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

..

Browse Source 
original commit: 5178f7e10ea8669c88c9d1d79e8cff83c3b26704
This commit is contained in:
Robby Findler 2002-10-10 17:18:35 +00:00
parent 62b7af443d
commit 1e621132aa
2 changed files with 36 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
collects/mzlib/contracts.ss
View File

@ -14,6 +14,7 @@
(require-for-syntax mzscheme
(lib "list.ss")
(lib "pretty.ss")
(lib "name.ss" "syntax")
(lib "stx.ss" "syntax"))
@ -115,9 +116,10 @@
[(struct struct-name ((field-name contract) ...))
(and (identifier? (syntax struct-name))
(andmap identifier? (syntax->list (syntax (field-name ...)))))
(build-struct-code (syntax struct-name)
(syntax->list (syntax (field-name ...)))
(syntax->list (syntax (contract ...))))]
(let ([sc (build-struct-code (syntax struct-name)
(syntax->list (syntax (field-name ...)))
(syntax->list (syntax (contract ...))))])
(cons sc (code-for-each-clause (cdr clauses))))]
[(struct name)
(identifier? (syntax name))
(raise-syntax-error 'provide/contract
@ -168,23 +170,24 @@
;; constructs the code for a struct clause
(define (build-struct-code struct-name field-names field-contracts)
(let* ([field-contract-ids (map (lambda (field-name)
(mangle-id field-name "provide/contract-field-contract"))
(mangle-id field-name
"provide/contract-field-contract"))
field-names)]
[selector-ids (map (lambda (field-contract-id)
(build-selector-id struct-name field-contract-id))
field-contract-ids)]
[mutator-ids (map (lambda (field-contract-id)
(build-mutator-id struct-name field-contract-id))
field-contract-ids)]
[predicate-id (build-predicate-id struct-name)])
[selector-ids (map (lambda (field-name)
(build-selector-id struct-name field-name))
field-names)]
[mutator-ids (map (lambda (field-name)
(build-mutator-id struct-name field-name))
field-names)]
[predicate-id (build-predicate-id struct-name)]
[constructor-id (build-constructor-id struct-name)])
(with-syntax ([(selector-codes ...)
(map (lambda (field-name field-contract-id)
(code-for-one-id (build-selector-id struct-name
field-contract-id)
(map (lambda (selector-id field-contract-id)
(code-for-one-id selector-id
(build-selector-contract struct-name
predicate-id
field-contract-id)))
field-names
selector-ids
field-contract-ids)]
[(mutator-codes ...)
(map (lambda (mutator-id field-contract-id)
@ -196,7 +199,7 @@
field-contract-ids)]
[predicate-code (code-for-one-id predicate-id (syntax (-> any? boolean?)))]
[constructor-code (code-for-one-id
(build-constructor-id struct-name)
constructor-id
(build-constructor-contract field-contract-ids
predicate-id))]
[(field-contracts ...) field-contracts]
@ -213,21 +216,29 @@
(define (build-constructor-contract field-contract-ids predicate-id)
(with-syntax ([(field-contract-ids ...) field-contract-ids]
[predicate-id predicate-id])
(syntax (-> field-contract-ids ... predicate-id))))
(syntax (field-contract-ids
...
. -> .
(let ([predicate-id (lambda (x) (predicate-id x))]) 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))))
(syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) 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 contract-id void?))))
(syntax ((let ([predicate-id (lambda (x) (predicate-id x))]) predicate-id)
field-contract-id
. -> .
void?))))
;; build-constructor-id : syntax -> syntax
;; constructs the name of the selector for a particular field of a struct
@ -365,7 +376,7 @@
;; flat-named-contract = (make-flat-named-contract string (any -> boolean))
;; this holds flat contracts that have names for error reporting
(define-struct flat-named-contract (type-name predicate) (make-inspector)) (print-struct #t)
(define-struct flat-named-contract (type-name predicate))
(provide (rename build-flat-named-contract flat-named-contract)
flat-named-contract-type-name

7
collects/tests/mzscheme/contracts.ss
View File

@ -4,7 +4,7 @@
(SECTION 'contracts)
(parameterize ([error-print-width 200])
(parameterize ([error-print-width 200])
(let ()
;; test/spec-passed : symbol sexp -> void
;; tests a passing specification
@ -496,7 +496,10 @@
(provide/contract (struct s ((a any?))))
(define-struct s (a))))
(eval '(require contract-test-suite4))
(eval '(list make-s s-a s? set-s-a!))))
(eval '(list (make-s 1)
(s-a (make-s 1))
(s? (make-s 1))
(set-s-a! (make-s 1) 2)))))
))