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

Keep the original class in the supers list. Also, copy over the no-super-init?

Browse Source 
flag.

svn: r18296
This commit is contained in:
Stevie Strickland 2010-02-23 12:51:27 +00:00
parent ff065ca1d8
commit 09425bc801
1 changed files with 11 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2570,6 +2570,13 @@
(λ (cls) (λ (cls)
(class/c-check-first-order ctc cls blame) (class/c-check-first-order ctc cls blame)
(let* ([name (class-name cls)] (let* ([name (class-name cls)]
;; Only add a new slot if we're not projecting an already contracted class.
[supers (if (eq? (class-orig-cls cls) cls)
(list->vector (append (vector->list (class-supers cls)) (list #f)))
(list->vector (vector->list (class-supers cls))))]
[pos (if (eq? (class-orig-cls cls) cls)
(add1 (class-pos cls))
(class-pos cls))]
[method-width (class-method-width cls)] [method-width (class-method-width cls)]
[method-ht (class-method-ht cls)] [method-ht (class-method-ht cls)]
[dynamic-features [dynamic-features
@ -2620,8 +2627,8 @@
(string->symbol (format "class:~a" name))) (string->symbol (format "class:~a" name)))
make-class)] make-class)]
[c (class-make name [c (class-make name
(class-pos cls) pos
(list->vector (vector->list (class-supers cls))) supers
(class-self-interface cls) (class-self-interface cls)
void ;; No inspecting void ;; No inspecting
@ -2658,12 +2665,12 @@
(class-orig-cls cls) (class-orig-cls cls)
#f #f ; serializer is never set #f #f ; serializer is never set
#f)] (class-no-super-init? cls))]
[obj-name (if name [obj-name (if name
(string->symbol (format "object:~a" name)) (string->symbol (format "object:~a" name))
'object)]) 'object)])
(vector-set! (class-supers c) (class-pos c) c) (vector-set! supers pos c)
;; --- Make the new object struct --- ;; --- Make the new object struct ---
(let-values ([(struct:object object-make object? object-field-ref object-field-set!) (let-values ([(struct:object object-make object? object-field-ref object-field-set!)