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

Sort the init contract forms.

Browse Source 
svn: r18535
This commit is contained in:
Stevie Strickland 2010-03-15 07:03:54 +00:00
parent 1bd29dd7e9
commit 9640ea4e2c
1 changed files with 40 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/scheme/private/class-internal.ss
View File

@ -2632,6 +2632,7 @@
[ext-field-sets (if (null? (class/c-fields ctc))
(class-ext-field-sets cls)
(make-vector field-pub-width))]
[init (class-init cls)]
[class-make (if name
(make-naming-constructor
struct:class
@ -2672,7 +2673,7 @@
(class-init-args cls)
(class-init-mode cls)
(class-init cls)
init
(class-orig-cls cls)
#f #f ; serializer is never set
@ -3032,12 +3033,19 @@
(syntax-case stx ()
[(_ form ...)
(let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #f)])
(let* ([inits (reverse (hash-ref parsed-forms 'inits null))]
[init-contracts (reverse (hash-ref parsed-forms 'init-contracts null))]
[paired (map cons inits init-contracts)]
[sorted-inits (sort paired
(lambda (s1 s2)
(string<? (symbol->string s1) (symbol->string s2)))
#:key car)])
(with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))]
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
[inits #`(list #,@(reverse (hash-ref parsed-forms 'inits null)))]
[init-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'init-contracts null)))]
[inits #`(list #,@(map car sorted-inits))]
[init-ctcs #`(list #,@(map cdr sorted-inits))]
[inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))]
[inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))]
[inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))]
@ -3062,7 +3070,7 @@
inners inner-ctcs
overrides override-ctcs
augments augment-ctcs
augrides augride-ctcs))))]))
augrides augride-ctcs)))))]))
(define (check-object-contract obj blame methods fields)
(let/ec return