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

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

@ -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,37 +3033,44 @@
(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)])
(with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))] (let* ([inits (reverse (hash-ref parsed-forms 'inits null))]
[method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))] [init-contracts (reverse (hash-ref parsed-forms 'init-contracts null))]
[fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))] [paired (map cons inits init-contracts)]
[field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))] [sorted-inits (sort paired
[inits #`(list #,@(reverse (hash-ref parsed-forms 'inits null)))] (lambda (s1 s2)
[init-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'init-contracts null)))] (string<? (symbol->string s1) (symbol->string s2)))
[inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))] #:key car)])
[inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))] (with-syntax ([methods #`(list #,@(reverse (hash-ref parsed-forms 'methods null)))]
[inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))] [method-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'method-contracts null)))]
[inherit-field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-field-contracts null)))] [fields #`(list #,@(reverse (hash-ref parsed-forms 'fields null)))]
[supers #`(list #,@(reverse (hash-ref parsed-forms 'supers null)))] [field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'field-contracts null)))]
[super-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'super-contracts null)))] [inits #`(list #,@(map car sorted-inits))]
[inners #`(list #,@(reverse (hash-ref parsed-forms 'inners null)))] [init-ctcs #`(list #,@(map cdr sorted-inits))]
[inner-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inner-contracts null)))] [inherits #`(list #,@(reverse (hash-ref parsed-forms 'inherits null)))]
[overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))] [inherit-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-contracts null)))]
[override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))] [inherit-fields #`(list #,@(reverse (hash-ref parsed-forms 'inherit-fields null)))]
[augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))] [inherit-field-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inherit-field-contracts null)))]
[augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))] [supers #`(list #,@(reverse (hash-ref parsed-forms 'supers null)))]
[augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))] [super-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'super-contracts null)))]
[augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))]) [inners #`(list #,@(reverse (hash-ref parsed-forms 'inners null)))]
(syntax/loc stx [inner-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'inner-contracts null)))]
(make-class/c methods method-ctcs [overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))]
fields field-ctcs [override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))]
inits init-ctcs [augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))]
inherits inherit-ctcs [augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))]
inherit-fields inherit-field-ctcs [augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))]
supers super-ctcs [augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))])
inners inner-ctcs (syntax/loc stx
overrides override-ctcs (make-class/c methods method-ctcs
augments augment-ctcs fields field-ctcs
augrides augride-ctcs))))])) inits init-ctcs
inherits inherit-ctcs
inherit-fields inherit-field-ctcs
supers super-ctcs
inners inner-ctcs
overrides override-ctcs
augments augment-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