709 lines
38 KiB
Scheme
709 lines
38 KiB
Scheme
#lang scheme/base
|
|
|
|
(provide provide/contract)
|
|
|
|
(require (for-syntax scheme/base
|
|
scheme/list
|
|
(prefix-in a: "helpers.ss"))
|
|
"arrow.ss"
|
|
"base.ss"
|
|
scheme/contract/exists
|
|
"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))
|