Fixing reshaping to work with type declaration
Slava Pestov
parent
3a9b1bae58
commit
664631aa23
|
|
@ -101,7 +101,7 @@ GENERIC: <yo-momma>
|
|||
|
||||
TUPLE: yo-momma ;
|
||||
|
||||
"IN: classes.tuple.tests C: <yo-momma> yo-momma" eval
|
||||
[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval ] unit-test
|
||||
|
||||
[ f ] [ \ <yo-momma> generic? ] unit-test
|
||||
|
||||
|
|
@ -203,7 +203,7 @@ C: <erg's-reshape-problem> erg's-reshape-problem
|
|||
: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
|
||||
: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
|
||||
|
||||
"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test
|
||||
|
||||
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
|
||||
|
||||
|
|
@ -348,7 +348,7 @@ test-server-slot-values
|
|||
[ 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
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
|
||||
|
||||
test-laptop-slot-values
|
||||
test-server-slot-values
|
||||
|
|
@ -631,3 +631,24 @@ must-fail-with
|
|||
\ blah must-infer
|
||||
|
||||
[ V{ } ] [ blah ] unit-test
|
||||
|
||||
! Test reshaping with type declarations and slot attributes
|
||||
TUPLE: reshape-test x ;
|
||||
|
||||
T{ reshape-test f "hi" } "tuple" set
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test
|
||||
|
||||
[ f ] [ \ reshape-test \ (>>x) method ] unit-test
|
||||
|
||||
[ "tuple" get 5 >>x ] must-fail
|
||||
|
||||
[ "hi" ] [ "tuple" get x>> ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test
|
||||
|
||||
[ 0 ] [ "tuple" get x>> ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test
|
||||
|
||||
[ 0 ] [ "tuple" get x>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -80,9 +80,6 @@ M: tuple-class slots>tuple
|
|||
: slot-names ( class -- seq )
|
||||
"slot-names" word-prop ;
|
||||
|
||||
: all-slot-names ( class -- slots )
|
||||
superclasses [ slot-names ] map concat \ class prefix ;
|
||||
|
||||
ERROR: bad-superclass class ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -158,34 +155,45 @@ ERROR: bad-superclass class ;
|
|||
: define-tuple-layout ( class -- )
|
||||
dup make-tuple-layout "layout" set-word-prop ;
|
||||
|
||||
: compute-slot-permutation ( class old-slot-names -- permutation )
|
||||
>r all-slot-names r> [ index ] curry map ;
|
||||
: compute-slot-permutation ( new-slots old-slots -- triples )
|
||||
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
|
||||
[ drop [ class>> ] map ]
|
||||
[ drop [ initial>> ] map ]
|
||||
2tri 3array flip ;
|
||||
|
||||
: apply-slot-permutation ( old-values permutation -- new-values )
|
||||
[ [ swap ?nth ] [ drop f ] if* ] with map ;
|
||||
: update-slot ( old-values n class initial -- value )
|
||||
pick [
|
||||
>r >r swap nth dup r> instance?
|
||||
[ r> drop ] [ drop r> ] if
|
||||
] [ >r 3drop r> ] if ;
|
||||
|
||||
: permute-slots ( old-values -- new-values )
|
||||
dup first dup outdated-tuples get at
|
||||
: apply-slot-permutation ( old-values triples -- new-values )
|
||||
[ first3 update-slot ] with map ;
|
||||
|
||||
: permute-slots ( old-values layout -- new-values )
|
||||
[ class>> all-slots ] [ outdated-tuples get at ] bi
|
||||
compute-slot-permutation
|
||||
apply-slot-permutation ;
|
||||
|
||||
: change-tuple ( tuple quot -- newtuple )
|
||||
>r tuple>array r> call >tuple ; inline
|
||||
|
||||
: update-tuple ( tuple -- newtuple )
|
||||
[ permute-slots ] change-tuple ;
|
||||
[ tuple-slots ] [ layout-of ] bi
|
||||
[ permute-slots ] [ class>> ] bi
|
||||
slots>tuple ;
|
||||
|
||||
: update-tuples ( -- )
|
||||
outdated-tuples get
|
||||
dup assoc-empty? [ drop ] [
|
||||
[ >r class r> key? ] curry instances
|
||||
[
|
||||
over tuple?
|
||||
[ >r layout-of r> key? ] [ 2drop f ] if
|
||||
] 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 ;
|
||||
[ all-slots ] [ tuple-layout ] bi outdated-tuples get set-at ;
|
||||
|
||||
M: tuple-class update-class
|
||||
{
|
||||
|
|
@ -239,9 +247,9 @@ M: word define-tuple-class
|
|||
define-new-tuple-class ;
|
||||
|
||||
M: tuple-class define-tuple-class
|
||||
over check-superclass
|
||||
3dup tuple-class-unchanged?
|
||||
[ over check-superclass 3dup redefine-tuple-class ] unless
|
||||
3drop ;
|
||||
[ 3drop ] [ redefine-tuple-class ] if ;
|
||||
|
||||
: define-error-class ( class superclass slots -- )
|
||||
[ define-tuple-class ] [ 2drop ] 3bi
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ $nl
|
|||
$nl
|
||||
"Mirrors are created by calling " { $link <mirror> } " or " { $link make-mirror } "." } ;
|
||||
|
||||
HELP: <mirror>
|
||||
HELP: <mirror> ( object -- mirror )
|
||||
{ $values { "object" object } { "mirror" mirror } }
|
||||
{ $description "Creates a " { $link mirror } " reflecting an object." }
|
||||
{ $examples
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: mirrors tools.test assocs kernel arrays accessors words
|
||||
namespaces math slots ;
|
||||
namespaces math slots parser ;
|
||||
IN: mirrors.tests
|
||||
|
||||
TUPLE: foo bar baz ;
|
||||
|
|
@ -50,3 +50,10 @@ TUPLE: color
|
|||
[ T{ color f 0 0 0 } ] [
|
||||
1 2 3 color boa [ <mirror> clear-assoc ] keep
|
||||
] unit-test
|
||||
|
||||
! Test reshaping with a mirror
|
||||
1 2 3 color boa <mirror> "mirror" set
|
||||
|
||||
[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test
|
||||
|
||||
[ 1 ] [ "red" "mirror" get at ] unit-test
|
||||
|
|
|
|||
|
|
@ -5,13 +5,14 @@ arrays classes slots slots.private classes.tuple math vectors
|
|||
quotations accessors combinators ;
|
||||
IN: mirrors
|
||||
|
||||
TUPLE: mirror { object read-only } { slots read-only } ;
|
||||
TUPLE: mirror { object read-only } ;
|
||||
|
||||
: <mirror> ( object -- mirror )
|
||||
dup class all-slots mirror boa ;
|
||||
C: <mirror> mirror
|
||||
|
||||
: object-slots ( mirror -- slots ) object>> class all-slots ; inline
|
||||
|
||||
M: mirror at*
|
||||
[ nip object>> ] [ slots>> slot-named ] 2bi
|
||||
[ nip object>> ] [ object-slots slot-named ] 2bi
|
||||
dup [ offset>> slot t ] [ 2drop f f ] if ;
|
||||
|
||||
: check-set-slot ( val slot -- val offset )
|
||||
|
|
@ -23,21 +24,21 @@ M: mirror at*
|
|||
} cond ; inline
|
||||
|
||||
M: mirror set-at ( val key mirror -- )
|
||||
[ slots>> slot-named check-set-slot ] [ object>> ] bi
|
||||
[ object-slots slot-named check-set-slot ] [ object>> ] bi
|
||||
swap set-slot ;
|
||||
|
||||
M: mirror delete-at ( key mirror -- )
|
||||
f -rot set-at ;
|
||||
|
||||
M: mirror clear-assoc ( mirror -- )
|
||||
[ object>> ] [ slots>> ] bi [
|
||||
[ object>> ] [ object-slots ] bi [
|
||||
[ initial>> ] [ offset>> ] bi swapd set-slot
|
||||
] with each ;
|
||||
|
||||
M: mirror >alist ( mirror -- alist )
|
||||
[ slots>> [ name>> ] map ]
|
||||
[ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
|
||||
zip ;
|
||||
[ object-slots [ [ name>> ] map ] [ [ offset>> ] map ] bi ]
|
||||
[ object>> [ swap slot ] curry ] bi
|
||||
map zip ;
|
||||
|
||||
M: mirror assoc-size mirror-slots length ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue