Make syntax class for syntax properties.
This commit is contained in:
Eric Dobson
parent
87135b110b
commit
15fddbafe0
|
|
@ -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)]))
|
||||
|
||||
(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
|
||||
|
|
@ -233,10 +234,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
(syntax-parse stx
|
||||
[(_ name:id ty:expr)
|
||||
#`(begin
|
||||
#,(ignore-property (if (eq? (syntax-local-context) 'top-level)
|
||||
#'(define name (procedure-rename (make-predicate ty) 'name))
|
||||
(flat-contract-def-property #'(define name #f) #'ty))
|
||||
#t)
|
||||
#,(ignore (if (eq? (syntax-local-context) 'top-level)
|
||||
#'(define name (procedure-rename (make-predicate ty) 'name))
|
||||
(flat-contract-def-property #'(define name #f) #'ty)))
|
||||
;; not a require, this is just the unchecked declaration syntax
|
||||
#,(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)))
|
||||
|
||||
#`(ann
|
||||
#,(external-check-property (ignore-some-property name #t) check-valid-type)
|
||||
#,(external-check-property (ignore-some name) check-valid-type)
|
||||
(Any -> Boolean : ty)))
|
||||
(let ([typ (parse-type #'ty)])
|
||||
(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")
|
||||
#`(#%expression
|
||||
(ann
|
||||
#,(ignore-some-property
|
||||
#,(ignore-some
|
||||
(type->contract
|
||||
typ
|
||||
;; must be a flat contract
|
||||
#:kind 'flat
|
||||
;; the value is not from the typed side
|
||||
#:typed-side #f
|
||||
(type->contract-fail typ #'ty #:ctc-str "predicate"))
|
||||
#t)
|
||||
(type->contract-fail typ #'ty #:ctc-str "predicate")))
|
||||
(Any -> Boolean : ty))))))]))
|
||||
|
||||
(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)
|
||||
#`(#%expression
|
||||
(ann
|
||||
#,(ignore-some-property
|
||||
#,(ignore-some
|
||||
#`(let-values (((val) #,(with-type-property #'(ann v Any) #t)))
|
||||
(contract
|
||||
#,ctc-expr
|
||||
|
|
@ -289,8 +288,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
'cast
|
||||
'typed-world
|
||||
val
|
||||
(quote-syntax #,stx)))
|
||||
#t)
|
||||
(quote-syntax #,stx))))
|
||||
ty)))
|
||||
|
||||
(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)])
|
||||
(quasisyntax/loc stx
|
||||
(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))))
|
||||
#,(if (attribute ne)
|
||||
(internal (syntax/loc stx (define-type-alias-internal 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
|
||||
(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])
|
||||
(with-syntax*
|
||||
([proc* (with-type-property #'(ann proc : proc-ty) #t)]
|
||||
[d-s (ignore-some-property (syntax/loc stx (define-struct nm (fld.name ...)
|
||||
#:property prop:procedure proc*))
|
||||
#t)]
|
||||
[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))])
|
||||
#'(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)
|
||||
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
|
||||
[cname (second (build-struct-names #'nm.name empty #t #t))])
|
||||
(with-syntax ([d-s (ignore-some-property
|
||||
(syntax/loc stx (define-struct nm (fs.fld ...) . opts))
|
||||
#t)]
|
||||
(with-syntax ([d-s (ignore-some
|
||||
(syntax/loc stx (define-struct nm (fs.fld ...) . opts)))]
|
||||
[dtsi (quasisyntax/loc stx
|
||||
(dtsi* (vars.vars ...) nm (fs ...)
|
||||
#: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 ...)
|
||||
opts:struct-options)
|
||||
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())])
|
||||
(with-syntax ([d-s (ignore-property (quasisyntax/loc stx
|
||||
(struct #,@(attribute nm.new-spec) (fs.fld ...)
|
||||
. opts))
|
||||
#t)]
|
||||
(with-syntax ([d-s (ignore (quasisyntax/loc stx
|
||||
(struct #,@(attribute nm.new-spec) (fs.fld ...)
|
||||
. opts)))]
|
||||
[dtsi (quasisyntax/loc stx
|
||||
(dtsi* (vars.vars ...)
|
||||
nm.old-spec (fs ...)
|
||||
|
|
@ -1161,9 +1156,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
(list
|
||||
(attribute args.required-pos)
|
||||
(attribute args.optional-pos))))
|
||||
(syntax-property
|
||||
(syntax-property d 'kw-lambda kw-property)
|
||||
'opt-lambda opt-property)]
|
||||
(opt-lambda-property
|
||||
(kw-lambda-property d kw-property)
|
||||
opt-property)]
|
||||
;; This is an error and will be caught by the real lambda
|
||||
[_ d])]))
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
;; maps identifiers to their types, updated by mutation
|
||||
|
||||
(require "../types/tc-error.rkt"
|
||||
syntax/parse
|
||||
syntax/id-table
|
||||
racket/lazy-require)
|
||||
(provide register-type register-type-if-undefined
|
||||
|
|
@ -11,6 +12,7 @@
|
|||
maybe-finish-register-type
|
||||
register-type/undefined
|
||||
lookup-type
|
||||
typed-id^
|
||||
register-types
|
||||
unregister-type
|
||||
check-all-registered-types
|
||||
|
|
@ -64,6 +66,12 @@
|
|||
[(procedure? v) (define t (v)) (register-type id t) t]
|
||||
[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)
|
||||
(let ([v (free-id-table-ref the-mapping id)])
|
||||
(if (box? v)
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
|
||||
(require "../utils/utils.rkt"
|
||||
(for-template racket/base)
|
||||
(private syntax-properties)
|
||||
syntax/parse
|
||||
syntax/id-table
|
||||
racket/match
|
||||
|
|
@ -31,9 +32,8 @@
|
|||
[(#%expression e) (loop #'e)]
|
||||
[(~or (case-lambda formals . body) (#%plain-lambda formals . body))
|
||||
(add-vars stx)]
|
||||
[(let-values ([(f) fun]) . body)
|
||||
#:when (or (syntax-property stx 'kw-lambda)
|
||||
(syntax-property stx 'opt-lambda))
|
||||
[(~and (let-values ([(f) fun]) . body)
|
||||
(~or _:kw-lambda^ :opt-lambda^))
|
||||
(add-vars #'fun)]
|
||||
[e (void)]))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -18,15 +18,12 @@
|
|||
#:literal-sets (kernel-literals)
|
||||
#:attributes (opt)
|
||||
;; Can't optimize this code because it isn't typechecked
|
||||
(pattern opt:expr
|
||||
#:when (or (ignore-property #'opt)
|
||||
(ignore-some-property #'opt)
|
||||
(with-handlers-property #'opt)))
|
||||
(pattern (~or opt:ignore^ opt:ignore-some^ opt:with-handlers^))
|
||||
|
||||
;; Can't optimize the body of this code because it isn't typechecked
|
||||
(pattern ((~and op let-values)
|
||||
([(i:id) e-rhs:opt-expr]) e-body:expr ...)
|
||||
#:when (kw-lambda-property this-syntax)
|
||||
(pattern (~and _:kw-lambda^
|
||||
((~and op let-values)
|
||||
([(i:id) e-rhs:opt-expr]) e-body:expr ...))
|
||||
#:with opt (quasisyntax/loc/origin this-syntax #'op
|
||||
(op ([(i) e-rhs.opt]) e-body ...)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,43 +1,55 @@
|
|||
#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
|
||||
(syntax-parser
|
||||
((_ (name:id sym:id) ...)
|
||||
(with-syntax (((symbol ...) (generate-temporaries #'(sym ...))))
|
||||
#`(begin
|
||||
(begin
|
||||
;; TODO: make this an uninterned symbol once the phasing issue of the unit
|
||||
;; tests is fixed
|
||||
(define symbol 'sym)
|
||||
(provide name)
|
||||
(define name
|
||||
(case-lambda
|
||||
((stx) (syntax-property stx symbol))
|
||||
((stx value) (syntax-property stx symbol value))))) ...)))))
|
||||
(define-syntax (define-properties stx)
|
||||
(define-syntax-class clause
|
||||
(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)))
|
||||
|
||||
(syntax-parse stx
|
||||
((_ :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))))
|
||||
(define-syntax-class syntax-class-name
|
||||
#:attributes (value)
|
||||
(pattern e
|
||||
#:attr value (name #'e)
|
||||
#:when (attribute value)))) ...))))
|
||||
|
||||
;;TODO add contracts on the properties
|
||||
;;TODO make better interface for properties with values of only #t
|
||||
|
||||
(define-properties
|
||||
(plambda-property typechecker:plambda)
|
||||
(ignore-property typechecker:ignore)
|
||||
(ignore-some-property typechecker:ignore-some)
|
||||
(contract-def/maker-property typechecker:contract-def/maker)
|
||||
(contract-def-property typechecker:contract-def)
|
||||
(flat-contract-def-property typechecker:flat-contract-def)
|
||||
(external-check-property typechecker:external-check)
|
||||
(with-type-property typechecker:with-type)
|
||||
(type-ascription-property type-ascription)
|
||||
(type-inst-property type-inst)
|
||||
(type-label-property type-label)
|
||||
(type-dotted-property type-dotted)
|
||||
(exn-handler-property typechecker:exn-handler)
|
||||
(exn-body-property typechecker:exn-body)
|
||||
(with-handlers-property typechecker:with-handlers)
|
||||
(struct-info-property struct-info)
|
||||
(opt-lambda-property opt-lambda)
|
||||
(kw-lambda-property kw-lambda)
|
||||
(tail-position-property typechecker:called-in-tail-position)
|
||||
(plambda typechecker:plambda)
|
||||
(ignore typechecker:ignore)
|
||||
(ignore-some typechecker:ignore-some)
|
||||
(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)
|
||||
(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)
|
||||
(struct-info struct-info)
|
||||
(opt-lambda opt-lambda)
|
||||
(kw-lambda kw-lambda)
|
||||
(tail-position typechecker:called-in-tail-position)
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@
|
|||
(except-in (types subtype union utils generalize))
|
||||
(private parse-type syntax-properties)
|
||||
(contract-req)
|
||||
syntax/parse
|
||||
racket/match)
|
||||
|
||||
(provide type-annotation
|
||||
|
|
@ -36,16 +37,12 @@
|
|||
(parse-type/id stx prop)))
|
||||
;(unless let-binding (error 'ohno))
|
||||
;(printf "in type-annotation:~a\n" (syntax->datum stx))
|
||||
(cond
|
||||
[(type-label-property stx) => pt]
|
||||
[(type-ascription-property stx) => pt]
|
||||
;; this is so that : annotation works in internal def ctxts
|
||||
[(and (identifier? stx) (lookup-type stx (lambda () #f)))
|
||||
=>
|
||||
(lambda (t)
|
||||
(maybe-finish-register-type stx)
|
||||
t)]
|
||||
[else #f]))
|
||||
(syntax-parse stx
|
||||
[(~or v:type-label^ v:type-ascription^) (pt (attribute v.value))]
|
||||
[i:typed-id^
|
||||
(maybe-finish-register-type stx)
|
||||
(attribute i.type)]
|
||||
[_ #f]))
|
||||
|
||||
;(trace type-annotation)
|
||||
|
||||
|
|
@ -55,30 +52,27 @@
|
|||
(if (syntax? prop)
|
||||
(parse-tc-results prop)
|
||||
(parse-tc-results/id stx prop)))
|
||||
(cond
|
||||
[(type-ascription-property stx)
|
||||
=>
|
||||
(lambda (prop)
|
||||
(let loop ((prop prop))
|
||||
(if (pair? prop)
|
||||
(loop (cdr prop))
|
||||
(pt prop))))]
|
||||
[else #f]))
|
||||
(syntax-parse stx
|
||||
[s:type-ascription^
|
||||
(let loop ((prop (attribute s.value)))
|
||||
(if (pair? prop)
|
||||
(loop (cdr prop))
|
||||
(pt prop)))]
|
||||
[_ #f]))
|
||||
|
||||
(define (remove-ascription stx)
|
||||
(type-ascription-property
|
||||
stx
|
||||
(cond
|
||||
[(type-ascription-property stx)
|
||||
=>
|
||||
(lambda (prop)
|
||||
(if (pair? prop)
|
||||
(let loop ((prop (cdr prop)) (last (car prop)))
|
||||
(if (pair? prop)
|
||||
(cons last (loop (cdr prop) (car prop)))
|
||||
last))
|
||||
#f))]
|
||||
[else #f])))
|
||||
(syntax-parse stx
|
||||
[s:type-ascription^
|
||||
(define prop (attribute s.value))
|
||||
(if (pair? prop)
|
||||
(let loop ((prop (cdr prop)) (last (car prop)))
|
||||
(if (pair? prop)
|
||||
(cons last (loop (cdr prop) (car prop)))
|
||||
last))
|
||||
#f)]
|
||||
[_ #f])))
|
||||
|
||||
;; get the type annotation of this identifier, otherwise 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))))
|
||||
|
||||
(define (dotted? stx)
|
||||
(cond [(type-dotted-property stx) => syntax-e]
|
||||
[else #f]))
|
||||
(syntax-parse stx
|
||||
[v:type-dotted^ (syntax-e (attribute v.value))]
|
||||
[_ #f]))
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@
|
|||
unstable/list
|
||||
unstable/sequence
|
||||
(contract-req)
|
||||
(for-syntax racket/base syntax/parse racket/syntax)
|
||||
(for-template racket/base racket/contract racket/set (utils any-wrap)
|
||||
(prefix-in t: (types numeric-predicates))
|
||||
(only-in unstable/contract sequence/c)
|
||||
|
|
@ -27,25 +28,27 @@
|
|||
;; 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
|
||||
;; expression to the module level will put the property on the body.
|
||||
(define-values (typechecker:contract-def
|
||||
typechecker:flat-contract-def
|
||||
typechecker:contract-def/maker)
|
||||
(let ()
|
||||
(define ((get-contract-def property) stx)
|
||||
(or (property stx)
|
||||
(syntax-case stx (define-values)
|
||||
((define-values (name) body)
|
||||
(property #'body))
|
||||
(_ #f))))
|
||||
(values
|
||||
(get-contract-def contract-def-property)
|
||||
(get-contract-def flat-contract-def-property)
|
||||
(get-contract-def contract-def/maker-property))))
|
||||
(define-syntax (contract-finders stx)
|
||||
(define-syntax-class clause
|
||||
(pattern name:id
|
||||
#:with external-name (format-id #'name "typechecker:~a" #'name)
|
||||
#:with syntax-class-name (format-id #'name "~a^" #'name)))
|
||||
(syntax-parse stx
|
||||
[(_ #:union union-name:id :clause ... )
|
||||
#'(begin
|
||||
(define external-name
|
||||
(syntax-parser
|
||||
#:literal-sets (kernel-literals)
|
||||
[(~or (~var v syntax-class-name)
|
||||
(define-values (_) (~var v syntax-class-name)))
|
||||
(attribute v.value)]
|
||||
[_ #f])) ...
|
||||
(define (union-name stx)
|
||||
(or (external-name stx) ...)))]))
|
||||
|
||||
(define (define/fixup-contract? stx)
|
||||
(or (typechecker:contract-def stx)
|
||||
(typechecker:flat-contract-def stx)
|
||||
(typechecker:contract-def/maker stx)))
|
||||
(contract-finders
|
||||
#:union define/fixup-contract?
|
||||
contract-def flat-contract-def contract-def/maker)
|
||||
|
||||
;; type->contract-fail : Syntax Type #:ctc-str String
|
||||
;; -> #:reason (Option String) -> Void
|
||||
|
|
@ -144,7 +147,7 @@
|
|||
|
||||
|
||||
(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 (increase-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))]
|
||||
[(Value: v) #`(flat-named-contract '#,v (lambda (x) (equal? x '#,v)))]
|
||||
;; TODO Is this sound?
|
||||
[(Param: in out)
|
||||
[(Param: in out)
|
||||
(set-impersonator!)
|
||||
#`(parameter/c #,(t->c in) #,(t->c out))]
|
||||
[(Hashtable: k v)
|
||||
|
|
|
|||
|
|
@ -54,21 +54,18 @@
|
|||
(let loop ([form form])
|
||||
(parameterize ([current-orig-stx form])
|
||||
(syntax-parse form
|
||||
[stx
|
||||
;; if this needs to be checked
|
||||
#:when (with-type-property form)
|
||||
;; if this needs to be checked
|
||||
[stx:with-type^
|
||||
;; the form should be already ascribed the relevant type
|
||||
(tc-expr form)]
|
||||
[stx
|
||||
;; this is a handler function
|
||||
#:when (exn-handler-property form)
|
||||
;; this is a handler function
|
||||
[stx:exn-handler^
|
||||
(let ([t (single-value form)])
|
||||
(match t
|
||||
[(tc-result1: t)
|
||||
(set! handler-tys (cons (get-result-ty t) handler-tys))]))]
|
||||
[stx
|
||||
;; this is the body of the with-handlers
|
||||
#:when (exn-body-property form)
|
||||
;; this is the body of the with-handlers
|
||||
[stx:exn-body^
|
||||
(set! body-stx form)
|
||||
(set! body-ty (tc-expr form))]
|
||||
[(a . b)
|
||||
|
|
@ -82,18 +79,15 @@
|
|||
(let loop ([form form])
|
||||
(parameterize ([current-orig-stx form])
|
||||
(syntax-parse form
|
||||
[stx
|
||||
;; if this needs to be checked
|
||||
#:when (with-type-property form)
|
||||
;; if this needs to be checked
|
||||
[stx:with-type^
|
||||
;; the form should be already ascribed the relevant type
|
||||
(tc-expr form)]
|
||||
[stx
|
||||
;; this is a handler function
|
||||
#:when (exn-handler-property form)
|
||||
;; this is a handler function
|
||||
[stx:exn-handler^
|
||||
(tc-expr/check form (ret (-> (Un) (tc-results->values expected))))]
|
||||
[stx
|
||||
;; this is the body of the with-handlers
|
||||
#:when (exn-body-property form)
|
||||
;; this is the body of the with-handlers
|
||||
[stx:exn-body^
|
||||
(tc-expr/check form expected)]
|
||||
[(a . b)
|
||||
(begin
|
||||
|
|
@ -107,9 +101,8 @@
|
|||
(define (check-subforms/ignore form)
|
||||
(let loop ([form form])
|
||||
(syntax-parse form
|
||||
[stx
|
||||
;; if this needs to be checked
|
||||
#:when (with-type-property form)
|
||||
;; if this needs to be checked
|
||||
[stx:with-type^
|
||||
;; the form should be already ascribed the relevant type
|
||||
(void (tc-expr form))]
|
||||
[(a . b)
|
||||
|
|
|
|||
|
|
@ -17,9 +17,7 @@
|
|||
|
||||
|
||||
(define-syntax-class annotated-op
|
||||
(pattern i:identifier
|
||||
#:when (or (type-inst-property #'i)
|
||||
(type-ascription-property #'i))))
|
||||
(pattern (~and i:identifier (~or :type-inst^ :type-ascription^))))
|
||||
|
||||
(define-tc/app-syntax-class (tc/app-annotated expected)
|
||||
;; Just do regular typechecking if we have one of these.
|
||||
|
|
|
|||
|
|
@ -180,11 +180,9 @@
|
|||
(syntax-parse form
|
||||
#:literal-sets (kernel-literals)
|
||||
#:literals (find-method/who)
|
||||
[stx
|
||||
#:when (with-handlers-property form)
|
||||
[stx:with-handlers^
|
||||
(check-subforms/with-handlers/check form expected)]
|
||||
[stx
|
||||
#:when (ignore-some-property form)
|
||||
[stx:ignore-some^
|
||||
(check-subforms/ignore form)
|
||||
;; We trust ignore to be only on syntax objects objects that are well typed
|
||||
expected]
|
||||
|
|
@ -267,8 +265,7 @@
|
|||
(#%plain-app _ _ _arg-var2 ...))))))
|
||||
(tc/send #'find-app #'rcvr #'meth #'(args ...) expected)]
|
||||
;; kw function def
|
||||
[(let-values ([(_) fun]) . body)
|
||||
#:when (syntax-property form 'kw-lambda)
|
||||
[(~and (let-values ([(f) fun]) . body) _:kw-lambda^)
|
||||
(match expected
|
||||
[(tc-result1: (and f (or (Function: _)
|
||||
(Poly: _ (Function: _)))))
|
||||
|
|
@ -277,13 +274,12 @@
|
|||
(tc-error/expr "Keyword functions must have function type, given ~a" expected)])
|
||||
expected]
|
||||
;; opt function def
|
||||
[(let-values ([(f) fun]) . body)
|
||||
#:when (syntax-property form 'opt-lambda)
|
||||
[(~and (let-values ([(f) fun]) . body) opt:opt-lambda^)
|
||||
(define conv-type
|
||||
(match expected
|
||||
[(tc-result1: fun-type)
|
||||
(match-define (list required-pos optional-pos)
|
||||
(syntax-property form 'opt-lambda))
|
||||
(attribute opt.value))
|
||||
(opt-convert fun-type required-pos optional-pos)]
|
||||
[_ #f]))
|
||||
(match-define (tc-result1: returned-fun-type)
|
||||
|
|
@ -321,14 +317,12 @@
|
|||
#:literal-sets (kernel-literals)
|
||||
#:literals (#%app lambda find-method/who)
|
||||
;;
|
||||
[stx
|
||||
#:when (with-handlers-property form)
|
||||
[stx:with-handlers^
|
||||
(let ([ty (check-subforms/with-handlers form)])
|
||||
(unless ty
|
||||
(int-err "internal error: with-handlers"))
|
||||
ty)]
|
||||
[stx
|
||||
#:when (ignore-some-property form)
|
||||
[stx:ignore-some^
|
||||
(check-subforms/ignore form)
|
||||
(ret Univ)]
|
||||
;; explicit failure
|
||||
|
|
|
|||
|
|
@ -87,18 +87,11 @@
|
|||
(tc-body/check body (erase-filter expected))
|
||||
(tc-body body)))))))
|
||||
|
||||
(define (tc-expr/maybe-expected/t e name)
|
||||
(define expecteds
|
||||
(map (lambda (stx) (lookup-type stx (lambda () #f))) name))
|
||||
(define mk (if (and (pair? expecteds) (null? (cdr expecteds)))
|
||||
car
|
||||
-values))
|
||||
(define tcr
|
||||
(if
|
||||
(andmap values expecteds)
|
||||
(tc-expr/check e (mk expecteds))
|
||||
(tc-expr e)))
|
||||
tcr)
|
||||
(define (tc-expr/maybe-expected/t e names)
|
||||
(syntax-parse names
|
||||
[(i:typed-id^ ...)
|
||||
(tc-expr/check e (-values (attribute i.type)))]
|
||||
[_ (tc-expr e)]))
|
||||
|
||||
(define (tc/letrec-values namess exprs body form [expected #f])
|
||||
(let* ([names (stx-map syntax->list namess)]
|
||||
|
|
@ -206,11 +199,11 @@
|
|||
;; say that this binding is only called in tail position
|
||||
(define ((tc-expr-t/maybe-expected expected) e)
|
||||
(syntax-parse e #:literals (#%plain-lambda)
|
||||
[(#%plain-lambda () _)
|
||||
#:fail-unless (and expected (tail-position-property e)) #f
|
||||
[(~and (#%plain-lambda () _) _:tail-position^)
|
||||
#:when expected
|
||||
(tc-expr/check e (ret (t:-> (tc-results->values expected))))]
|
||||
[_
|
||||
#:fail-unless (and expected (tail-position-property e)) #f
|
||||
[_:tail-position^
|
||||
#:when expected
|
||||
(tc-expr/check e expected)]
|
||||
[_ (tc-expr e)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -59,8 +59,7 @@
|
|||
;#:literal-sets (kernel-literals)
|
||||
|
||||
;; forms that are handled in other ways
|
||||
[stx
|
||||
#:when (or (ignore-property form) (ignore-some-property form))
|
||||
[(~or _:ignore^ _:ignore-some^)
|
||||
(list)]
|
||||
|
||||
[((~literal module) n:id spec ((~literal #%plain-module-begin) body ...))
|
||||
|
|
@ -116,29 +115,29 @@
|
|||
|
||||
;; values definitions
|
||||
[(define-values (var ...) expr)
|
||||
(let* ([vars (syntax->list #'(var ...))])
|
||||
(cond
|
||||
;; if all the variables have types, we stick them into the environment
|
||||
[(andmap type-label-property vars)
|
||||
(let ([ts (map (λ (x) (get-type x #:infer #f)) vars)])
|
||||
(for-each register-type-if-undefined vars ts)
|
||||
(map make-def-binding vars ts))]
|
||||
;; if this already had an annotation, we just construct the binding reps
|
||||
[(andmap (lambda (s) (lookup-type s (lambda () #f))) vars)
|
||||
(define top-level? (eq? (syntax-local-context) 'top-level))
|
||||
(for ([var (in-list vars)])
|
||||
(when (dict-has-key? unann-defs var)
|
||||
(free-id-table-remove! unann-defs var))
|
||||
(finish-register-type var top-level?))
|
||||
(map (lambda (s) (make-def-binding s (lookup-type s))) vars)]
|
||||
;; special case to infer types for top level defines
|
||||
[else
|
||||
(match (get-type/infer vars #'expr tc-expr tc-expr/check)
|
||||
[(tc-results: ts)
|
||||
(for/list ([i (in-list vars)] [t (in-list ts)])
|
||||
(register-type i t)
|
||||
(free-id-table-set! unann-defs i #t)
|
||||
(make-def-binding i t))])]))]
|
||||
(define vars (syntax->list #'(var ...)))
|
||||
(syntax-parse vars
|
||||
;; if all the variables have types, we stick them into the environment
|
||||
[(v:type-label^ ...)
|
||||
(let ([ts (map (λ (x) (get-type x #:infer #f)) vars)])
|
||||
(for-each register-type-if-undefined vars ts)
|
||||
(map make-def-binding vars ts))]
|
||||
;; if this already had an annotation, we just construct the binding reps
|
||||
[(v:typed-id^ ...)
|
||||
(define top-level? (eq? (syntax-local-context) 'top-level))
|
||||
(for ([var (in-list vars)])
|
||||
(when (dict-has-key? unann-defs var)
|
||||
(free-id-table-remove! unann-defs var))
|
||||
(finish-register-type var top-level?))
|
||||
(stx-map make-def-binding #'(v ...) (attribute v.type))]
|
||||
;; special case to infer types for top level defines
|
||||
[_
|
||||
(match (get-type/infer vars #'expr tc-expr tc-expr/check)
|
||||
[(tc-results: ts)
|
||||
(for/list ([i (in-list vars)] [t (in-list ts)])
|
||||
(register-type i t)
|
||||
(free-id-table-set! unann-defs i #t)
|
||||
(make-def-binding i t))])])]
|
||||
|
||||
;; to handle the top-level, we have to recur into begins
|
||||
[(begin . rest)
|
||||
|
|
@ -164,13 +163,11 @@
|
|||
(syntax-parse form
|
||||
#:literal-sets (kernel-literals)
|
||||
;; these forms we have been instructed to ignore
|
||||
[stx
|
||||
#:when (ignore-property form)
|
||||
[stx:ignore^
|
||||
(void)]
|
||||
|
||||
;; this is a form that we mostly ignore, but we check some interior parts
|
||||
[stx
|
||||
#:when (ignore-some-property form)
|
||||
[stx:ignore-some^
|
||||
(check-subforms/ignore form)]
|
||||
|
||||
;; these forms should always be ignored
|
||||
|
|
@ -185,13 +182,14 @@
|
|||
[(define-values () expr)
|
||||
(tc-expr/check #'expr (ret empty))]
|
||||
[(define-values (var ...) expr)
|
||||
(unless (for/and ([v (in-syntax #'(var ...))])
|
||||
(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))))
|
||||
#:when (for/and ([v (in-syntax #'(var ...))])
|
||||
(free-id-table-ref unann-defs v (lambda _ #f)))
|
||||
(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
|
||||
[(begin) (void)]
|
||||
|
|
@ -365,9 +363,9 @@
|
|||
;; syntax -> (values #f (or/c void? tc-results/c))
|
||||
(define (tc-toplevel-form form)
|
||||
(syntax-parse form
|
||||
[((~literal begin) e ...)
|
||||
;; Don't open up `begin`s that are supposed to be ignored
|
||||
#:when (not (or (ignore-property form) (ignore-some-property form)))
|
||||
;; Don't open up `begin`s that are supposed to be ignored
|
||||
[(~and ((~literal begin) e ...)
|
||||
(~not (~or _:ignore^ _:ignore-some^)))
|
||||
(define result
|
||||
(for/last ([form (in-syntax #'(e ...))])
|
||||
(define-values (_ result) (tc-toplevel-form form))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user