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

Adding cstruct, which is like the struct signature form but with contracts.

Browse Source 
svn: r13647

original commit: 340035bef7544d1bb868c98e5fb28a18a4214222
This commit is contained in:
Stevie Strickland 2009-02-16 02:51:12 +00:00
commit cf063bd01f
1 changed files with 86 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
collects/mzlib/unit.ss
View File

@ -1,5 +1,6 @@
(module unit mzscheme (module unit mzscheme
(require-for-syntax mzlib/list (require-for-syntax mzlib/list
scheme/pretty
stxclass stxclass
syntax/boundmap syntax/boundmap
syntax/context syntax/context
@ -19,7 +20,7 @@
"private/unit-runtime.ss" "private/unit-runtime.ss"
"private/unit-utils.ss") "private/unit-utils.ss")
(provide define-signature-form struct open (provide define-signature-form struct cstruct open
define-signature provide-signature-elements define-signature provide-signature-elements
only except rename import export prefix link tag init-depend extends contracted only except rename import export prefix link tag init-depend extends contracted
unit? unit?
@ -125,6 +126,90 @@
((_) ((_)
(raise-stx-err "missing name and fields"))))) (raise-stx-err "missing name and fields")))))
(define-signature-form (cstruct stx)
(parameterize ((error-syntax stx))
(syntax-case stx ()
((_ name ([field ctc] ...) . omissions)
(let ([omit-selectors #f]
[omit-setters #f]
[omit-constructor #f]
[omit-type #f])
(define (remove-ctor&type-info l)
(define new-type
(if omit-type
#f
(cadr l)))
(define new-ctor
(if omit-constructor
#f
(caddr l)))
(cons (car l)
(cons new-type
(cons new-ctor
(cdddr l)))))
(define (add-contracts l)
(let* ([pred (caddr l)]
[ctor-ctc #`(-> ctc ... #,pred)]
[pred-ctc #`(-> any/c boolean?)]
[field-ctcs (apply append
(map (λ (c)
(append (if omit-selectors
null
(list #`(-> #,pred #,c)))
(if omit-setters
null
(list #`(-> #,pred #,c void?)))))
(syntax->list #'(ctc ...))))])
(list* (car l)
(list (cadr l) ctor-ctc)
(list pred pred-ctc)
(map list (cdddr l) field-ctcs))))
(check-id #'name)
(for-each check-id (syntax->list #'(field ...)))
(for-each
(lambda (omission)
(cond
((and (identifier? omission)
(module-identifier=? omission #'-selectors))
(set! omit-selectors #t))
((and (identifier? omission)
(module-identifier=? omission #'-setters))
(set! omit-setters #t))
((and (identifier? omission)
(module-identifier=? omission #'-constructor))
(set! omit-constructor #t))
((and (identifier? omission)
(module-identifier=? omission #'-type))
(set! omit-type #t))
(else
(raise-stx-err
"expected \"-selectors\" or \"-setters\" or \"-constructor\" or \"-type\""
omission))))
(checked-syntax->list #'omissions))
(cons
#`(define-syntaxes (name)
#,(remove-ctor&type-info
(build-struct-expand-info
#'name (syntax->list #'(field ...))
omit-selectors omit-setters
#f '(#f) '(#f))))
(let* ([res (add-contracts
(build-struct-names #'name (syntax->list #'(field ...))
omit-selectors omit-setters #f))]
[cpairs (cons 'contracted (if omit-constructor (cddr res) (cdr res)))])
(if omit-type
(list cpairs)
(list (car res) cpairs))))))
((_ name (x . y) . omissions)
;; Will fail
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx)))))
((_ name fields . omissions)
(raise-stx-err "expected syntax matching (identifier ...)" #'fields))
((_ name)
(raise-stx-err "missing fields"))
((_)
(raise-stx-err "missing name and fields")))))
;; build-val+macro-defs : sig -> (list syntax-object^3) ;; build-val+macro-defs : sig -> (list syntax-object^3)
(define-for-syntax (build-val+macro-defs sig) (define-for-syntax (build-val+macro-defs sig)