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

Honu: continued implementation of contract helpers.

Browse Source 
svn: r1860
This commit is contained in:
Carl Eastlund 2006-01-18 23:30:02 +00:00
parent 07c86de139
commit 830f29891c
1 changed files with 53 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
collects/honu/contract.ss
View File

@ -47,6 +47,59 @@
(define INSPECTOR-VAR INSPECTOR-EXPR) (define INSPECTOR-VAR INSPECTOR-EXPR)
#,(build-define-struct #'STRUCT #'INSPECTOR-VAR) ...))])) #,(build-define-struct #'STRUCT #'INSPECTOR-VAR) ...))]))
(define-syntax (define-structs/provide stx)
(define (build-define-struct struct-stx var-stx)
(syntax-case struct-stx ()
[(NAME (FIELD ...) STRUCT ...)
#`(begin
(define-struct NAME (FIELD ...) #,var-stx)
#,(build-define-struct #'STRUCT var-stx) ...)]))
(define (build-provide struct-stx)
(syntax-case struct-stx ()
[(NAME (FIELD ...) STRUCT ...)
#`(begin
(provide (struct NAME (FIELD ...)))
#,(build-provide #'STRUCT) ...)]))
(syntax-case stx ()
[(_ INSPECTOR-EXPR STRUCT ...)
(with-syntax ([(INSPECTOR-VAR) (generate-temporaries #'(INSPECTOR-EXPR))])
#`(begin
(define INSPECTOR-VAR INSPECTOR-EXPR)
#,(build-define-struct #'STRUCT #'INSPECTOR-VAR) ...
#,(build-provide #'STRUCT) ...))]))
(define-syntax (define-structs/provide/contract stx)
(define (build-define-struct struct-stx var-stx)
(syntax-case struct-stx ()
[(NAME ([FIELD CONTRACT] ...) STRUCT ...)
#`(begin
(define-struct NAME (FIELD ...) #,var-stx)
#,(build-define-struct #'STRUCT var-stx) ...)]))
(define (build-provide/contract struct-stx parent-fields)
(syntax-case struct-stx ()
[(NAME ([FIELD CONTRACT-EXPR] ...) STRUCT ...)
(with-syntax ([(PARENT-FIELD ...) parent-fields]
[(CONTRACT-VAR ...) (generate-temporaries #'(CONTRACT-EXPR ...))]
[FIELDS #'(PARENT-FIELD ... [FIELD CONTRACT-VAR] ...)])
#`(begin
(define CONTRACT-VAR CONTRACT-EXPR) ...
(provide/contract
(struct NAME FIELDS))
#,(build-provide #'STRUCT #'FIELDS) ...))]))
(syntax-case stx ()
[(_ INSPECTOR-EXPR STRUCT ...)
(with-syntax ([(INSPECTOR-VAR) (generate-temporaries #'(INSPECTOR-EXPR))])
#`(begin
(define INSPECTOR-VAR INSPECTOR-EXPR)
#,(build-define-struct #'STRUCT #'INSPECTOR-VAR) ...
#,(build-provide/contract #'STRUCT #'()) ...))]))
(define-syntax (define-structs/provide stx) (define-syntax (define-structs/provide stx)
(syntax-case stx () (syntax-case stx ()
[(_ (NAME SUPER) (FIELD ...) REST ...) [(_ (NAME SUPER) (FIELD ...) REST ...)