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

Improve `internal-forms'

Browse Source 
First step to custom predicates in `define-typed-struct-internal'

svn: r17820

original commit: bb541fd03fa0b35e22f0c82f6c9b3a8a6d5b0591
This commit is contained in:
Sam Tobin-Hochstadt 2010-01-25 18:38:56 +00:00
parent 3dc58b3a44
commit 674c88a752
2 changed files with 20 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/typed-scheme/typecheck/internal-forms.ss
View File

@ -1,16 +1,21 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require (for-syntax scheme/base)
syntax/parse)
(define-syntax-rule (internal-forms nms ...)
(define-syntax-rule (internal-forms set-name nms ...)
(begin
(provide nms ...)
(provide nms ... set-name)
(define-literal-set set-name (nms ...))
(define-syntax (nms stx) (raise-syntax-error 'typecheck "Internal typechecker form used out of context" stx)) ...))
(internal-forms require/typed-internal define-type-alias-internal
define-typed-struct-internal
define-typed-struct/exec-internal
assert-predicate-internal
declare-refinement-internal
:-internal)
(internal-forms internal-literals
require/typed-internal
define-type-alias-internal
define-type-internal
define-typed-struct-internal
define-typed-struct/exec-internal
assert-predicate-internal
declare-refinement-internal
:-internal)

7
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -90,6 +90,7 @@
#:mutable [setters? #f]
#:proc-ty [proc-ty #f]
#:maker [maker* #f]
#:predicate [pred* #f]
#:constructor-return [cret #f]
#:poly? [poly? #f]
#:type-only [type-only #f])
@ -107,6 +108,7 @@
#:type-wrapper type-wrapper
#:pred-wrapper pred-wrapper
#:maker (or maker* maker)
#:predicate (or pred* pred)
#:constructor-return cret))))
;; generate names, and register the approriate types give field types and structure type
@ -117,6 +119,7 @@
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:maker [maker* #f]
#:predicate [pred* #f]
#:constructor-return [cret #f])
;; create the approriate names that define-struct will bind
(define-values (maker pred getters setters) (struct-names nm flds setters?))
@ -127,7 +130,7 @@
(append
(list (cons (or maker* maker)
(wrapper (->* external-fld-types (if cret cret name))))
(cons pred
(cons (or pred* pred)
(make-pred-ty (pred-wrapper name))))
(for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
(let ([func (if setters?
@ -185,6 +188,7 @@
;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
(define (tc/struct nm/par flds tys [proc-ty #f]
#:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
#:predicate [pred #f]
#:type-only [type-only #f])
;; get the parent info and create some types and type variables
(define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
@ -200,6 +204,7 @@
;; procedure
#:proc-ty proc-ty-parsed
#:maker maker
#:predicate pred
#:constructor-return (and cret (parse-type cret))
#:mutable mutable
#:type-only type-only))