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

Got the struct:x name built, but forgot just the name x for the static info,

Browse Source 
even though I had changed with-contract to detect (uncontracted) exports of
syntax.

svn: r14004
This commit is contained in:
Stevie Strickland 2009-03-07 16:48:27 +00:00
parent d07a335324
commit a3035a76a8
1 changed files with 4 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/scheme/private/contract.ss
View File

@ -132,7 +132,8 @@ improve method arity mismatch contract violation error messages?
(define (build-struct-names name field-infos) (define (build-struct-names name field-infos)
(let ([name-str (symbol->string (syntax-e name))]) (let ([name-str (symbol->string (syntax-e name))])
(list* (datum->syntax (list* name
(datum->syntax
name name
(string->symbol (string->symbol
(string-append "struct:" name-str))) (string-append "struct:" name-str)))
@ -284,7 +285,7 @@ improve method arity mismatch contract violation error messages?
(let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))] (let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))]
[sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)] [sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)]
[names (build-struct-names #'name field-infos)] [names (build-struct-names #'name field-infos)]
[pred (caddr names)] [pred (cadddr names)]
[ctcs (build-contracts stx pred field-infos)]) [ctcs (build-contracts stx pred field-infos)])
(let-values ([(non-auto-fields auto-fields) (let-values ([(non-auto-fields auto-fields)
(let loop ([fields field-infos] (let loop ([fields field-infos]
@ -306,7 +307,7 @@ improve method arity mismatch contract violation error messages?
(field-info-stx (car fields)))))))]) (field-info-stx (car fields)))))))])
(with-syntax ([ctc-bindings (with-syntax ([ctc-bindings
(let ([val-bindings (if (s-info-def-vals? sinfo) (let ([val-bindings (if (s-info-def-vals? sinfo)
(map list (cdr names) ctcs) (cons (cadr names) (map list (cddr names) ctcs))
null)]) null)])
(if (s-info-def-stxs? sinfo) (if (s-info-def-stxs? sinfo)
(cons (car names) val-bindings) (cons (car names) val-bindings)