Sort the init contract forms.
svn: r18535
This commit is contained in:
parent
1bd29dd7e9
commit
9640ea4e2c
|
@ -2632,6 +2632,7 @@
|
||||||
[ext-field-sets (if (null? (class/c-fields ctc))
|
[ext-field-sets (if (null? (class/c-fields ctc))
|
||||||
(class-ext-field-sets cls)
|
(class-ext-field-sets cls)
|
||||||
(make-vector field-pub-width))]
|
(make-vector field-pub-width))]
|
||||||
|
[init (class-init cls)]
|
||||||
[class-make (if name
|
[class-make (if name
|
||||||
(make-naming-constructor
|
(make-naming-constructor
|
||||||
struct:class
|
struct:class
|
||||||
|
@ -2672,7 +2673,7 @@
|
||||||
|
|
||||||
(class-init-args cls)
|
(class-init-args cls)
|
||||||
(class-init-mode cls)
|
(class-init-mode cls)
|
||||||
(class-init cls)
|
init
|
||||||
|
|
||||||
(class-orig-cls cls)
|
(class-orig-cls cls)
|
||||||
#f #f ; serializer is never set
|
#f #f ; serializer is never set
|
||||||
|
@ -3032,12 +3033,19 @@
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ form ...)
|
[(_ form ...)
|
||||||
(let ([parsed-forms (parse-class/c-specs (syntax->list #'(form ...)) #f)])
|
(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)))]
|
(with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))]
|
||||||
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
|
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
|
||||||
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
|
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
|
||||||
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
|
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
|
||||||
[inits #`(list #,@(reverse (hash-ref parsed-forms 'inits null)))]
|
[inits #`(list #,@(map car sorted-inits))]
|
||||||
[init-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'init-contracts null)))]
|
[init-ctcs #`(list #,@(map cdr sorted-inits))]
|
||||||
[inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))]
|
[inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))]
|
||||||
[inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))]
|
[inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))]
|
||||||
[inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))]
|
[inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))]
|
||||||
|
@ -3062,7 +3070,7 @@
|
||||||
inners inner-ctcs
|
inners inner-ctcs
|
||||||
overrides override-ctcs
|
overrides override-ctcs
|
||||||
augments augment-ctcs
|
augments augment-ctcs
|
||||||
augrides augride-ctcs))))]))
|
augrides augride-ctcs)))))]))
|
||||||
|
|
||||||
(define (check-object-contract obj blame methods fields)
|
(define (check-object-contract obj blame methods fields)
|
||||||
(let/ec return
|
(let/ec return
|
||||||
|
|
Loading…
Reference in New Issue
Block a user