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

.

Browse Source 
original commit: e041f9011678922198c46afde29f05b06c1b27aa
This commit is contained in:
Robby Findler 2004-05-23 22:16:32 +00:00
parent b0d6dee04b
commit fc971fb502
2 changed files with 142 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
collects/mzlib/contract.ss
View File

@ -167,7 +167,7 @@ add struct contracts for immutable structs?
[(rename . _) [(rename . _)
(raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)] (raise-syntax-error 'provide/contract "malformed rename clause" provide-stx clause)]
[(struct struct-name ((field-name contract) ...)) [(struct struct-name ((field-name contract) ...))
(and (identifier? (syntax struct-name)) (and (well-formed-struct-name? (syntax struct-name))
(andmap identifier? (syntax->list (syntax (field-name ...))))) (andmap identifier? (syntax->list (syntax (field-name ...)))))
(let ([sc (build-struct-code provide-stx (let ([sc (build-struct-code provide-stx
(syntax struct-name) (syntax struct-name)
@ -180,6 +180,11 @@ add struct contracts for immutable structs?
"missing fields" "missing fields"
provide-stx provide-stx
clause)] 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 ...)) [(struct name (fields ...))
(for-each (lambda (field) (for-each (lambda (field)
(syntax-case field () (syntax-case field ()
@ -220,11 +225,36 @@ add struct contracts for immutable structs?
provide-stx provide-stx
(syntax unk))]))])) (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 ;; build-struct-code : syntax syntax (listof syntax) (listof syntax) -> syntax
;; constructs the code for a struct clause ;; constructs the code for a struct clause
;; first arg is the original syntax object, for source locations ;; first arg is the original syntax object, for source locations
(define (build-struct-code stx struct-name field-names field-contracts) (define (build-struct-code stx struct-name-position field-names field-contracts)
(let* ([field-contract-ids (map (lambda (field-name) (let* ([struct-name (syntax-case struct-name-position ()
[(a b) (syntax a)]
[else struct-name-position])]
[parent-struct-count (let ([parent-info (extract-parent-struct-info struct-name-position)])
(and parent-info
(let ([fields (cadddr parent-info)])
(cond
[(null? fields) 0]
[(not (car (last-pair fields)))
(raise-syntax-error
'provide/contract
"cannot determine the number of fields in super struct"
provide-stx
struct-name)]
[else (length fields)]))))]
[field-contract-ids (map (lambda (field-name)
(a:mangle-id provide-stx (a:mangle-id provide-stx
"provide/contract-field-contract" "provide/contract-field-contract"
field-name field-name
@ -239,25 +269,35 @@ add struct contracts for immutable structs?
[predicate-id (build-predicate-id struct-name)] [predicate-id (build-predicate-id struct-name)]
[constructor-id (build-constructor-id struct-name)]) [constructor-id (build-constructor-id struct-name)])
(with-syntax ([(selector-codes ...) (with-syntax ([(selector-codes ...)
(map (lambda (selector-id field-contract-id) (filter
(lambda (x) x)
(map/count (lambda (selector-id field-contract-id index)
(if (or (not parent-struct-count)
(parent-struct-count . <= . index))
(code-for-one-id stx (code-for-one-id stx
selector-id selector-id
(build-selector-contract struct-name (build-selector-contract struct-name
predicate-id predicate-id
field-contract-id) field-contract-id)
#f)
#f)) #f))
selector-ids selector-ids
field-contract-ids)] field-contract-ids))]
[(mutator-codes ...) [(mutator-codes ...)
(map (lambda (mutator-id field-contract-id) (filter
(lambda (x) x)
(map/count (lambda (mutator-id field-contract-id index)
(if (or (not parent-struct-count)
(parent-struct-count . <= . index))
(code-for-one-id stx (code-for-one-id stx
mutator-id mutator-id
(build-mutator-contract struct-name (build-mutator-contract struct-name
predicate-id predicate-id
field-contract-id) field-contract-id)
#f)
#f)) #f))
mutator-ids mutator-ids
field-contract-ids)] field-contract-ids))]
[predicate-code (code-for-one-id stx predicate-id (syntax (-> any? boolean?)) #f)] [predicate-code (code-for-one-id stx predicate-id (syntax (-> any? boolean?)) #f)]
[constructor-code (code-for-one-id [constructor-code (code-for-one-id
stx stx
@ -284,6 +324,32 @@ add struct contracts for immutable structs?
constructor-code constructor-code
(provide struct-name struct:struct-name)))))) (provide struct-name struct:struct-name))))))
;; map/count : (X Y int -> Z) (listof X) (listof Y) -> (listof Z)
(define (map/count f l1 l2)
(let loop ([l1 l1]
[l2 l2]
[i 0])
(cond
[(and (null? l1) (null? l2)) '()]
[(or (null? l1) (null? l2)) (error 'map/count "mismatched lists")]
[else (cons (f (car l1) (car l2) i)
(loop (cdr l1)
(cdr l2)
(+ i 1)))])))
;; extract-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
(define (extract-parent-struct-info stx)
(syntax-case stx ()
[(a b)
(syntax-local-value
(syntax b)
(lambda ()
(raise-syntax-error 'provide/contract
"expected a struct name"
provide-stx
(syntax a))))]
[a #f]))
;; build-constructor-contract : syntax (listof syntax) syntax -> syntax ;; build-constructor-contract : syntax (listof syntax) syntax -> syntax
(define (build-constructor-contract stx field-contract-ids predicate-id) (define (build-constructor-contract stx field-contract-ids predicate-id)
(with-syntax ([(field-contract-ids ...) field-contract-ids] (with-syntax ([(field-contract-ids ...) field-contract-ids]

56
collects/tests/mzscheme/contract-test.ss
View File

@ -1093,11 +1093,29 @@
'provide/contract7 'provide/contract7
'(let () '(let ()
(eval '(module contract-test-suite7 mzscheme (eval '(module contract-test-suite7 mzscheme
(require (lib "contract.ss"))
(define-struct s (a b))
(define-struct (t s) (c d))
(provide/contract
(struct s ((a any?) (b any?)))
(struct (t s) ((a any?) (b any?) (c any?) (d any?))))))
(eval '(require contract-test-suite7))
(eval '(let ([x (make-t 1 2 3 4)])
(s-a x)
(s-b x)
(t-c x)
(t-d x)
(void)))))
(test/spec-passed
'provide/contract8
'(let ()
(eval '(module contract-test-suite8 mzscheme
(require (lib "contract.ss")) (require (lib "contract.ss"))
(provide/contract (rename the-internal-name the-external-name integer?)) (provide/contract (rename the-internal-name the-external-name integer?))
(define the-internal-name 1) (define the-internal-name 1)
(+ the-internal-name 1))) (+ the-internal-name 1)))
(eval '(require contract-test-suite7)) (eval '(require contract-test-suite8))
(eval '(+ the-external-name 1)))) (eval '(+ the-external-name 1))))
@ -1164,6 +1182,27 @@
'pos 'pos
'neg)) 'neg))
(test/spec-passed/result
'object-contract/field6
'(send (contract (object-contract [m (integer? . -> . integer?)])
(new (class object% (define x 1) (define/public (m y) x) (super-new)))
'pos
'neg)
m
2)
1)
#;
(test/spec-passed/result
'object-contract/field7
'(send (contract (object-contract)
(new (class object% (define x 1) (define/public (m y) x) (super-new)))
'pos
'neg)
m
2)
1)
(test/spec-passed/result (test/spec-passed/result
'object-contract->1 'object-contract->1
'(send '(send
@ -2378,6 +2417,21 @@
(test/well-formed #'(case-> (->d* (any? any?) (lambda x any?)) (-> integer? integer?))) (test/well-formed #'(case-> (->d* (any? any?) (lambda x any?)) (-> integer? integer?)))
(test/well-formed #'(case-> (->d* (any? any?) any? (lambda x any?)) (-> integer? integer?))) (test/well-formed #'(case-> (->d* (any? any?) any? (lambda x any?)) (-> integer? integer?)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; Inferred Name Tests ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(eval
'(module contract-test-suite-inferred-name1 mzscheme
(require (lib "contract.ss"))
(define contract-inferred-name-test-contract (-> integer? any))
(define (contract-inferred-name-test x) #t)
(provide/contract (contract-inferred-name-test contract-inferred-name-test-contract))))
(eval '(require contract-test-suite-inferred-name1))
(eval '(test 'contract-inferred-name-test object-name contract-inferred-name-test))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;; ;; ;;
;; Contract Name Tests ;; ;; Contract Name Tests ;;