Refactoring scheme/private/contract into reasonably sized pieces.
svn: r16049
This commit is contained in:
Stevie Strickland
parent
aca0bcf82e
commit
70e8f21ba2
|
|
@ -29,10 +29,9 @@
|
|||
;; except the arrow contracts
|
||||
;;
|
||||
|
||||
(require (except-in scheme/private/contract-base
|
||||
define/contract
|
||||
with-contract
|
||||
define-struct/contract)
|
||||
(require scheme/private/contract-base
|
||||
scheme/private/contract-misc
|
||||
scheme/private/contract-provide
|
||||
scheme/private/contract-guts
|
||||
scheme/private/contract-ds
|
||||
scheme/private/contract-opt
|
||||
|
|
@ -43,7 +42,9 @@
|
|||
(except-out (all-from-out scheme/private/contract-ds)
|
||||
lazy-depth-to-look)
|
||||
|
||||
(except-out (all-from-out scheme/private/contract-base)
|
||||
(all-from-out scheme/private/contract-base)
|
||||
(all-from-out scheme/private/contract-provide)
|
||||
(except-out (all-from-out scheme/private/contract-misc)
|
||||
check-between/c
|
||||
string-len/c
|
||||
check-unary-between/c)
|
||||
|
|
|
|||
|
|
@ -9,8 +9,12 @@ differences from v3:
|
|||
|
||||
|#
|
||||
|
||||
(require "private/contract-base.ss"
|
||||
"private/contract-arrow.ss"
|
||||
(require "private/contract-arrow.ss"
|
||||
"private/contract-base.ss"
|
||||
"private/contract-exists.ss"
|
||||
"private/contract-misc.ss"
|
||||
"private/contract-provide.ss"
|
||||
"private/contract-regions.ss"
|
||||
"private/contract-guts.ss"
|
||||
"private/contract-ds.ss"
|
||||
"private/contract-opt.ss"
|
||||
|
|
@ -26,10 +30,13 @@ differences from v3:
|
|||
procedure-accepts-and-more?
|
||||
check-procedure
|
||||
check-procedure/more)
|
||||
(except-out (all-from-out "private/contract-base.ss")
|
||||
∃?
|
||||
(except-out (all-from-out "private/contract-exists.ss") ∃?)
|
||||
(except-out (all-from-out "private/contract-misc.ss")
|
||||
check-between/c
|
||||
check-unary-between/c))
|
||||
check-unary-between/c)
|
||||
(all-from-out "private/contract-regions.ss")
|
||||
(all-from-out "private/contract-provide.ss")
|
||||
(all-from-out "private/contract-base.ss"))
|
||||
|
||||
;; from contract-guts.ss
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme
|
||||
|
||||
(require "../private/contract-base.ss")
|
||||
(require "../private/contract-exists.ss")
|
||||
|
||||
;; this code builds the list of predicates (in case it changes, this may need to be re-run)
|
||||
#;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
38
collects/scheme/private/contract-exists.ss
Normal file
38
collects/scheme/private/contract-exists.ss
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "contract-guts.ss")
|
||||
|
||||
(provide new-∃/c
|
||||
∃?)
|
||||
|
||||
(define (∃-proj ctc)
|
||||
(let ([in (∃/c-in ctc)]
|
||||
[out (∃/c-out ctc)]
|
||||
[pred? (∃/c-pred? ctc)])
|
||||
(λ (pos-blame neg-blame src-info orig-str positive-position?)
|
||||
(if positive-position?
|
||||
in
|
||||
(λ (val)
|
||||
(if (pred? val)
|
||||
(out val)
|
||||
(raise-contract-error val src-info pos-blame orig-str
|
||||
"non-polymorphic value: ~e"
|
||||
val)))))))
|
||||
|
||||
(define-struct ∃/c (in out pred? name)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop ∃-proj
|
||||
#:property name-prop (λ (ctc) (∃/c-name ctc))
|
||||
#:property first-order-prop
|
||||
(λ (ctc) (λ (x) #t)) ;; ???
|
||||
|
||||
#:property stronger-prop
|
||||
(λ (this that) #f))
|
||||
|
||||
(define-struct ∃ ())
|
||||
|
||||
(define (new-∃/c raw-name)
|
||||
(define name (string->symbol (format "~a/∃" raw-name)))
|
||||
(define-values (struct-type constructor predicate accessor mutator)
|
||||
(make-struct-type name struct:∃ 1 0))
|
||||
(make-∃/c constructor (λ (x) (accessor x 0)) predicate raw-name))
|
||||
|
|
@ -3,14 +3,30 @@
|
|||
(provide unpack-blame build-src-loc-string
|
||||
mangle-id mangle-id-for-maker
|
||||
build-struct-names
|
||||
lookup-struct-info
|
||||
nums-up-to
|
||||
add-name-prop
|
||||
all-but-last
|
||||
known-good-contract?)
|
||||
|
||||
(require setup/main-collects
|
||||
scheme/struct-info
|
||||
(for-template scheme/base))
|
||||
|
||||
;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
|
||||
(define (lookup-struct-info stx provide-stx)
|
||||
(let ([id (syntax-case stx ()
|
||||
[(a b) (syntax a)]
|
||||
[_ stx])])
|
||||
(let ([v (syntax-local-value id (λ () #f))])
|
||||
(if (struct-info? v)
|
||||
(extract-struct-info v)
|
||||
(raise-syntax-error 'provide/contract
|
||||
"expected a struct name"
|
||||
provide-stx
|
||||
id)))))
|
||||
|
||||
|
||||
(define (add-name-prop name stx)
|
||||
(cond
|
||||
[(identifier? name)
|
||||
|
|
|
|||
1257
collects/scheme/private/contract-misc.ss
Normal file
1257
collects/scheme/private/contract-misc.ss
Normal file
File diff suppressed because it is too large
Load Diff
708
collects/scheme/private/contract-provide.ss
Normal file
708
collects/scheme/private/contract-provide.ss
Normal file
|
|
@ -0,0 +1,708 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide provide/contract)
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/list
|
||||
(prefix-in a: "contract-helpers.ss"))
|
||||
"contract-arrow.ss"
|
||||
"contract-base.ss"
|
||||
"contract-exists.ss"
|
||||
"contract-guts.ss")
|
||||
|
||||
(define-syntax (verify-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name x) (a:known-good-contract? #'x) #'x]
|
||||
[(_ name x) #'(coerce-contract name x)]))
|
||||
|
||||
;; id->contract-src-info : identifier -> syntax
|
||||
;; constructs the last argument to the -contract, given an identifier
|
||||
(define-for-syntax (id->contract-src-info id)
|
||||
#`(list (make-srcloc #,id
|
||||
#,(syntax-line id)
|
||||
#,(syntax-column id)
|
||||
#,(syntax-position id)
|
||||
#,(syntax-span id))
|
||||
#,(format "~s" (syntax->datum id))))
|
||||
|
||||
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
|
||||
(make-set!-transformer
|
||||
(let ([saved-id-table (make-hasheq)])
|
||||
(λ (stx)
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
;; In an expression context:
|
||||
(let ([key (syntax-local-lift-context)])
|
||||
;; Already lifted in this lifting context?
|
||||
(let ([lifted-id
|
||||
(or (hash-ref saved-id-table key #f)
|
||||
;; No: lift the contract creation:
|
||||
(with-syntax ([contract-id contract-id]
|
||||
[id id]
|
||||
[pos-module-source pos-module-source]
|
||||
[id-ref (syntax-case stx (set!)
|
||||
[(set! whatever e)
|
||||
id] ;; just avoid an error here, signal the error later
|
||||
[(id . x)
|
||||
#'id]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
#'id])])
|
||||
(syntax-local-introduce
|
||||
(syntax-local-lift-expression
|
||||
#`(contract contract-id
|
||||
id
|
||||
pos-module-source
|
||||
(#%variable-reference)
|
||||
#,(id->contract-src-info #'id))))))])
|
||||
(when key
|
||||
(hash-set! saved-id-table key lifted-id))
|
||||
;; Expand to a use of the lifted expression:
|
||||
(with-syntax ([saved-id (syntax-local-introduce lifted-id)])
|
||||
(syntax-case stx (set!)
|
||||
[name
|
||||
(identifier? (syntax name))
|
||||
(syntax saved-id)]
|
||||
[(set! id arg)
|
||||
(raise-syntax-error 'provide/contract
|
||||
"cannot set! a provide/contract variable"
|
||||
stx
|
||||
(syntax id))]
|
||||
[(name . more)
|
||||
(with-syntax ([app (datum->syntax stx '#%app)])
|
||||
(syntax/loc stx (app saved-id . more)))]))))
|
||||
;; In case of partial expansion for module-level and internal-defn contexts,
|
||||
;; delay expansion until it's a good time to lift expressions:
|
||||
(quasisyntax/loc stx (#%expression #,stx)))))))
|
||||
|
||||
|
||||
(define-syntax (provide/contract provide-stx)
|
||||
(syntax-case provide-stx (struct)
|
||||
[(_ p/c-ele ...)
|
||||
(let ()
|
||||
|
||||
;; ids : table[id -o> (listof id)]
|
||||
;; code-for-each-clause adds identifiers to this map.
|
||||
;; when it binds things; they are then used to signal
|
||||
;; a syntax error for duplicates
|
||||
(define dups-table (make-hash))
|
||||
(define (add-to-dups-table id)
|
||||
(hash-update!
|
||||
dups-table
|
||||
(syntax-e id)
|
||||
(λ (ids) (cons id ids))
|
||||
'()))
|
||||
(define (signal-dup-syntax-error)
|
||||
(hash-for-each
|
||||
dups-table
|
||||
(λ (k ids)
|
||||
(let loop ([ids ids])
|
||||
(cond
|
||||
[(null? ids) (void)]
|
||||
[else
|
||||
(cond
|
||||
[(ormap (λ (x) (bound-identifier=? (car ids) x)) (cdr ids))
|
||||
(let ([dups (filter (λ (x) (bound-identifier=? (car ids) x))
|
||||
ids)])
|
||||
(raise-syntax-error 'provide/contract
|
||||
"duplicate identifiers"
|
||||
provide-stx
|
||||
(car dups)
|
||||
(cdr dups)))]
|
||||
[else
|
||||
(loop (cdr ids))])])))))
|
||||
|
||||
;; code-for-each-clause : (listof syntax) -> (listof syntax)
|
||||
;; constructs code for each clause of a provide/contract
|
||||
(define (code-for-each-clause clauses)
|
||||
(let loop ([clauses clauses]
|
||||
[exists-binders '()])
|
||||
(cond
|
||||
[(null? clauses) null]
|
||||
[else
|
||||
(let ([clause (car clauses)])
|
||||
;; compare raw identifiers for `struct' and `rename' just like provide does
|
||||
(syntax-case* clause (struct rename) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
[exists
|
||||
(or (eq? '#:exists (syntax-e #'exists)) (eq? '#:∃ (syntax-e #'exists)))
|
||||
(cond
|
||||
[(null? (cdr clauses))
|
||||
(raise-syntax-error 'provide/conract
|
||||
(format "expected either a single variable or a sequence of variables to follow ~a, but found nothing"
|
||||
(syntax-e #'exists))
|
||||
provide-stx
|
||||
clause)]
|
||||
[else
|
||||
(syntax-case (cadr clauses) ()
|
||||
[x
|
||||
(identifier? #'x)
|
||||
(with-syntax ([(x-gen) (generate-temporaries #'(x))])
|
||||
(cons (code-for-one-exists-id #'x #'x-gen)
|
||||
(loop (cddr clauses)
|
||||
(add-a-binder #'x #'x-gen exists-binders))))]
|
||||
[(x ...)
|
||||
(andmap identifier? (syntax->list #'(x ...)))
|
||||
(with-syntax ([(x-gen ...) (generate-temporaries #'(x ...))])
|
||||
(append (map code-for-one-exists-id
|
||||
(syntax->list #'(x ...))
|
||||
(syntax->list #'(x-gen ...)))
|
||||
(loop (cddr clauses)
|
||||
(let loop ([binders exists-binders]
|
||||
[xs (syntax->list #'(x ...))]
|
||||
[x-gens (syntax->list #'(x-gen ...))])
|
||||
(cond
|
||||
[(null? xs) binders]
|
||||
[else (loop (add-a-binder (car xs) (car x-gens) binders)
|
||||
(cdr xs)
|
||||
(cdr x-gens))])))))]
|
||||
[else
|
||||
(raise-syntax-error 'provide/contract
|
||||
(format "expected either a single variable or a sequence of variables to follow ~a"
|
||||
(syntax-e #'exists))
|
||||
provide-stx
|
||||
(cadr clauses))])])]
|
||||
[(rename this-name new-name contract)
|
||||
(and (identifier? (syntax this-name))
|
||||
(identifier? (syntax new-name)))
|
||||
(begin
|
||||
(add-to-dups-table #'new-name)
|
||||
(cons (code-for-one-id provide-stx
|
||||
(syntax this-name)
|
||||
(add-exists-binders (syntax contract) exists-binders)
|
||||
(syntax new-name))
|
||||
(loop (cdr clauses) exists-binders)))]
|
||||
[(rename this-name new-name contract)
|
||||
(identifier? (syntax this-name))
|
||||
(raise-syntax-error 'provide/contract
|
||||
"malformed rename clause, expected an identifier"
|
||||
provide-stx
|
||||
(syntax new-name))]
|
||||
[(rename this-name new-name contract)
|
||||
(identifier? (syntax new-name))
|
||||
(raise-syntax-error 'provide/contract
|
||||
"malformed rename clause, expected an identifier"
|
||||
provide-stx
|
||||
(syntax this-name))]
|
||||
[(rename . _)
|
||||
(raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)]
|
||||
[(struct struct-name ((field-name contract) ...))
|
||||
(and (well-formed-struct-name? (syntax struct-name))
|
||||
(andmap identifier? (syntax->list (syntax (field-name ...)))))
|
||||
(let ([sc (build-struct-code provide-stx
|
||||
(syntax struct-name)
|
||||
(syntax->list (syntax (field-name ...)))
|
||||
(map (λ (x) (add-exists-binders x exists-binders))
|
||||
(syntax->list (syntax (contract ...)))))])
|
||||
(add-to-dups-table #'struct-name)
|
||||
(cons sc (loop (cdr clauses) exists-binders)))]
|
||||
[(struct name)
|
||||
(identifier? (syntax name))
|
||||
(raise-syntax-error 'provide/contract
|
||||
"missing fields"
|
||||
provide-stx
|
||||
clause)]
|
||||
[(struct name . rest)
|
||||
(not (well-formed-struct-name? (syntax name)))
|
||||
(raise-syntax-error 'provide/contract "name must be an identifier or two identifiers with parens around them"
|
||||
provide-stx
|
||||
(syntax name))]
|
||||
[(struct name (fields ...))
|
||||
(for-each (λ (field)
|
||||
(syntax-case field ()
|
||||
[(x y)
|
||||
(identifier? (syntax x))
|
||||
(void)]
|
||||
[(x y)
|
||||
(raise-syntax-error 'provide/contract
|
||||
"malformed struct field, expected identifier"
|
||||
provide-stx
|
||||
(syntax x))]
|
||||
[else
|
||||
(raise-syntax-error 'provide/contract
|
||||
"malformed struct field"
|
||||
provide-stx
|
||||
field)]))
|
||||
(syntax->list (syntax (fields ...))))
|
||||
|
||||
;; if we didn't find a bad field something is wrong!
|
||||
(raise-syntax-error 'provide/contract "internal error" provide-stx clause)]
|
||||
[(struct name . fields)
|
||||
(raise-syntax-error 'provide/contract
|
||||
"malformed struct fields"
|
||||
provide-stx
|
||||
clause)]
|
||||
[(name contract)
|
||||
(identifier? (syntax name))
|
||||
(begin
|
||||
(add-to-dups-table #'name)
|
||||
(cons (code-for-one-id provide-stx
|
||||
(syntax name)
|
||||
(add-exists-binders (syntax contract)
|
||||
exists-binders)
|
||||
#f)
|
||||
(loop (cdr clauses) exists-binders)))]
|
||||
[(name contract)
|
||||
(raise-syntax-error 'provide/contract
|
||||
"expected identifier"
|
||||
provide-stx
|
||||
(syntax name))]
|
||||
[unk
|
||||
(raise-syntax-error 'provide/contract
|
||||
"malformed clause"
|
||||
provide-stx
|
||||
(syntax unk))]))])))
|
||||
|
||||
;; well-formed-struct-name? : syntax -> bool
|
||||
(define (well-formed-struct-name? stx)
|
||||
(or (identifier? stx)
|
||||
(syntax-case stx ()
|
||||
[(name super)
|
||||
(and (identifier? (syntax name))
|
||||
(identifier? (syntax super)))
|
||||
#t]
|
||||
[else #f])))
|
||||
|
||||
;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax
|
||||
;; constructs the code for a struct clause
|
||||
;; first arg is the original syntax object, for source locations
|
||||
(define (build-struct-code stx struct-name-position field-names field-contracts)
|
||||
(let* ([struct-name (syntax-case struct-name-position ()
|
||||
[(a b) (syntax a)]
|
||||
[else struct-name-position])]
|
||||
[super-id (syntax-case struct-name-position ()
|
||||
[(a b) (syntax b)]
|
||||
[else #t])]
|
||||
|
||||
|
||||
[all-parent-struct-count/names (get-field-counts/struct-names struct-name provide-stx)]
|
||||
[parent-struct-count (if (null? all-parent-struct-count/names)
|
||||
#f
|
||||
(let ([pp (cdr all-parent-struct-count/names)])
|
||||
(if (null? pp)
|
||||
#f
|
||||
(car (car pp)))))]
|
||||
|
||||
[struct-info (a:lookup-struct-info struct-name-position provide-stx)]
|
||||
[constructor-id (list-ref struct-info 1)]
|
||||
[predicate-id (list-ref struct-info 2)]
|
||||
[selector-ids (reverse (list-ref struct-info 3))]
|
||||
[is-id-ok?
|
||||
(λ (id i)
|
||||
(if (or (not parent-struct-count)
|
||||
(parent-struct-count . <= . i))
|
||||
id
|
||||
#t))]
|
||||
[mutator-ids (reverse (list-ref struct-info 4))] ;; (listof (union #f identifier))
|
||||
[field-contract-ids (map (λ (field-name field-contract)
|
||||
(if (a:known-good-contract? field-contract)
|
||||
field-contract
|
||||
(a:mangle-id provide-stx
|
||||
"provide/contract-field-contract"
|
||||
field-name
|
||||
struct-name)))
|
||||
field-names
|
||||
field-contracts)]
|
||||
[struct:struct-name
|
||||
(datum->syntax
|
||||
struct-name
|
||||
(string->symbol
|
||||
(string-append
|
||||
"struct:"
|
||||
(symbol->string (syntax-e struct-name)))))]
|
||||
|
||||
[-struct:struct-name
|
||||
(datum->syntax
|
||||
struct-name
|
||||
(string->symbol
|
||||
(string-append
|
||||
"-struct:"
|
||||
(symbol->string (syntax-e struct-name)))))]
|
||||
|
||||
[is-new-id?
|
||||
(λ (index)
|
||||
(or (not parent-struct-count)
|
||||
(parent-struct-count . <= . index)))])
|
||||
|
||||
(let ([unknown-info
|
||||
(λ (what names)
|
||||
(raise-syntax-error
|
||||
'provide/contract
|
||||
(format "cannot determine ~a, found ~s" what names)
|
||||
provide-stx
|
||||
struct-name))])
|
||||
|
||||
(unless (or (null? selector-ids)
|
||||
(identifier? (last selector-ids)))
|
||||
(unknown-info "the selectors" (map syntax->datum selector-ids)))
|
||||
|
||||
(unless constructor-id (unknown-info "constructor" constructor-id))
|
||||
(unless predicate-id (unknown-info "predicate" predicate-id))
|
||||
(unless (andmap/count is-id-ok? selector-ids)
|
||||
(unknown-info "selectors"
|
||||
(map (λ (x) (if (syntax? x)
|
||||
(syntax->datum x)
|
||||
x))
|
||||
selector-ids))))
|
||||
|
||||
(unless (equal? (length selector-ids)
|
||||
(length field-contract-ids))
|
||||
(raise-syntax-error 'provide/contract
|
||||
(format "found ~a field~a in struct, but ~a contract~a"
|
||||
(length selector-ids)
|
||||
(if (= 1 (length selector-ids)) "" "s")
|
||||
(length field-contract-ids)
|
||||
(if (= 1 (length field-contract-ids)) "" "s"))
|
||||
provide-stx
|
||||
struct-name))
|
||||
|
||||
;; make sure the field names are right.
|
||||
(let* ([relative-counts (let loop ([c (map car all-parent-struct-count/names)])
|
||||
(cond
|
||||
[(null? c) null]
|
||||
[(null? (cdr c)) c]
|
||||
[else (cons (- (car c) (cadr c))
|
||||
(loop (cdr c)))]))]
|
||||
[names (map cdr all-parent-struct-count/names)]
|
||||
[maker-name (format "~a" (syntax-e constructor-id))]
|
||||
[struct-name (substring maker-name 5 (string-length maker-name))])
|
||||
(let loop ([count (car relative-counts)]
|
||||
[name (car names)]
|
||||
[counts (cdr relative-counts)]
|
||||
[names (cdr names)]
|
||||
[selector-strs (reverse (map (λ (x) (format "~a" (syntax-e x))) selector-ids))]
|
||||
[field-names (reverse field-names)])
|
||||
(cond
|
||||
[(or (null? selector-strs) (null? field-names))
|
||||
(void)]
|
||||
[(zero? count)
|
||||
(loop (car counts) (car names) (cdr counts) (cdr names)
|
||||
selector-strs
|
||||
field-names)]
|
||||
[else
|
||||
(let* ([selector-str (car selector-strs)]
|
||||
[field-name (car field-names)]
|
||||
[field-name-should-be
|
||||
(substring selector-str
|
||||
(+ (string-length name) 1)
|
||||
(string-length selector-str))]
|
||||
[field-name-is (format "~a" (syntax-e field-name))])
|
||||
(unless (equal? field-name-should-be field-name-is)
|
||||
(raise-syntax-error 'provide/contract
|
||||
(format "expected field name to be ~a, but found ~a"
|
||||
field-name-should-be
|
||||
field-name-is)
|
||||
provide-stx
|
||||
field-name))
|
||||
(loop (- count 1)
|
||||
name
|
||||
counts
|
||||
names
|
||||
(cdr selector-strs)
|
||||
(cdr field-names)))])))
|
||||
|
||||
(with-syntax ([((selector-codes selector-new-names) ...)
|
||||
(filter
|
||||
(λ (x) x)
|
||||
(map/count (λ (selector-id field-contract-id index)
|
||||
(if (is-new-id? index)
|
||||
(code-for-one-id/new-name
|
||||
stx
|
||||
selector-id
|
||||
(build-selector-contract struct-name
|
||||
predicate-id
|
||||
field-contract-id)
|
||||
#f)
|
||||
#f))
|
||||
selector-ids
|
||||
field-contract-ids))]
|
||||
[(rev-selector-old-names ...)
|
||||
(reverse
|
||||
(filter
|
||||
(λ (x) x)
|
||||
(map/count (λ (selector-id index)
|
||||
(if (not (is-new-id? index))
|
||||
selector-id
|
||||
#f))
|
||||
selector-ids)))]
|
||||
[(mutator-codes/mutator-new-names ...)
|
||||
(map/count (λ (mutator-id field-contract-id index)
|
||||
(if (and mutator-id (is-new-id? index))
|
||||
(code-for-one-id/new-name stx
|
||||
mutator-id
|
||||
(build-mutator-contract struct-name
|
||||
predicate-id
|
||||
field-contract-id)
|
||||
#f)
|
||||
#f))
|
||||
mutator-ids
|
||||
field-contract-ids)]
|
||||
[(predicate-code predicate-new-name)
|
||||
(code-for-one-id/new-name stx predicate-id (syntax (-> any/c boolean?)) #f)]
|
||||
[(constructor-code constructor-new-name)
|
||||
(code-for-one-id/new-name
|
||||
stx
|
||||
constructor-id
|
||||
(build-constructor-contract stx
|
||||
field-contract-ids
|
||||
predicate-id)
|
||||
#f
|
||||
#t)]
|
||||
|
||||
[(field-contract-id-definitions ...)
|
||||
(filter values (map (λ (field-contract-id field-contract)
|
||||
(if (a:known-good-contract? field-contract)
|
||||
#f
|
||||
(with-syntax ([field-contract-id field-contract-id]
|
||||
[field-contract field-contract])
|
||||
#'(define field-contract-id (verify-contract 'provide/contract field-contract)))))
|
||||
field-contract-ids
|
||||
field-contracts))]
|
||||
[(field-contracts ...) field-contracts]
|
||||
[(field-contract-ids ...) field-contract-ids])
|
||||
|
||||
(with-syntax ([((mutator-codes mutator-new-names) ...)
|
||||
(filter syntax-e (syntax->list #'(mutator-codes/mutator-new-names ...)))])
|
||||
(with-syntax ([(rev-selector-new-names ...) (reverse (syntax->list (syntax (selector-new-names ...))))]
|
||||
[(rev-mutator-new-names ...) (reverse (syntax->list (syntax (mutator-new-names ...))))])
|
||||
(with-syntax ([struct-code
|
||||
(with-syntax ([id-rename (a:mangle-id provide-stx
|
||||
"provide/contract-struct-expandsion-info-id"
|
||||
struct-name)]
|
||||
[struct-name struct-name]
|
||||
[-struct:struct-name -struct:struct-name]
|
||||
[super-id (if (boolean? super-id)
|
||||
super-id
|
||||
(with-syntax ([super-id super-id])
|
||||
(syntax ((syntax-local-certifier) #'super-id))))]
|
||||
[(mutator-id-info ...)
|
||||
(map (λ (x)
|
||||
(syntax-case x ()
|
||||
[(a b) #'(slc #'b)]
|
||||
[else #f]))
|
||||
(syntax->list #'(mutator-codes/mutator-new-names ...)))]
|
||||
[(exported-selector-ids ...) (reverse selector-ids)]
|
||||
)
|
||||
#`(begin
|
||||
(provide (rename-out [id-rename struct-name]))
|
||||
(define-syntax id-rename
|
||||
(let ([slc (syntax-local-certifier)])
|
||||
#;
|
||||
(list (slc #'-struct:struct-name)
|
||||
(slc #'#,constructor-id)
|
||||
(slc #'#,predicate-id)
|
||||
(list (slc #'exported-selector-ids) ...)
|
||||
(list mutator-id-info ...)
|
||||
super-id)
|
||||
(list (slc #'-struct:struct-name)
|
||||
(slc #'constructor-new-name)
|
||||
(slc #'predicate-new-name)
|
||||
(list (slc #'rev-selector-new-names) ...
|
||||
(slc #'rev-selector-old-names) ...)
|
||||
(list mutator-id-info ...)
|
||||
super-id)))))]
|
||||
[struct:struct-name struct:struct-name]
|
||||
[-struct:struct-name -struct:struct-name]
|
||||
[struct-name struct-name]
|
||||
[(selector-ids ...) selector-ids])
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
struct-code
|
||||
field-contract-id-definitions ...
|
||||
selector-codes ...
|
||||
mutator-codes ...
|
||||
predicate-code
|
||||
constructor-code
|
||||
|
||||
;; expanding out the body of the `make-pc-struct-type' function
|
||||
;; directly here in the expansion makes this very expensive at compile time
|
||||
;; when there are a lot of provide/contract clause using structs
|
||||
(define -struct:struct-name
|
||||
(make-pc-struct-type 'struct-name struct:struct-name field-contract-ids ...))
|
||||
(provide (rename-out [-struct:struct-name struct:struct-name]))))))))))
|
||||
|
||||
(define (map/count f . ls)
|
||||
(let loop ([ls ls]
|
||||
[i 0])
|
||||
(cond
|
||||
[(andmap null? ls) '()]
|
||||
[(ormap null? ls) (error 'map/count "mismatched lists")]
|
||||
[else (cons (apply f (append (map car ls) (list i)))
|
||||
(loop (map cdr ls)
|
||||
(+ i 1)))])))
|
||||
|
||||
;; andmap/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
|
||||
(define (andmap/count f l1)
|
||||
(let loop ([l1 l1]
|
||||
[i 0])
|
||||
(cond
|
||||
[(null? l1) #t]
|
||||
[else (and (f (car l1) i)
|
||||
(loop (cdr l1)
|
||||
(+ i 1)))])))
|
||||
|
||||
;; get-field-counts/struct-names : syntax syntax -> (listof (cons symbol number))
|
||||
;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs
|
||||
(define (get-field-counts/struct-names struct-name provide-stx)
|
||||
(let loop ([parent-info-id struct-name])
|
||||
(let ([parent-info
|
||||
(and (identifier? parent-info-id)
|
||||
(a:lookup-struct-info parent-info-id provide-stx))])
|
||||
(cond
|
||||
[(boolean? parent-info) null]
|
||||
[else
|
||||
(let ([fields (list-ref parent-info 3)]
|
||||
[constructor (list-ref parent-info 1)])
|
||||
(cond
|
||||
[(and (not (null? fields))
|
||||
(not (last fields)))
|
||||
(raise-syntax-error
|
||||
'provide/contract
|
||||
"cannot determine the number of fields in super struct"
|
||||
provide-stx
|
||||
struct-name)]
|
||||
[else
|
||||
(cons (cons (length fields) (constructor->struct-name provide-stx constructor))
|
||||
(loop (list-ref parent-info 5)))]))]))))
|
||||
|
||||
(define (constructor->struct-name orig-stx stx)
|
||||
(and stx
|
||||
(let ([m (regexp-match #rx"^make-(.*)$" (format "~a" (syntax-e stx)))])
|
||||
(cond
|
||||
[m (cadr m)]
|
||||
[else (raise-syntax-error 'contract-base.ss
|
||||
"unable to cope with a struct maker whose name doesn't begin with `make-'"
|
||||
orig-stx)]))))
|
||||
|
||||
;; build-constructor-contract : syntax (listof syntax) syntax -> syntax
|
||||
(define (build-constructor-contract stx field-contract-ids predicate-id)
|
||||
(with-syntax ([(field-contract-ids ...) field-contract-ids]
|
||||
[predicate-id predicate-id])
|
||||
(syntax/loc stx
|
||||
(-> field-contract-ids ...
|
||||
predicate-id))))
|
||||
|
||||
;; build-selector-contract : syntax syntax -> syntax
|
||||
;; constructs the contract for a selector
|
||||
(define (build-selector-contract struct-name predicate-id field-contract-id)
|
||||
(with-syntax ([field-contract-id field-contract-id]
|
||||
[predicate-id predicate-id])
|
||||
(syntax (-> predicate-id field-contract-id))))
|
||||
|
||||
;; build-mutator-contract : syntax syntax -> syntax
|
||||
;; constructs the contract for a selector
|
||||
(define (build-mutator-contract struct-name predicate-id field-contract-id)
|
||||
(with-syntax ([field-contract-id field-contract-id]
|
||||
[predicate-id predicate-id])
|
||||
(syntax (-> predicate-id
|
||||
field-contract-id
|
||||
void?))))
|
||||
|
||||
;; code-for-one-exists-id : syntax -> syntax
|
||||
(define (code-for-one-exists-id x x-gen)
|
||||
#`(define #,x-gen (new-∃/c '#,x)))
|
||||
|
||||
(define (add-exists-binders stx exists-binders)
|
||||
#`(let #,exists-binders #,stx))
|
||||
|
||||
(define (add-a-binder id id-gen binders)
|
||||
(cons #`[#,id #,id-gen] binders))
|
||||
|
||||
;; code-for-one-id : syntax syntax syntax (union syntax #f) -> syntax
|
||||
;; given the syntax for an identifier and a contract,
|
||||
;; builds a begin expression for the entire contract and provide
|
||||
;; the first syntax object is used for source locations
|
||||
(define (code-for-one-id stx id ctrct user-rename-id)
|
||||
(with-syntax ([(code id) (code-for-one-id/new-name stx id ctrct user-rename-id)])
|
||||
(syntax code)))
|
||||
|
||||
;; code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax)
|
||||
;; given the syntax for an identifier and a contract,
|
||||
;; builds a begin expression for the entire contract and provide
|
||||
;; the first syntax object is used for source locations
|
||||
(define code-for-one-id/new-name
|
||||
(case-lambda
|
||||
[(stx id ctrct user-rename-id)
|
||||
(code-for-one-id/new-name stx id ctrct user-rename-id #f)]
|
||||
[(stx id ctrct user-rename-id mangle-for-maker?)
|
||||
(let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct)])
|
||||
(with-syntax ([id-rename ((if mangle-for-maker?
|
||||
a:mangle-id-for-maker
|
||||
a:mangle-id)
|
||||
provide-stx
|
||||
"provide/contract-id"
|
||||
(or user-rename-id id))]
|
||||
[contract-id (if no-need-to-check-ctrct?
|
||||
ctrct
|
||||
(a:mangle-id provide-stx
|
||||
"provide/contract-contract-id"
|
||||
(or user-rename-id id)))]
|
||||
[pos-module-source (a:mangle-id provide-stx
|
||||
"provide/contract-pos-module-source"
|
||||
(or user-rename-id id))]
|
||||
[pos-stx (datum->syntax id 'here)]
|
||||
[id id]
|
||||
[ctrct (syntax-property ctrct 'inferred-name id)]
|
||||
[external-name (or user-rename-id id)]
|
||||
[where-stx stx])
|
||||
(with-syntax ([extra-test
|
||||
(syntax-case #'ctrct (->)
|
||||
[(-> dom ... arg)
|
||||
#`(and (procedure? id)
|
||||
(procedure-arity-includes? id #,(length (syntax->list #'(dom ...)))))]
|
||||
[_ #f])])
|
||||
(with-syntax ([code
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(define pos-module-source (#%variable-reference))
|
||||
|
||||
#,@(if no-need-to-check-ctrct?
|
||||
(list)
|
||||
(list #'(define contract-id
|
||||
(let ([id ctrct]) ;; let is here to give the right name.
|
||||
(verify-contract 'provide/contract id)))))
|
||||
(define-syntax id-rename
|
||||
(make-provide/contract-transformer (quote-syntax contract-id)
|
||||
(quote-syntax id)
|
||||
(quote-syntax pos-module-source)))
|
||||
|
||||
(provide (rename-out [id-rename external-name]))))])
|
||||
|
||||
(syntax-local-lift-module-end-declaration
|
||||
#`(begin
|
||||
(unless extra-test
|
||||
(contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id)))
|
||||
(void)))
|
||||
|
||||
(syntax (code id-rename))))))]))
|
||||
|
||||
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
|
||||
(signal-dup-syntax-error)
|
||||
(syntax
|
||||
(begin
|
||||
bodies ...))))]))
|
||||
|
||||
(define (make-pc-struct-type struct-name struct:struct-name . ctcs)
|
||||
(let-values ([(struct:struct-name _make _pred _get _set)
|
||||
(make-struct-type struct-name
|
||||
struct:struct-name
|
||||
0 ;; init
|
||||
0 ;; auto
|
||||
#f ;; auto-v
|
||||
'() ;; props
|
||||
#f ;; inspector
|
||||
#f ;; proc-spec
|
||||
'() ;; immutable-k-list
|
||||
(λ args
|
||||
(let ([vals (let loop ([args args])
|
||||
(cond
|
||||
[(null? args) null]
|
||||
[(null? (cdr args)) null]
|
||||
[else (cons (car args) (loop (cdr args)))]))])
|
||||
(apply values
|
||||
(map (λ (ctc val)
|
||||
(contract ctc
|
||||
val
|
||||
'not-enough-info-for-blame
|
||||
'not-enough-info-for-blame))
|
||||
ctcs
|
||||
vals)))))])
|
||||
struct:struct-name))
|
||||
614
collects/scheme/private/contract-regions.ss
Normal file
614
collects/scheme/private/contract-regions.ss
Normal file
|
|
@ -0,0 +1,614 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide define-struct/contract
|
||||
define/contract
|
||||
with-contract)
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/list
|
||||
scheme/struct-info
|
||||
syntax/define
|
||||
syntax/kerncase
|
||||
(prefix-in a: "contract-helpers.ss"))
|
||||
scheme/splicing
|
||||
"contract-arrow.ss"
|
||||
"contract-base.ss"
|
||||
"contract-guts.ss")
|
||||
|
||||
;; These are useful for all below.
|
||||
|
||||
(define-syntax (verify-contract stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name x) (a:known-good-contract? #'x) #'x]
|
||||
[(_ name x) #'(coerce-contract name x)]))
|
||||
|
||||
;; id->contract-src-info : identifier -> syntax
|
||||
;; constructs the last argument to the -contract, given an identifier
|
||||
(define-for-syntax (id->contract-src-info id)
|
||||
#`(list (make-srcloc #,id
|
||||
#,(syntax-line id)
|
||||
#,(syntax-column id)
|
||||
#,(syntax-position id)
|
||||
#,(syntax-span id))
|
||||
#,(format "~s" (syntax->datum id))))
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
; ; ;;; ; ;
|
||||
; ; ; ;
|
||||
; ; ; ; ; ;
|
||||
; ;; ; ;;; ;;;; ; ; ;; ;;; ; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;;
|
||||
; ; ;; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ;;;;;; ; ; ; ; ;;;;;; ; ; ; ; ; ; ; ; ;;;; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;; ; ;;;; ; ; ; ; ;;;; ; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;;
|
||||
; ;
|
||||
; ;
|
||||
;
|
||||
|
||||
;; (define/contract id contract expr)
|
||||
;; defines `id' with `contract'; initially binding
|
||||
;; it to the result of `expr'. These variables may not be set!'d.
|
||||
(define-syntax (define/contract define-stx)
|
||||
(when (eq? (syntax-local-context) 'expression)
|
||||
(raise-syntax-error 'define/contract
|
||||
"used in expression context"
|
||||
define-stx))
|
||||
(syntax-case define-stx ()
|
||||
[(_ name)
|
||||
(raise-syntax-error 'define/contract
|
||||
"no contract or body"
|
||||
define-stx)]
|
||||
[(_ name contract-expr)
|
||||
(raise-syntax-error 'define/contract
|
||||
"expected a contract expression and a definition body, but found only one expression"
|
||||
define-stx)]
|
||||
[(_ name+arg-list contract #:freevars args . body)
|
||||
(identifier? #'args)
|
||||
(raise-syntax-error 'define/contract
|
||||
"expected list of identifier/contract pairs"
|
||||
#'args)]
|
||||
[(_ name+arg-list contract #:freevars (arg ...) #:freevar x c . body)
|
||||
(syntax/loc define-stx
|
||||
(define/contract name+arg-list contract #:freevars (arg ... [x c]) . body))]
|
||||
[(_ name+arg-list contract #:freevar x c . body)
|
||||
(syntax/loc define-stx
|
||||
(define/contract name+arg-list contract #:freevars () #:freevar x c . body))]
|
||||
[(_ name+arg-list contract #:freevars args body0 body ...)
|
||||
(begin
|
||||
(when (and (identifier? #'name+arg-list)
|
||||
(not (null? (syntax->list #'(body ...)))))
|
||||
(raise-syntax-error 'define/contract
|
||||
"multiple expressions after identifier and contract"
|
||||
#'(body ...)))
|
||||
(let-values ([(name body-expr)
|
||||
(if (identifier? #'name+arg-list)
|
||||
(values #'name+arg-list #'body0)
|
||||
(normalize-definition
|
||||
(datum->syntax #'define-stx (list* 'define/contract #'name+arg-list
|
||||
#'body0 #'(body ...)))
|
||||
#'lambda #t #t))])
|
||||
(with-syntax ([name name]
|
||||
[body-expr body-expr]
|
||||
[type (if (identifier? #'name+arg-list) 'definition 'function)])
|
||||
(syntax/loc define-stx
|
||||
(with-contract #:type type name
|
||||
([name contract])
|
||||
#:freevars args
|
||||
(define name body-expr))))))]
|
||||
[(_ name+arg-list contract body0 body ...)
|
||||
(syntax/loc define-stx
|
||||
(define/contract name+arg-list contract #:freevars () body0 body ...))]))
|
||||
|
||||
(define-syntax (define-struct/contract stx)
|
||||
(define-struct field-info (stx ctc [mutable? #:mutable] auto?))
|
||||
(define-struct s-info (auto-value-stx transparent? def-stxs? def-vals?))
|
||||
|
||||
(define syntax-error
|
||||
(lambda v
|
||||
(apply raise-syntax-error 'define-struct/contract v)))
|
||||
|
||||
(define (build-struct-names name field-infos)
|
||||
(let ([name-str (symbol->string (syntax-case name ()
|
||||
[id (identifier? #'id)
|
||||
(syntax-e #'id)]
|
||||
[(sub super)
|
||||
(syntax-e #'sub)]))])
|
||||
(list*
|
||||
(syntax-case name ()
|
||||
[id (identifier? #'id) #'id]
|
||||
[(sub super) #'sub])
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append "struct:" name-str)))
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append "make-" name-str)))
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append name-str "?")))
|
||||
(apply append
|
||||
(for/list ([finfo field-infos])
|
||||
(let ([field-str (symbol->string (syntax-e (field-info-stx finfo)))])
|
||||
(cons (datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append name-str "-" field-str)))
|
||||
(if (field-info-mutable? finfo)
|
||||
(list (datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append "set-" name-str "-" field-str "!"))))
|
||||
null))))))))
|
||||
|
||||
(define (build-contracts stx pred field-infos)
|
||||
(list* (syntax/loc stx any/c)
|
||||
(syntax/loc stx any/c)
|
||||
(apply append
|
||||
(for/list ([finfo field-infos])
|
||||
(let ([field-ctc (field-info-ctc finfo)])
|
||||
(cons (quasisyntax/loc stx
|
||||
(-> #,pred #,field-ctc))
|
||||
(if (field-info-mutable? finfo)
|
||||
(list
|
||||
(quasisyntax/loc stx
|
||||
(-> #,pred #,field-ctc void?)))
|
||||
null)))))))
|
||||
|
||||
(define (check-field f ctc)
|
||||
(let ([p-list (syntax->list f)])
|
||||
(if p-list
|
||||
(begin
|
||||
(when (null? p-list)
|
||||
(syntax-error "expected struct field" f))
|
||||
(unless (identifier? (car p-list))
|
||||
(syntax-error "expected identifier" f))
|
||||
(let loop ([rest (cdr p-list)]
|
||||
[mutable? #f]
|
||||
[auto? #f])
|
||||
(if (null? rest)
|
||||
(make-field-info (car p-list) ctc mutable? auto?)
|
||||
(let ([elem (syntax-e (car rest))])
|
||||
(if (keyword? elem)
|
||||
(cond
|
||||
[(eq? elem '#:mutable)
|
||||
(begin (when mutable?
|
||||
(syntax-error "redundant #:mutable"
|
||||
(car rest)))
|
||||
(loop (cdr rest) #t auto?))]
|
||||
[(eq? elem '#:auto)
|
||||
(begin (when auto?
|
||||
(syntax-error "redundant #:mutable"
|
||||
(car rest)))
|
||||
(loop (cdr rest) mutable? #t))]
|
||||
[else (syntax-error "expected #:mutable or #:auto"
|
||||
(car rest))])
|
||||
(syntax-error "expected #:mutable or #:auto"
|
||||
(car rest)))))))
|
||||
(if (identifier? f)
|
||||
(make-field-info f ctc #f #f)
|
||||
(syntax-error "expected struct field" f)))))
|
||||
(define (check-kwds kwd-list field-infos)
|
||||
(let loop ([kwds kwd-list]
|
||||
[auto-value-stx #f]
|
||||
[mutable? #f]
|
||||
[transparent? #f]
|
||||
[def-stxs? #t]
|
||||
[def-vals? #t])
|
||||
(if (null? kwds)
|
||||
(make-s-info auto-value-stx transparent? def-stxs? def-vals?)
|
||||
(let ([kwd (syntax-e (car kwds))])
|
||||
(when (not (keyword? kwd))
|
||||
(syntax-error "expected a keyword"
|
||||
(car kwds)))
|
||||
(cond
|
||||
[(eq? kwd '#:auto-value)
|
||||
(when (null? (cdr kwds))
|
||||
(syntax-error "expected a following expression"
|
||||
(car kwds)))
|
||||
(loop (cddr kwds) (cadr kwds)
|
||||
transparent? mutable? def-stxs? def-vals?)]
|
||||
;; let arbitrary properties through
|
||||
[(eq? kwd '#:property)
|
||||
(when (null? (cdr kwds))
|
||||
(syntax-error "expected a property"
|
||||
(car kwds)))
|
||||
(when (null? (cddr kwds))
|
||||
(syntax-error "expected a value for the property"
|
||||
(car kwds)))
|
||||
(loop (cdddr kwds) auto-value-stx
|
||||
mutable? transparent? def-stxs? def-vals?)]
|
||||
[(eq? kwd '#:mutable)
|
||||
(when mutable?
|
||||
(syntax-error "redundant #:mutable"
|
||||
(car kwds)))
|
||||
(for ([finfo field-infos])
|
||||
(set-field-info-mutable?! finfo #t))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
#t transparent? def-stxs? def-vals?)]
|
||||
[(eq? kwd '#:transparent)
|
||||
(when transparent?
|
||||
(syntax-error "redundant #:transparent"
|
||||
(car kwds)))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
mutable? #t def-stxs? def-vals?)]
|
||||
[(eq? kwd '#:omit-define-syntaxes)
|
||||
(when (not def-stxs?)
|
||||
(syntax-error "redundant #:omit-define-syntaxes"
|
||||
(car kwds)))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
transparent? mutable? #f def-vals?)]
|
||||
[(eq? kwd '#:omit-define-values)
|
||||
(when (not def-vals?)
|
||||
(syntax-error "redundant #:omit-define-values"
|
||||
(car kwds)))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
transparent? mutable? def-stxs? #f)]
|
||||
[else (syntax-error "unexpected keyword"
|
||||
(car kwds))])))))
|
||||
(syntax-case stx ()
|
||||
[(_ name ([field ctc] ...) kwds ...)
|
||||
(let ([fields (syntax->list #'(field ...))])
|
||||
(unless (or (identifier? #'name)
|
||||
(syntax-case #'name ()
|
||||
[(x y) (and (identifier? #'x)
|
||||
(identifier? #'y))]
|
||||
[_ #f]))
|
||||
(syntax-error "expected identifier for struct name or a sub-type relationship (subtype supertype)"
|
||||
#'name))
|
||||
(let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))]
|
||||
[sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)]
|
||||
[names (build-struct-names #'name field-infos)]
|
||||
[pred (cadddr names)]
|
||||
[ctcs (build-contracts stx pred field-infos)]
|
||||
[super-fields (syntax-case #'name ()
|
||||
[(child parent)
|
||||
(let ([v (syntax-local-value #'parent (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "identifier is not bound to a structure type" stx #'parent))
|
||||
(let ([v (extract-struct-info v)])
|
||||
(cadddr v)))]
|
||||
[else '()])])
|
||||
(let-values ([(non-auto-fields auto-fields)
|
||||
(let loop ([fields field-infos]
|
||||
[nautos null]
|
||||
[autos null])
|
||||
(if (null? fields)
|
||||
(values (reverse nautos)
|
||||
(reverse autos))
|
||||
(if (field-info-auto? (car fields))
|
||||
(loop (cdr fields)
|
||||
nautos
|
||||
(cons (car fields) autos))
|
||||
(if (null? autos)
|
||||
(loop (cdr fields)
|
||||
(cons (car fields) nautos)
|
||||
autos)
|
||||
(syntax-error "non-auto field after auto fields"
|
||||
(field-info-stx (car fields)))))))])
|
||||
(with-syntax ([ctc-bindings
|
||||
(let ([val-bindings (if (s-info-def-vals? sinfo)
|
||||
(cons (cadr names)
|
||||
(map list (cddr names)
|
||||
ctcs))
|
||||
null)])
|
||||
(if (s-info-def-stxs? sinfo)
|
||||
(cons (car names) val-bindings)
|
||||
val-bindings))]
|
||||
[orig stx]
|
||||
[struct-name (syntax-case #'name ()
|
||||
[id (identifier? #'id) #'id]
|
||||
[(id1 super) #'id1])]
|
||||
[(auto-check ...)
|
||||
(let* ([av-stx (if (s-info-auto-value-stx sinfo)
|
||||
(s-info-auto-value-stx sinfo)
|
||||
#'#f)]
|
||||
[av-id (datum->syntax av-stx
|
||||
(string->symbol
|
||||
(string-append (syntax-case #'name ()
|
||||
[id (identifier? #'id)
|
||||
(symbol->string (syntax-e #'id))]
|
||||
[(id1 super)
|
||||
(symbol->string (syntax-e #'id1))])
|
||||
":auto-value"))
|
||||
av-stx)])
|
||||
(for/list ([finfo auto-fields])
|
||||
#`(let ([#,av-id #,av-stx])
|
||||
(contract #,(field-info-ctc finfo)
|
||||
#,av-id
|
||||
'(struct name)
|
||||
'cant-happen
|
||||
#,(id->contract-src-info av-id)))))]
|
||||
;; a list of variables, one for each super field
|
||||
[(super-fields ...) (generate-temporaries super-fields)]
|
||||
;; the contract for a super field is any/c becuase the
|
||||
;; super constructor will have its own contract
|
||||
[(super-contracts ...) (for/list ([i (in-list super-fields)])
|
||||
(datum->syntax stx 'any/c))]
|
||||
[(non-auto-contracts ...)
|
||||
(map field-info-ctc
|
||||
(filter (lambda (f)
|
||||
(not (field-info-auto? f)))
|
||||
field-infos))]
|
||||
;; the make-foo function. this is used to make the contract
|
||||
;; print the right name in the blame
|
||||
[maker (caddr names)]
|
||||
[(non-auto-name ...)
|
||||
(map field-info-stx non-auto-fields)])
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-values () (begin auto-check ... (values)))
|
||||
(define (guard super-fields ... non-auto-name ... struct-name)
|
||||
(values super-fields ... non-auto-name ...))
|
||||
(define blame-id
|
||||
(current-contract-region))
|
||||
(with-contract #:type struct struct-name
|
||||
ctc-bindings
|
||||
(define-struct/derived orig name (field ...)
|
||||
kwds ...
|
||||
#:guard (contract (-> super-contracts ... non-auto-contracts ... symbol? any)
|
||||
guard
|
||||
(current-contract-region) blame-id
|
||||
#'maker)))))))))]
|
||||
[(_ name . bad-fields)
|
||||
(identifier? #'name)
|
||||
(syntax-error "expected a list of field name/contract pairs"
|
||||
#'bad-fields)]
|
||||
[(_ . body)
|
||||
(syntax-error "expected a structure name"
|
||||
#'body)]))
|
||||
|
||||
;
|
||||
;
|
||||
; ; ;
|
||||
; ; ; ; ;
|
||||
; ; ; ; ;
|
||||
; ; ; ; ; ;;;; ; ;;; ;;; ;;; ; ;;; ;;;; ; ;; ;;;; ;;; ;;;;
|
||||
; ; ; ; ; ; ;; ; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ; ;
|
||||
; ; ; ; ;;; ; ; ;;; ;;; ; ; ;;; ; ;;;; ; ;;; ;;;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
(define-for-syntax (make-contracted-id-transformer id contract-stx pos-blame-id neg-blame-id)
|
||||
(make-set!-transformer
|
||||
(lambda (stx)
|
||||
(syntax-case stx (set!)
|
||||
[(set! id arg)
|
||||
(raise-syntax-error 'with-contract
|
||||
"cannot set! a contracted variable"
|
||||
stx
|
||||
(syntax id))]
|
||||
[(f arg ...)
|
||||
(quasisyntax/loc stx
|
||||
((contract #,contract-stx
|
||||
#,id
|
||||
#,pos-blame-id
|
||||
#,neg-blame-id
|
||||
#,(id->contract-src-info id))
|
||||
arg ...))]
|
||||
[ident
|
||||
(identifier? (syntax ident))
|
||||
(quasisyntax/loc stx
|
||||
(contract #,contract-stx
|
||||
#,id
|
||||
#,pos-blame-id
|
||||
#,neg-blame-id
|
||||
#,(id->contract-src-info id)))]))))
|
||||
|
||||
|
||||
(define-syntax (with-contract-helper stx)
|
||||
(syntax-case stx ()
|
||||
[(_ () ())
|
||||
(begin #'(define-values () (values)))]
|
||||
[(_ (p0 p ...) (u ...))
|
||||
(raise-syntax-error 'with-contract
|
||||
"no definition found for identifier"
|
||||
#'p0)]
|
||||
[(_ () (u0 u ...))
|
||||
(raise-syntax-error 'with-contract
|
||||
"no definition found for identifier"
|
||||
#'u0)]
|
||||
[(_ (p ...) (u ...) body0 body ...)
|
||||
(let ([expanded-body0 (local-expand #'body0
|
||||
(syntax-local-context)
|
||||
(kernel-form-identifier-list))])
|
||||
(define (filter-ids to-filter to-remove)
|
||||
(filter (λ (i1)
|
||||
(not (memf (λ (i2)
|
||||
(bound-identifier=? i1 i2))
|
||||
to-remove)))
|
||||
to-filter))
|
||||
(syntax-case expanded-body0 (begin define-values define-syntaxes)
|
||||
[(begin sub ...)
|
||||
(syntax/loc stx
|
||||
(with-contract-helper (p ...) (u ...) sub ... body ...))]
|
||||
[(define-syntaxes (id ...) expr)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for ([i1 (syntax->list #'(p ...))])
|
||||
(when (ormap (λ (i2)
|
||||
(bound-identifier=? i1 i2))
|
||||
ids)
|
||||
(raise-syntax-error 'with-contract
|
||||
"cannot export syntax with a contract"
|
||||
i1)))
|
||||
(with-syntax ([def expanded-body0]
|
||||
[unused-us (filter-ids (syntax->list #'(u ...)) ids)])
|
||||
(with-syntax ()
|
||||
(syntax/loc stx
|
||||
(begin def (with-contract-helper (p ...) unused-us body ...))))))]
|
||||
[(define-values (id ...) expr)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(with-syntax ([def expanded-body0]
|
||||
[unused-ps (filter-ids (syntax->list #'(p ...)) ids)]
|
||||
[unused-us (filter-ids (syntax->list #'(u ...)) ids)])
|
||||
(syntax/loc stx
|
||||
(begin def (with-contract-helper unused-ps unused-us body ...)))))]
|
||||
[else
|
||||
(quasisyntax/loc stx
|
||||
(begin #,expanded-body0
|
||||
(with-contract-helper (p ...) (u ...) body ...)))]))]))
|
||||
|
||||
(define-for-syntax (check-and-split-with-contracts single-allowed? args)
|
||||
(let loop ([args args]
|
||||
[unprotected null]
|
||||
[protected null]
|
||||
[protections null])
|
||||
(cond
|
||||
[(null? args)
|
||||
(values unprotected protected protections)]
|
||||
[(identifier? (car args))
|
||||
(unless single-allowed?
|
||||
(raise-syntax-error 'with-contract
|
||||
"expected (identifier contract)"
|
||||
(car args)))
|
||||
(loop (cdr args)
|
||||
(cons (car args) unprotected)
|
||||
protected
|
||||
protections)]
|
||||
[(let ([lst (syntax->list (car args))])
|
||||
(and (list? lst)
|
||||
(= (length lst) 2)
|
||||
(identifier? (first lst))
|
||||
lst))
|
||||
=>
|
||||
(lambda (l)
|
||||
(loop (cdr args)
|
||||
unprotected
|
||||
(cons (first l) protected)
|
||||
(cons (second l) protections)))]
|
||||
[else
|
||||
(raise-syntax-error 'with-contract
|
||||
(format "expected ~a(identifier contract)"
|
||||
(if single-allowed? "an identifier or " ""))
|
||||
(car args))])))
|
||||
|
||||
(define-syntax (with-contract stx)
|
||||
(when (eq? (syntax-local-context) 'expression)
|
||||
(raise-syntax-error 'with-contract
|
||||
"used in expression context"
|
||||
stx))
|
||||
(syntax-case stx ()
|
||||
[(_ #:type type etc ...)
|
||||
(not (identifier? #'type))
|
||||
(raise-syntax-error 'with-contract
|
||||
"expected identifier for type"
|
||||
#'type)]
|
||||
[(_ #:type type args etc ...)
|
||||
(not (identifier? #'args))
|
||||
(raise-syntax-error 'with-contract
|
||||
"expected identifier for blame"
|
||||
#'args)]
|
||||
[(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body)
|
||||
(identifier? #'x)
|
||||
(syntax/loc stx
|
||||
(with-contract #:type type blame (arg ...) #:freevars (fv ... [x c]) . body))]
|
||||
[(_ #:type type blame (arg ...) #:freevars (fv ...) #:freevar x c . body)
|
||||
(raise-syntax-error 'with-contract
|
||||
"use of #:freevar with non-identifier"
|
||||
#'x)]
|
||||
[(_ #:type type blame (arg ...) #:freevars (fv ...) . body)
|
||||
(and (identifier? #'blame)
|
||||
(identifier? #'type))
|
||||
(let*-values ([(marker) (make-syntax-introducer)]
|
||||
[(cid-marker) (make-syntax-introducer)]
|
||||
[(no-need free-vars free-ctcs)
|
||||
(check-and-split-with-contracts #f (syntax->list #'(fv ...)))]
|
||||
[(unprotected protected protections)
|
||||
(check-and-split-with-contracts #t (syntax->list #'(arg ...)))])
|
||||
(begin
|
||||
(let ([dupd-id (check-duplicate-identifier (append unprotected protected))])
|
||||
(when dupd-id
|
||||
(raise-syntax-error 'with-contract
|
||||
"identifier appears twice in exports"
|
||||
dupd-id)))
|
||||
(with-syntax ([blame-stx #''(type blame)]
|
||||
[blame-id (car (generate-temporaries (list #t)))]
|
||||
[(free-var ...) free-vars]
|
||||
[(free-var-id ...) (map marker free-vars)]
|
||||
[(free-ctc-id ...) (map cid-marker free-vars)]
|
||||
[(free-ctc ...) (map (λ (c v)
|
||||
(syntax-property c 'inferred-name v))
|
||||
free-ctcs
|
||||
free-vars)]
|
||||
[(free-src-info ...) (map id->contract-src-info free-vars)]
|
||||
[(ctc-id ...) (map cid-marker protected)]
|
||||
[(ctc ...) (map (λ (c v)
|
||||
(marker (syntax-property c 'inferred-name v)))
|
||||
protections
|
||||
protected)]
|
||||
[(p ...) protected]
|
||||
[(marked-p ...) (map marker protected)]
|
||||
[(src-info ...) (map (compose id->contract-src-info marker) protected)]
|
||||
[(u ...) unprotected]
|
||||
[(marked-u ...) (map marker unprotected)])
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
(define-values (free-ctc-id ...)
|
||||
(values (verify-contract 'with-contract free-ctc) ...))
|
||||
(define blame-id
|
||||
(current-contract-region))
|
||||
(define-values ()
|
||||
(begin (contract free-ctc-id
|
||||
free-var
|
||||
blame-id
|
||||
'cant-happen
|
||||
free-src-info)
|
||||
...
|
||||
(values)))
|
||||
(define-syntaxes (free-var-id ...)
|
||||
(values (make-contracted-id-transformer
|
||||
(quote-syntax free-var)
|
||||
(quote-syntax free-ctc-id)
|
||||
(quote-syntax blame-id)
|
||||
(quote-syntax blame-stx)) ...))
|
||||
(splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)])
|
||||
(with-contract-helper (marked-p ...) (marked-u ...) . #,(marker #'body)))
|
||||
(define-values (ctc-id ...)
|
||||
(values (verify-contract 'with-contract ctc) ...))
|
||||
(define-values ()
|
||||
(begin (contract ctc-id
|
||||
marked-p
|
||||
blame-stx
|
||||
'cant-happen
|
||||
src-info)
|
||||
...
|
||||
(values)))
|
||||
(define-syntaxes (u ... p ...)
|
||||
(values (make-rename-transformer #'marked-u) ...
|
||||
(make-contracted-id-transformer
|
||||
(quote-syntax marked-p)
|
||||
(quote-syntax ctc-id)
|
||||
(quote-syntax blame-stx)
|
||||
(quote-syntax blame-id)) ...)))))))]
|
||||
[(_ #:type type blame (arg ...) #:freevar x c . body)
|
||||
(syntax/loc stx
|
||||
(with-contract #:type type blame (arg ...) #:freevars ([x c]) . body))]
|
||||
[(_ #:type type blame (arg ...) . body)
|
||||
(syntax/loc stx
|
||||
(with-contract #:type type blame (arg ...) #:freevars () . body))]
|
||||
[(_ #:type type blame bad-args etc ...)
|
||||
(raise-syntax-error 'with-contract
|
||||
"expected list of identifier and/or (identifier contract)"
|
||||
#'bad-args)]
|
||||
[(_ #:type type blame)
|
||||
(raise-syntax-error 'with-contract
|
||||
"only blame"
|
||||
stx)]
|
||||
[(_ etc ...)
|
||||
(syntax/loc stx
|
||||
(with-contract #:type region etc ...))]))
|
||||
|
|
@ -200,8 +200,10 @@
|
|||
scheme/private/contract-basic-opters
|
||||
scheme/private/contract-ds
|
||||
scheme/private/contract-ds-helpers
|
||||
scheme/private/contract-exists
|
||||
scheme/private/contract-guts
|
||||
scheme/private/contract-helpers
|
||||
scheme/private/contract-misc
|
||||
scheme/private/contract-opt
|
||||
scheme/private/contract-opt-guts
|
||||
scheme/private/define-struct
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user