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

Make syntax class for syntax properties.

Browse Source
This commit is contained in:
Eric Dobson 2013-11-14 21:19:36 -08:00
parent 87135b110b
commit 15fddbafe0
12 changed files with 199 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
View File

@ -90,6 +90,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
[typed-racket/env/type-name-env (register-type-name)])) [typed-racket/env/type-name-env (register-type-name)]))
(define-for-syntax (ignore stx) (ignore-property stx #t)) (define-for-syntax (ignore stx) (ignore-property stx #t))
(define-for-syntax (ignore-some stx) (ignore-some-property stx #t))
(begin-for-syntax (begin-for-syntax
(define-syntax-class opt-parent (define-syntax-class opt-parent
@ -233,10 +234,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-parse stx (syntax-parse stx
[(_ name:id ty:expr) [(_ name:id ty:expr)
#`(begin #`(begin
#,(ignore-property (if (eq? (syntax-local-context) 'top-level) #,(ignore (if (eq? (syntax-local-context) 'top-level)
#'(define name (procedure-rename (make-predicate ty) 'name)) #'(define name (procedure-rename (make-predicate ty) 'name))
(flat-contract-def-property #'(define name #f) #'ty)) (flat-contract-def-property #'(define name #f) #'ty)))
#t)
;; not a require, this is just the unchecked declaration syntax ;; not a require, this is just the unchecked declaration syntax
#,(internal #'(require/typed-internal name (Any -> Boolean : ty))))])) #,(internal #'(require/typed-internal name (Any -> Boolean : ty))))]))
@ -256,7 +256,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
type))) type)))
#`(ann #`(ann
#,(external-check-property (ignore-some-property name #t) check-valid-type) #,(external-check-property (ignore-some name) check-valid-type)
(Any -> Boolean : ty))) (Any -> Boolean : ty)))
(let ([typ (parse-type #'ty)]) (let ([typ (parse-type #'ty)])
(if (Error? typ) (if (Error? typ)
@ -264,15 +264,14 @@ This file defines two sorts of primitives. All of them are provided into any mod
#`(error 'make-predicate "Couldn't parse type") #`(error 'make-predicate "Couldn't parse type")
#`(#%expression #`(#%expression
(ann (ann
#,(ignore-some-property #,(ignore-some
(type->contract (type->contract
typ typ
;; must be a flat contract ;; must be a flat contract
#:kind 'flat #:kind 'flat
;; the value is not from the typed side ;; the value is not from the typed side
#:typed-side #f #:typed-side #f
(type->contract-fail typ #'ty #:ctc-str "predicate")) (type->contract-fail typ #'ty #:ctc-str "predicate")))
#t)
(Any -> Boolean : ty))))))])) (Any -> Boolean : ty))))))]))
(define-syntax (cast stx) (define-syntax (cast stx)
@ -281,7 +280,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define (apply-contract ctc-expr) (define (apply-contract ctc-expr)
#`(#%expression #`(#%expression
(ann (ann
#,(ignore-some-property #,(ignore-some
#`(let-values (((val) #,(with-type-property #'(ann v Any) #t))) #`(let-values (((val) #,(with-type-property #'(ann v Any) #t)))
(contract (contract
#,ctc-expr #,ctc-expr
@ -289,8 +288,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
'cast 'cast
'typed-world 'typed-world
val val
(quote-syntax #,stx))) (quote-syntax #,stx))))
#t)
ty))) ty)))
(cond [(not (unbox typed-context?)) ; no-check, don't check (cond [(not (unbox typed-context?)) ; no-check, don't check
@ -328,12 +326,12 @@ This file defines two sorts of primitives. All of them are provided into any mod
(with-syntax ([hidden (generate-temporary #'pred)]) (with-syntax ([hidden (generate-temporary #'pred)])
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
#,(ignore-property #'(define pred-cnt (any/c . c-> . boolean?)) #t) #,(ignore #'(define pred-cnt (any/c . c-> . boolean?)))
#,(internal #'(require/typed-internal hidden (Any -> Boolean : (Opaque pred)))) #,(internal #'(require/typed-internal hidden (Any -> Boolean : (Opaque pred))))
#,(if (attribute ne) #,(if (attribute ne)
(internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred)))) (internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred))))
(syntax/loc stx (define-type-alias ty (Opaque pred)))) (syntax/loc stx (define-type-alias ty (Opaque pred))))
#,(ignore-property #'(require/contract pred hidden pred-cnt lib) #t))))])) #,(ignore #'(require/contract pred hidden pred-cnt lib)))))]))
(begin-for-syntax (begin-for-syntax
(define-syntax-class type-variables (define-syntax-class type-variables
@ -530,9 +528,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty]) [(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty])
(with-syntax* (with-syntax*
([proc* (with-type-property #'(ann proc : proc-ty) #t)] ([proc* (with-type-property #'(ann proc : proc-ty) #t)]
[d-s (ignore-some-property (syntax/loc stx (define-struct nm (fld.name ...) [d-s (ignore-some (syntax/loc stx (define-struct nm (fld.name ...)
#:property prop:procedure proc*)) #:property prop:procedure proc*)))]
#t)]
[dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))]) [dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))])
#'(begin d-s dtsi))])) #'(begin d-s dtsi))]))
@ -603,9 +600,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
opts:struct-options) opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())] (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
[cname (second (build-struct-names #'nm.name empty #t #t))]) [cname (second (build-struct-names #'nm.name empty #t #t))])
(with-syntax ([d-s (ignore-some-property (with-syntax ([d-s (ignore-some
(syntax/loc stx (define-struct nm (fs.fld ...) . opts)) (syntax/loc stx (define-struct nm (fs.fld ...) . opts)))]
#t)]
[dtsi (quasisyntax/loc stx [dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...) nm (fs ...) (dtsi* (vars.vars ...) nm (fs ...)
#:maker #,cname #:maker #,cname
@ -632,10 +628,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...) [(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
opts:struct-options) opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]) (let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())])
(with-syntax ([d-s (ignore-property (quasisyntax/loc stx (with-syntax ([d-s (ignore (quasisyntax/loc stx
(struct #,@(attribute nm.new-spec) (fs.fld ...) (struct #,@(attribute nm.new-spec) (fs.fld ...)
. opts)) . opts)))]
#t)]
[dtsi (quasisyntax/loc stx [dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...) (dtsi* (vars.vars ...)
nm.old-spec (fs ...) nm.old-spec (fs ...)
@ -1161,9 +1156,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
(list (list
(attribute args.required-pos) (attribute args.required-pos)
(attribute args.optional-pos)))) (attribute args.optional-pos))))
(syntax-property (opt-lambda-property
(syntax-property d 'kw-lambda kw-property) (kw-lambda-property d kw-property)
'opt-lambda opt-property)] opt-property)]
;; This is an error and will be caught by the real lambda ;; This is an error and will be caught by the real lambda
[_ d])])) [_ d])]))

8
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/global-env.rkt vendored
View File

@ -4,6 +4,7 @@
;; maps identifiers to their types, updated by mutation ;; maps identifiers to their types, updated by mutation
(require "../types/tc-error.rkt" (require "../types/tc-error.rkt"
syntax/parse
syntax/id-table syntax/id-table
racket/lazy-require) racket/lazy-require)
(provide register-type register-type-if-undefined (provide register-type register-type-if-undefined
@ -11,6 +12,7 @@
maybe-finish-register-type maybe-finish-register-type
register-type/undefined register-type/undefined
lookup-type lookup-type
typed-id^
register-types register-types
unregister-type unregister-type
check-all-registered-types check-all-registered-types
@ -64,6 +66,12 @@
[(procedure? v) (define t (v)) (register-type id t) t] [(procedure? v) (define t (v)) (register-type id t) t]
[else v])) [else v]))
(define-syntax-class typed-id^
#:attributes (type)
(pattern i:id
#:attr type (lookup-type #'i #f)
#:when (attribute type)))
(define (maybe-finish-register-type id) (define (maybe-finish-register-type id)
(let ([v (free-id-table-ref the-mapping id)]) (let ([v (free-id-table-ref the-mapping id)])
(if (box? v) (if (box? v)

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/scoped-tvar-env.rkt vendored
View File

@ -4,6 +4,7 @@
(require "../utils/utils.rkt" (require "../utils/utils.rkt"
(for-template racket/base) (for-template racket/base)
(private syntax-properties)
syntax/parse syntax/parse
syntax/id-table syntax/id-table
racket/match racket/match
@ -31,9 +32,8 @@
[(#%expression e) (loop #'e)] [(#%expression e) (loop #'e)]
[(~or (case-lambda formals . body) (#%plain-lambda formals . body)) [(~or (case-lambda formals . body) (#%plain-lambda formals . body))
(add-vars stx)] (add-vars stx)]
[(let-values ([(f) fun]) . body) [(~and (let-values ([(f) fun]) . body)
#:when (or (syntax-property stx 'kw-lambda) (~or _:kw-lambda^ :opt-lambda^))
(syntax-property stx 'opt-lambda))
(add-vars #'fun)] (add-vars #'fun)]
[e (void)]))])) [e (void)]))]))

11
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/optimizer/optimizer.rkt
View File

@ -18,15 +18,12 @@
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:attributes (opt) #:attributes (opt)
;; Can't optimize this code because it isn't typechecked ;; Can't optimize this code because it isn't typechecked
(pattern opt:expr (pattern (~or opt:ignore^ opt:ignore-some^ opt:with-handlers^))
#:when (or (ignore-property #'opt)
(ignore-some-property #'opt)
(with-handlers-property #'opt)))
;; Can't optimize the body of this code because it isn't typechecked ;; Can't optimize the body of this code because it isn't typechecked
(pattern ((~and op let-values) (pattern (~and _:kw-lambda^
([(i:id) e-rhs:opt-expr]) e-body:expr ...) ((~and op let-values)
#:when (kw-lambda-property this-syntax) ([(i:id) e-rhs:opt-expr]) e-body:expr ...))
#:with opt (quasisyntax/loc/origin this-syntax #'op #:with opt (quasisyntax/loc/origin this-syntax #'op
(op ([(i) e-rhs.opt]) e-body ...))) (op ([(i) e-rhs.opt]) e-body ...)))

80
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt
View File

@ -1,43 +1,55 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base syntax/parse)) (require
syntax/parse
(for-syntax racket/base syntax/parse racket/syntax))
(define-syntax define-properties (define-syntax (define-properties stx)
(syntax-parser (define-syntax-class clause
((_ (name:id sym:id) ...) (pattern (root:id sym:id)
(with-syntax (((symbol ...) (generate-temporaries #'(sym ...)))) #:with name (format-id #'root "~a-property" #'root)
#`(begin #:with syntax-class-name (format-id #'root "~a^" #'root)
(begin #:with symbol (generate-temporary #'sym)))
;; TODO: make this an uninterned symbol once the phasing issue of the unit
;; tests is fixed (syntax-parse stx
(define symbol 'sym) ((_ :clause ...)
(provide name) #`(begin
(define name (begin
(case-lambda ;; TODO: make this an uninterned symbol once the phasing issue of the unit
((stx) (syntax-property stx symbol)) ;; tests is fixed
((stx value) (syntax-property stx symbol value))))) ...))))) (define symbol 'sym)
(provide name syntax-class-name)
(define name
(case-lambda
((stx) (syntax-property stx symbol))
((stx value) (syntax-property stx symbol value))))
(define-syntax-class syntax-class-name
#:attributes (value)
(pattern e
#:attr value (name #'e)
#:when (attribute value)))) ...))))
;;TODO add contracts on the properties ;;TODO add contracts on the properties
;;TODO make better interface for properties with values of only #t ;;TODO make better interface for properties with values of only #t
(define-properties (define-properties
(plambda-property typechecker:plambda) (plambda typechecker:plambda)
(ignore-property typechecker:ignore) (ignore typechecker:ignore)
(ignore-some-property typechecker:ignore-some) (ignore-some typechecker:ignore-some)
(contract-def/maker-property typechecker:contract-def/maker) (contract-def/maker typechecker:contract-def/maker)
(contract-def-property typechecker:contract-def) (contract-def typechecker:contract-def)
(flat-contract-def-property typechecker:flat-contract-def) (flat-contract-def typechecker:flat-contract-def)
(external-check-property typechecker:external-check) (external-check typechecker:external-check)
(with-type-property typechecker:with-type) (with-type typechecker:with-type)
(type-ascription-property type-ascription) (type-ascription type-ascription)
(type-inst-property type-inst) (type-inst type-inst)
(type-label-property type-label) (type-label type-label)
(type-dotted-property type-dotted) (type-dotted type-dotted)
(exn-handler-property typechecker:exn-handler) (exn-handler typechecker:exn-handler)
(exn-body-property typechecker:exn-body) (exn-body typechecker:exn-body)
(with-handlers-property typechecker:with-handlers) (with-handlers typechecker:with-handlers)
(struct-info-property struct-info) (struct-info struct-info)
(opt-lambda-property opt-lambda) (opt-lambda opt-lambda)
(kw-lambda-property kw-lambda) (kw-lambda kw-lambda)
(tail-position-property typechecker:called-in-tail-position) (tail-position typechecker:called-in-tail-position)
) )

59
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-annotation.rkt
View File

@ -7,6 +7,7 @@
(except-in (types subtype union utils generalize)) (except-in (types subtype union utils generalize))
(private parse-type syntax-properties) (private parse-type syntax-properties)
(contract-req) (contract-req)
syntax/parse
racket/match) racket/match)
(provide type-annotation (provide type-annotation
@ -36,16 +37,12 @@
(parse-type/id stx prop))) (parse-type/id stx prop)))
;(unless let-binding (error 'ohno)) ;(unless let-binding (error 'ohno))
;(printf "in type-annotation:~a\n" (syntax->datum stx)) ;(printf "in type-annotation:~a\n" (syntax->datum stx))
(cond (syntax-parse stx
[(type-label-property stx) => pt] [(~or v:type-label^ v:type-ascription^) (pt (attribute v.value))]
[(type-ascription-property stx) => pt] [i:typed-id^
;; this is so that : annotation works in internal def ctxts (maybe-finish-register-type stx)
[(and (identifier? stx) (lookup-type stx (lambda () #f))) (attribute i.type)]
=> [_ #f]))
(lambda (t)
(maybe-finish-register-type stx)
t)]
[else #f]))
;(trace type-annotation) ;(trace type-annotation)
@ -55,30 +52,27 @@
(if (syntax? prop) (if (syntax? prop)
(parse-tc-results prop) (parse-tc-results prop)
(parse-tc-results/id stx prop))) (parse-tc-results/id stx prop)))
(cond (syntax-parse stx
[(type-ascription-property stx) [s:type-ascription^
=> (let loop ((prop (attribute s.value)))
(lambda (prop) (if (pair? prop)
(let loop ((prop prop)) (loop (cdr prop))
(if (pair? prop) (pt prop)))]
(loop (cdr prop)) [_ #f]))
(pt prop))))]
[else #f]))
(define (remove-ascription stx) (define (remove-ascription stx)
(type-ascription-property (type-ascription-property
stx stx
(cond (syntax-parse stx
[(type-ascription-property stx) [s:type-ascription^
=> (define prop (attribute s.value))
(lambda (prop) (if (pair? prop)
(if (pair? prop) (let loop ((prop (cdr prop)) (last (car prop)))
(let loop ((prop (cdr prop)) (last (car prop))) (if (pair? prop)
(if (pair? prop) (cons last (loop (cdr prop) (car prop)))
(cons last (loop (cdr prop) (car prop))) last))
last)) #f)]
#f))] [_ #f])))
[else #f])))
;; get the type annotation of this identifier, otherwise error ;; get the type annotation of this identifier, otherwise error
;; if #:default is provided, return that instead of error ;; if #:default is provided, return that instead of error
@ -143,5 +137,6 @@
(tc-error "Body had type:\n~a\nVariable had type:\n~a\n" e-type ty)))) (tc-error "Body had type:\n~a\nVariable had type:\n~a\n" e-type ty))))
(define (dotted? stx) (define (dotted? stx)
(cond [(type-dotted-property stx) => syntax-e] (syntax-parse stx
[else #f])) [v:type-dotted^ (syntax-e (attribute v.value))]
[_ #f]))

43
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
View File

@ -19,6 +19,7 @@
unstable/list unstable/list
unstable/sequence unstable/sequence
(contract-req) (contract-req)
(for-syntax racket/base syntax/parse racket/syntax)
(for-template racket/base racket/contract racket/set (utils any-wrap) (for-template racket/base racket/contract racket/set (utils any-wrap)
(prefix-in t: (types numeric-predicates)) (prefix-in t: (types numeric-predicates))
(only-in unstable/contract sequence/c) (only-in unstable/contract sequence/c)
@ -27,25 +28,27 @@
;; These check if either the define form or the body form has the syntax ;; These check if either the define form or the body form has the syntax
;; property. Normally the define form will have the property but lifting an ;; property. Normally the define form will have the property but lifting an
;; expression to the module level will put the property on the body. ;; expression to the module level will put the property on the body.
(define-values (typechecker:contract-def (define-syntax (contract-finders stx)
typechecker:flat-contract-def (define-syntax-class clause
typechecker:contract-def/maker) (pattern name:id
(let () #:with external-name (format-id #'name "typechecker:~a" #'name)
(define ((get-contract-def property) stx) #:with syntax-class-name (format-id #'name "~a^" #'name)))
(or (property stx) (syntax-parse stx
(syntax-case stx (define-values) [(_ #:union union-name:id :clause ... )
((define-values (name) body) #'(begin
(property #'body)) (define external-name
(_ #f)))) (syntax-parser
(values #:literal-sets (kernel-literals)
(get-contract-def contract-def-property) [(~or (~var v syntax-class-name)
(get-contract-def flat-contract-def-property) (define-values (_) (~var v syntax-class-name)))
(get-contract-def contract-def/maker-property)))) (attribute v.value)]
[_ #f])) ...
(define (union-name stx)
(or (external-name stx) ...)))]))
(define (define/fixup-contract? stx) (contract-finders
(or (typechecker:contract-def stx) #:union define/fixup-contract?
(typechecker:flat-contract-def stx) contract-def flat-contract-def contract-def/maker)
(typechecker:contract-def/maker stx)))
;; type->contract-fail : Syntax Type #:ctc-str String ;; type->contract-fail : Syntax Type #:ctc-str String
;; -> #:reason (Option String) -> Void ;; -> #:reason (Option String) -> Void
@ -144,7 +147,7 @@
(define (type->contract ty fail #:typed-side [typed-side #t] #:kind [kind 'impersonator]) (define (type->contract ty fail #:typed-side [typed-side #t] #:kind [kind 'impersonator])
(define vars (make-parameter '())) (define vars (make-parameter '()))
(define current-contract-kind (make-parameter flat-sym)) (define current-contract-kind (make-parameter flat-sym))
(define (increase-current-contract-kind! kind) (define (increase-current-contract-kind! kind)
(current-contract-kind (contract-kind-max (current-contract-kind) kind))) (current-contract-kind (contract-kind-max (current-contract-kind) kind)))
@ -481,7 +484,7 @@
#`(syntax/c #,(t->c t #:kind flat-sym))] #`(syntax/c #,(t->c t #:kind flat-sym))]
[(Value: v) #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v)))] [(Value: v) #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v)))]
;; TODO Is this sound? ;; TODO Is this sound?
[(Param: in out) [(Param: in out)
(set-impersonator!) (set-impersonator!)
#`(parameter/c #,(t->c in) #,(t->c out))] #`(parameter/c #,(t->c in) #,(t->c out))]
[(Hashtable: k v) [(Hashtable: k v)

35
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt
View File

@ -54,21 +54,18 @@
(let loop ([form form]) (let loop ([form form])
(parameterize ([current-orig-stx form]) (parameterize ([current-orig-stx form])
(syntax-parse form (syntax-parse form
[stx ;; if this needs to be checked
;; if this needs to be checked [stx:with-type^
#:when (with-type-property form)
;; the form should be already ascribed the relevant type ;; the form should be already ascribed the relevant type
(tc-expr form)] (tc-expr form)]
[stx ;; this is a handler function
;; this is a handler function [stx:exn-handler^
#:when (exn-handler-property form)
(let ([t (single-value form)]) (let ([t (single-value form)])
(match t (match t
[(tc-result1: t) [(tc-result1: t)
(set! handler-tys (cons (get-result-ty t) handler-tys))]))] (set! handler-tys (cons (get-result-ty t) handler-tys))]))]
[stx ;; this is the body of the with-handlers
;; this is the body of the with-handlers [stx:exn-body^
#:when (exn-body-property form)
(set! body-stx form) (set! body-stx form)
(set! body-ty (tc-expr form))] (set! body-ty (tc-expr form))]
[(a . b) [(a . b)
@ -82,18 +79,15 @@
(let loop ([form form]) (let loop ([form form])
(parameterize ([current-orig-stx form]) (parameterize ([current-orig-stx form])
(syntax-parse form (syntax-parse form
[stx ;; if this needs to be checked
;; if this needs to be checked [stx:with-type^
#:when (with-type-property form)
;; the form should be already ascribed the relevant type ;; the form should be already ascribed the relevant type
(tc-expr form)] (tc-expr form)]
[stx ;; this is a handler function
;; this is a handler function [stx:exn-handler^
#:when (exn-handler-property form)
(tc-expr/check form (ret (-> (Un) (tc-results->values expected))))] (tc-expr/check form (ret (-> (Un) (tc-results->values expected))))]
[stx ;; this is the body of the with-handlers
;; this is the body of the with-handlers [stx:exn-body^
#:when (exn-body-property form)
(tc-expr/check form expected)] (tc-expr/check form expected)]
[(a . b) [(a . b)
(begin (begin
@ -107,9 +101,8 @@
(define (check-subforms/ignore form) (define (check-subforms/ignore form)
(let loop ([form form]) (let loop ([form form])
(syntax-parse form (syntax-parse form
[stx ;; if this needs to be checked
;; if this needs to be checked [stx:with-type^
#:when (with-type-property form)
;; the form should be already ascribed the relevant type ;; the form should be already ascribed the relevant type
(void (tc-expr form))] (void (tc-expr form))]
[(a . b) [(a . b)

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-app/tc-app-main.rkt
View File

@ -17,9 +17,7 @@
(define-syntax-class annotated-op (define-syntax-class annotated-op
(pattern i:identifier (pattern (~and i:identifier (~or :type-inst^ :type-ascription^))))
#:when (or (type-inst-property #'i)
(type-ascription-property #'i))))
(define-tc/app-syntax-class (tc/app-annotated expected) (define-tc/app-syntax-class (tc/app-annotated expected)
;; Just do regular typechecking if we have one of these. ;; Just do regular typechecking if we have one of these.

20
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -180,11 +180,9 @@
(syntax-parse form (syntax-parse form
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:literals (find-method/who) #:literals (find-method/who)
[stx [stx:with-handlers^
#:when (with-handlers-property form)
(check-subforms/with-handlers/check form expected)] (check-subforms/with-handlers/check form expected)]
[stx [stx:ignore-some^
#:when (ignore-some-property form)
(check-subforms/ignore form) (check-subforms/ignore form)
;; We trust ignore to be only on syntax objects objects that are well typed ;; We trust ignore to be only on syntax objects objects that are well typed
expected] expected]
@ -267,8 +265,7 @@
(#%plain-app _ _ _arg-var2 ...)))))) (#%plain-app _ _ _arg-var2 ...))))))
(tc/send #'find-app #'rcvr #'meth #'(args ...) expected)] (tc/send #'find-app #'rcvr #'meth #'(args ...) expected)]
;; kw function def ;; kw function def
[(let-values ([(_) fun]) . body) [(~and (let-values ([(f) fun]) . body) _:kw-lambda^)
#:when (syntax-property form 'kw-lambda)
(match expected (match expected
[(tc-result1: (and f (or (Function: _) [(tc-result1: (and f (or (Function: _)
(Poly: _ (Function: _))))) (Poly: _ (Function: _)))))
@ -277,13 +274,12 @@
(tc-error/expr "Keyword functions must have function type, given ~a" expected)]) (tc-error/expr "Keyword functions must have function type, given ~a" expected)])
expected] expected]
;; opt function def ;; opt function def
[(let-values ([(f) fun]) . body) [(~and (let-values ([(f) fun]) . body) opt:opt-lambda^)
#:when (syntax-property form 'opt-lambda)
(define conv-type (define conv-type
(match expected (match expected
[(tc-result1: fun-type) [(tc-result1: fun-type)
(match-define (list required-pos optional-pos) (match-define (list required-pos optional-pos)
(syntax-property form 'opt-lambda)) (attribute opt.value))
(opt-convert fun-type required-pos optional-pos)] (opt-convert fun-type required-pos optional-pos)]
[_ #f])) [_ #f]))
(match-define (tc-result1: returned-fun-type) (match-define (tc-result1: returned-fun-type)
@ -321,14 +317,12 @@
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:literals (#%app lambda find-method/who) #:literals (#%app lambda find-method/who)
;; ;;
[stx [stx:with-handlers^
#:when (with-handlers-property form)
(let ([ty (check-subforms/with-handlers form)]) (let ([ty (check-subforms/with-handlers form)])
(unless ty (unless ty
(int-err "internal error: with-handlers")) (int-err "internal error: with-handlers"))
ty)] ty)]
[stx [stx:ignore-some^
#:when (ignore-some-property form)
(check-subforms/ignore form) (check-subforms/ignore form)
(ret Univ)] (ret Univ)]
;; explicit failure ;; explicit failure

25
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt
View File

@ -87,18 +87,11 @@
(tc-body/check body (erase-filter expected)) (tc-body/check body (erase-filter expected))
(tc-body body))))))) (tc-body body)))))))
(define (tc-expr/maybe-expected/t e name) (define (tc-expr/maybe-expected/t e names)
(define expecteds (syntax-parse names
(map (lambda (stx) (lookup-type stx (lambda () #f))) name)) [(i:typed-id^ ...)
(define mk (if (and (pair? expecteds) (null? (cdr expecteds))) (tc-expr/check e (-values (attribute i.type)))]
car [_ (tc-expr e)]))
-values))
(define tcr
(if
(andmap values expecteds)
(tc-expr/check e (mk expecteds))
(tc-expr e)))
tcr)
(define (tc/letrec-values namess exprs body form [expected #f]) (define (tc/letrec-values namess exprs body form [expected #f])
(let* ([names (stx-map syntax->list namess)] (let* ([names (stx-map syntax->list namess)]
@ -206,11 +199,11 @@
;; say that this binding is only called in tail position ;; say that this binding is only called in tail position
(define ((tc-expr-t/maybe-expected expected) e) (define ((tc-expr-t/maybe-expected expected) e)
(syntax-parse e #:literals (#%plain-lambda) (syntax-parse e #:literals (#%plain-lambda)
[(#%plain-lambda () _) [(~and (#%plain-lambda () _) _:tail-position^)
#:fail-unless (and expected (tail-position-property e)) #f #:when expected
(tc-expr/check e (ret (t:-> (tc-results->values expected))))] (tc-expr/check e (ret (t:-> (tc-results->values expected))))]
[_ [_:tail-position^
#:fail-unless (and expected (tail-position-property e)) #f #:when expected
(tc-expr/check e expected)] (tc-expr/check e expected)]
[_ (tc-expr e)])) [_ (tc-expr e)]))

74
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -59,8 +59,7 @@
;#:literal-sets (kernel-literals) ;#:literal-sets (kernel-literals)
;; forms that are handled in other ways ;; forms that are handled in other ways
[stx [(~or _:ignore^ _:ignore-some^)
#:when (or (ignore-property form) (ignore-some-property form))
(list)] (list)]
[((~literal module) n:id spec ((~literal #%plain-module-begin) body ...)) [((~literal module) n:id spec ((~literal #%plain-module-begin) body ...))
@ -116,29 +115,29 @@
;; values definitions ;; values definitions
[(define-values (var ...) expr) [(define-values (var ...) expr)
(let* ([vars (syntax->list #'(var ...))]) (define vars (syntax->list #'(var ...)))
(cond (syntax-parse vars
;; if all the variables have types, we stick them into the environment ;; if all the variables have types, we stick them into the environment
[(andmap type-label-property vars) [(v:type-label^ ...)
(let ([ts (map (λ (x) (get-type x #:infer #f)) vars)]) (let ([ts (map (λ (x) (get-type x #:infer #f)) vars)])
(for-each register-type-if-undefined vars ts) (for-each register-type-if-undefined vars ts)
(map make-def-binding vars ts))] (map make-def-binding vars ts))]
;; if this already had an annotation, we just construct the binding reps ;; if this already had an annotation, we just construct the binding reps
[(andmap (lambda (s) (lookup-type s (lambda () #f))) vars) [(v:typed-id^ ...)
(define top-level? (eq? (syntax-local-context) 'top-level)) (define top-level? (eq? (syntax-local-context) 'top-level))
(for ([var (in-list vars)]) (for ([var (in-list vars)])
(when (dict-has-key? unann-defs var) (when (dict-has-key? unann-defs var)
(free-id-table-remove! unann-defs var)) (free-id-table-remove! unann-defs var))
(finish-register-type var top-level?)) (finish-register-type var top-level?))
(map (lambda (s) (make-def-binding s (lookup-type s))) vars)] (stx-map make-def-binding #'(v ...) (attribute v.type))]
;; special case to infer types for top level defines ;; special case to infer types for top level defines
[else [_
(match (get-type/infer vars #'expr tc-expr tc-expr/check) (match (get-type/infer vars #'expr tc-expr tc-expr/check)
[(tc-results: ts) [(tc-results: ts)
(for/list ([i (in-list vars)] [t (in-list ts)]) (for/list ([i (in-list vars)] [t (in-list ts)])
(register-type i t) (register-type i t)
(free-id-table-set! unann-defs i #t) (free-id-table-set! unann-defs i #t)
(make-def-binding i t))])]))] (make-def-binding i t))])])]
;; to handle the top-level, we have to recur into begins ;; to handle the top-level, we have to recur into begins
[(begin . rest) [(begin . rest)
@ -164,13 +163,11 @@
(syntax-parse form (syntax-parse form
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
;; these forms we have been instructed to ignore ;; these forms we have been instructed to ignore
[stx [stx:ignore^
#:when (ignore-property form)
(void)] (void)]
;; this is a form that we mostly ignore, but we check some interior parts ;; this is a form that we mostly ignore, but we check some interior parts
[stx [stx:ignore-some^
#:when (ignore-some-property form)
(check-subforms/ignore form)] (check-subforms/ignore form)]
;; these forms should always be ignored ;; these forms should always be ignored
@ -185,13 +182,14 @@
[(define-values () expr) [(define-values () expr)
(tc-expr/check #'expr (ret empty))] (tc-expr/check #'expr (ret empty))]
[(define-values (var ...) expr) [(define-values (var ...) expr)
(unless (for/and ([v (in-syntax #'(var ...))]) #:when (for/and ([v (in-syntax #'(var ...))])
(free-id-table-ref unann-defs v (lambda _ #f))) (free-id-table-ref unann-defs v (lambda _ #f)))
(let ([ts (stx-map lookup-type #'(var ...))])
(when (= 1 (length ts))
(add-scoped-tvars #'expr (lookup-scoped-tvars (stx-car #'(var ...)))))
(tc-expr/check #'expr (ret ts))))
(void)] (void)]
[(define-values (var:typed-id^ ...) expr)
(let ([ts (attribute var.type)])
(when (= 1 (length ts))
(add-scoped-tvars #'expr (lookup-scoped-tvars (stx-car #'(var ...)))))
(tc-expr/check #'expr (ret ts))) ]
;; to handle the top-level, we have to recur into begins ;; to handle the top-level, we have to recur into begins
[(begin) (void)] [(begin) (void)]
@ -365,9 +363,9 @@
;; syntax -> (values #f (or/c void? tc-results/c)) ;; syntax -> (values #f (or/c void? tc-results/c))
(define (tc-toplevel-form form) (define (tc-toplevel-form form)
(syntax-parse form (syntax-parse form
[((~literal begin) e ...) ;; Don't open up `begin`s that are supposed to be ignored
;; Don't open up `begin`s that are supposed to be ignored [(~and ((~literal begin) e ...)
#:when (not (or (ignore-property form) (ignore-some-property form))) (~not (~or _:ignore^ _:ignore-some^)))
(define result (define result
(for/last ([form (in-syntax #'(e ...))]) (for/last ([form (in-syntax #'(e ...))])
(define-values (_ result) (tc-toplevel-form form)) (define-values (_ result) (tc-toplevel-form form))