Tuple reshaping now works with inheritance
Slava Pestov
parent
2ebb7d2271
commit
6995e2adf5
|
|
@ -153,23 +153,11 @@ HELP: tuple=
|
|||
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
|
||||
{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
|
||||
|
||||
HELP: permutation
|
||||
{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
|
||||
{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
|
||||
|
||||
HELP: reshape-tuple
|
||||
{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } }
|
||||
{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ;
|
||||
|
||||
HELP: reshape-tuples
|
||||
{ $values { "class" tuple-class } { "superclass" class } { "newslots" "a sequence of strings" } }
|
||||
{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
|
||||
|
||||
HELP: removed-slots
|
||||
{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
|
||||
{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
|
||||
|
||||
HELP: forget-slots
|
||||
HELP: forget-removed-slots
|
||||
{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
|
||||
{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -265,9 +265,13 @@ C: <laptop> laptop
|
|||
[ t ] [ "laptop" get computer? ] unit-test
|
||||
[ t ] [ "laptop" get tuple? ] unit-test
|
||||
|
||||
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
|
||||
[ 128 ] [ "laptop" get ram>> ] unit-test
|
||||
[ t ] [ "laptop" get battery>> 3 hours = ] unit-test
|
||||
: test-laptop-slot-values
|
||||
[ laptop ] [ "laptop" get class ] unit-test
|
||||
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test
|
||||
[ 128 ] [ "laptop" get ram>> ] unit-test
|
||||
[ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
|
||||
|
||||
test-laptop-slot-values
|
||||
|
||||
[ laptop ] [
|
||||
"laptop" get tuple-layout
|
||||
|
|
@ -294,9 +298,13 @@ C: <server> server
|
|||
[ t ] [ "server" get computer? ] unit-test
|
||||
[ t ] [ "server" get tuple? ] unit-test
|
||||
|
||||
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
|
||||
[ 64 ] [ "server" get ram>> ] unit-test
|
||||
[ "1U" ] [ "server" get rackmount>> ] unit-test
|
||||
: test-server-slot-values
|
||||
[ server ] [ "server" get class ] unit-test
|
||||
[ "PowerPC" ] [ "server" get cpu>> ] unit-test
|
||||
[ 64 ] [ "server" get ram>> ] unit-test
|
||||
[ "1U" ] [ "server" get rackmount>> ] unit-test ;
|
||||
|
||||
test-server-slot-values
|
||||
|
||||
[ f ] [ "server" get laptop? ] unit-test
|
||||
[ f ] [ "laptop" get server? ] unit-test
|
||||
|
|
@ -316,10 +324,10 @@ C: <server> server
|
|||
"IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
|
||||
] must-fail
|
||||
|
||||
! Reshaping with inheritance
|
||||
! Dynamically changing inheritance hierarchy
|
||||
TUPLE: electronic-device ;
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
|
||||
|
||||
[ f ] [ electronic-device laptop class< ] unit-test
|
||||
[ t ] [ server electronic-device class< ] unit-test
|
||||
|
|
@ -335,11 +343,73 @@ TUPLE: electronic-device ;
|
|||
[ f ] [ "server" get laptop? ] unit-test
|
||||
[ t ] [ "server" get server? ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
|
||||
|
||||
[ f ] [ "laptop" get electronic-device? ] unit-test
|
||||
[ t ] [ "laptop" get computer? ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
||||
TUPLE: make-me-some-accessors voltage grounded? ;
|
||||
|
||||
[ f ] [ "laptop" get voltage>> ] unit-test
|
||||
[ f ] [ "server" get voltage>> ] unit-test
|
||||
|
||||
[ ] [ "laptop" get 220 >>voltage drop ] unit-test
|
||||
[ ] [ "server" get 110 >>voltage drop ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
||||
[ 220 ] [ "laptop" get voltage>> ] unit-test
|
||||
[ 110 ] [ "server" get voltage>> ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
||||
[ 220 ] [ "laptop" get voltage>> ] unit-test
|
||||
[ 110 ] [ "server" get voltage>> ] unit-test
|
||||
|
||||
! Reshaping superclass and subclass simultaneously
|
||||
"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
||||
[ 220 ] [ "laptop" get voltage>> ] unit-test
|
||||
[ 110 ] [ "server" get voltage>> ] unit-test
|
||||
|
||||
! Reshape crash
|
||||
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
|
||||
|
||||
T{ test2 f "a" "b" } "test" set
|
||||
|
||||
: test-a/b
|
||||
[ "a" ] [ "test" get a>> ] unit-test
|
||||
[ "b" ] [ "test" get b>> ] unit-test ;
|
||||
|
||||
test-a/b
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
|
||||
|
||||
test-a/b
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
|
||||
|
||||
test-a/b
|
||||
|
||||
! Redefinition problem
|
||||
TUPLE: redefinition-problem ;
|
||||
|
||||
|
|
|
|||
|
|
@ -24,13 +24,14 @@ M: class tuple-layout "layout" word-prop ;
|
|||
M: tuple tuple-layout 1 slot ;
|
||||
|
||||
M: tuple-layout tuple-layout ;
|
||||
|
||||
: tuple-size tuple-layout layout-size ; inline
|
||||
|
||||
: prepare-tuple>array ( tuple -- n tuple layout )
|
||||
[ tuple-size ] [ ] [ tuple-layout ] tri ;
|
||||
|
||||
: copy-tuple-slots ( n tuple first -- array )
|
||||
[ array-nth ] curry map r> add* ;
|
||||
: copy-tuple-slots ( n tuple -- array )
|
||||
[ array-nth ] curry map ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -128,48 +129,63 @@ PRIVATE>
|
|||
[ writer-word forget-method ] 2bi
|
||||
] with each ;
|
||||
|
||||
: permutation ( seq1 seq2 -- permutation )
|
||||
swap [ index ] curry map ;
|
||||
|
||||
: all-slot-names ( class -- slots )
|
||||
superclasses [ slot-names ] map concat \ class add* ;
|
||||
|
||||
: slot-permutation ( class superclass newslots -- n permutation )
|
||||
[ all-slot-names ] [ all-slot-names ] [ ] tri* append
|
||||
[ drop length ] [ permutation ] 2bi ;
|
||||
: compute-slot-permutation ( class old-slot-names -- permutation )
|
||||
>r all-slot-names r> [ index ] curry map ;
|
||||
|
||||
: permute-direct-slots ( oldslots permutation -- newslots )
|
||||
: apply-slot-permutation ( old-values permutation -- new-values )
|
||||
[ [ swap ?nth ] [ drop f ] if* ] with map ;
|
||||
|
||||
: permute-all-slots ( oldslots n permutation -- newslots )
|
||||
[ >r head r> permute-direct-slots ] [ drop tail ] 3bi append ;
|
||||
: permute-slots ( old-values -- new-values )
|
||||
dup first dup outdated-tuples get at
|
||||
compute-slot-permutation
|
||||
apply-slot-permutation ;
|
||||
|
||||
: change-tuple ( tuple quot -- newtuple )
|
||||
>r tuple>array r> call >tuple ; inline
|
||||
|
||||
: update-tuples ( predicate n permutation -- )
|
||||
[ permute-all-slots ] 2curry [ change-tuple ] curry
|
||||
>r "predicate" word-prop instances dup r> map
|
||||
become ; inline
|
||||
: update-tuple ( tuple -- newtuple )
|
||||
[ permute-slots ] change-tuple ;
|
||||
|
||||
: update-tuples-after ( class superclass newslots -- )
|
||||
[ 2drop ] [ slot-permutation ] 3bi
|
||||
[ update-tuples ] 3curry after-compilation ;
|
||||
: update-tuples ( -- )
|
||||
outdated-tuples get
|
||||
dup assoc-empty? [ drop ] [
|
||||
[ >r class r> key? ] curry instances
|
||||
dup [ update-tuple ] map become
|
||||
] if ;
|
||||
|
||||
[ update-tuples ] update-tuples-hook set-global
|
||||
|
||||
: update-tuples-after ( class -- )
|
||||
outdated-tuples get [ all-slot-names ] cache drop ;
|
||||
|
||||
: subclasses ( class -- classes )
|
||||
class-usages keys [ tuple-class? ] subset ;
|
||||
|
||||
: each-subclass ( class quot -- )
|
||||
>r subclasses r> each ; inline
|
||||
|
||||
: define-tuple-shape ( class -- )
|
||||
[ define-tuple-slots ]
|
||||
[ define-tuple-layout ]
|
||||
[ define-tuple-predicate ]
|
||||
tri ;
|
||||
|
||||
: define-new-tuple-class ( class superclass slots -- )
|
||||
[ drop f tuple-class define-class ]
|
||||
[ nip "slot-names" set-word-prop ] [
|
||||
[ nip "slot-names" set-word-prop ]
|
||||
[
|
||||
2drop
|
||||
class-usages keys [ tuple-class? ] subset [
|
||||
[ define-tuple-slots ]
|
||||
[ define-tuple-layout ]
|
||||
[ define-tuple-predicate ]
|
||||
tri
|
||||
] each
|
||||
[ define-tuple-shape ] each-subclass
|
||||
] 3tri ;
|
||||
|
||||
: redefine-tuple-class ( class superclass slots -- )
|
||||
[ update-tuples-after ]
|
||||
[
|
||||
2drop
|
||||
[ update-tuples-after ] each-subclass
|
||||
]
|
||||
[
|
||||
nip
|
||||
[ forget-removed-slots ]
|
||||
|
|
@ -205,11 +221,6 @@ M: tuple clone
|
|||
M: tuple equal?
|
||||
over tuple? [ tuple= ] [ 2drop f ] if ;
|
||||
|
||||
: delegates ( obj -- seq )
|
||||
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
|
||||
|
||||
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
|
||||
|
||||
M: tuple hashcode*
|
||||
[
|
||||
dup tuple-size -rot 0 -rot [
|
||||
|
|
@ -217,21 +228,26 @@ M: tuple hashcode*
|
|||
] 2curry reduce
|
||||
] recursive-hashcode ;
|
||||
|
||||
! Definition protocol
|
||||
M: tuple-class reset-class
|
||||
{ "metaclass" "superclass" "slots" "layout" } reset-props ;
|
||||
|
||||
M: object get-slots ( obj slots -- ... )
|
||||
[ execute ] with each ;
|
||||
|
||||
M: object set-slots ( ... obj slots -- )
|
||||
<reversed> get-slots ;
|
||||
|
||||
M: object construct-empty ( class -- tuple )
|
||||
tuple-layout <tuple> ;
|
||||
|
||||
M: object construct-boa ( ... class -- tuple )
|
||||
tuple-layout <tuple-boa> ;
|
||||
|
||||
! Deprecated
|
||||
M: object set-slots ( ... obj slots -- )
|
||||
<reversed> get-slots ;
|
||||
|
||||
M: object construct ( ... slots class -- tuple )
|
||||
construct-empty [ swap set-slots ] keep ;
|
||||
|
||||
M: object construct-boa ( ... class -- tuple )
|
||||
tuple-layout <tuple-boa> ;
|
||||
: delegates ( obj -- seq )
|
||||
[ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
|
||||
|
||||
: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
|
||||
|
|
|
|||
|
|
@ -69,21 +69,19 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
dup [ drop crossref? ] assoc-contains?
|
||||
modify-code-heap ;
|
||||
|
||||
SYMBOL: post-compile-tasks
|
||||
|
||||
: after-compilation ( quot -- )
|
||||
post-compile-tasks get push ;
|
||||
SYMBOL: outdated-tuples
|
||||
SYMBOL: update-tuples-hook
|
||||
|
||||
: call-recompile-hook ( -- )
|
||||
changed-words get keys
|
||||
compiled-usages recompile-hook get call ;
|
||||
|
||||
: call-post-compile-tasks ( -- )
|
||||
post-compile-tasks get [ call ] each ;
|
||||
: call-update-tuples-hook ( -- )
|
||||
update-tuples-hook get call ;
|
||||
|
||||
: finish-compilation-unit ( -- )
|
||||
call-recompile-hook
|
||||
call-post-compile-tasks
|
||||
call-update-tuples-hook
|
||||
dup [ drop crossref? ] assoc-contains? modify-code-heap
|
||||
changed-definitions notify-definition-observers ;
|
||||
|
||||
|
|
@ -91,7 +89,7 @@ SYMBOL: post-compile-tasks
|
|||
[
|
||||
H{ } clone changed-words set
|
||||
H{ } clone forgotten-definitions set
|
||||
V{ } clone post-compile-tasks set
|
||||
H{ } clone outdated-tuples set
|
||||
<definitions> new-definitions set
|
||||
<definitions> old-definitions set
|
||||
[ finish-compilation-unit ]
|
||||
|
|
|
|||
|
|
@ -79,3 +79,6 @@ C: <slot-spec> slot-spec
|
|||
dup slot-spec-offset swap slot-spec-name
|
||||
define-slot-methods
|
||||
] with each ;
|
||||
|
||||
: slot-named ( name specs -- spec/f )
|
||||
[ slot-spec-name = ] with find nip ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue