Tuple redefinition fixes
Slava Pestov
parent
e1ad21a439
commit
4844bae31a
|
|
@ -2,18 +2,18 @@ USING: definitions generic kernel kernel.private math
|
|||
math.constants parser sequences tools.test words assocs
|
||||
namespaces quotations sequences.private classes continuations
|
||||
generic.standard effects tuples tuples.private arrays vectors
|
||||
strings compiler.units ;
|
||||
strings compiler.units accessors ;
|
||||
IN: tuples.tests
|
||||
|
||||
TUPLE: rect x y w h ;
|
||||
: <rect> rect construct-boa ;
|
||||
|
||||
: move ( x rect -- )
|
||||
[ rect-x + ] keep set-rect-x ;
|
||||
: move ( x rect -- rect )
|
||||
[ + ] change-x ;
|
||||
|
||||
[ f ] [ 10 20 30 40 <rect> dup clone 5 swap [ move ] keep = ] unit-test
|
||||
[ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
|
||||
|
||||
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
|
||||
[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
|
||||
|
||||
GENERIC: delegation-test
|
||||
M: object delegation-test drop 3 ;
|
||||
|
|
@ -34,27 +34,46 @@ TUPLE: quuux-tuple-2 ;
|
|||
|
||||
[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
|
||||
|
||||
! Make sure we handle tuple class redefinition
|
||||
TUPLE: redefinition-test ;
|
||||
|
||||
C: <redefinition-test> redefinition-test
|
||||
|
||||
<redefinition-test> "redefinition-test" set
|
||||
|
||||
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
|
||||
|
||||
"IN: tuples.tests TUPLE: redefinition-test ;" eval
|
||||
|
||||
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
|
||||
|
||||
! Make sure we handle changing shapes!
|
||||
TUPLE: point x y ;
|
||||
|
||||
C: <point> point
|
||||
|
||||
100 200 <point> "p" set
|
||||
[ ] [ 100 200 <point> "p" set ] unit-test
|
||||
|
||||
! Use eval to sequence parsing explicitly
|
||||
"IN: tuples.tests TUPLE: point x y z ;" eval
|
||||
[ ] [ "IN: tuples.tests TUPLE: point x y z ;" eval ] unit-test
|
||||
|
||||
[ 100 ] [ "p" get point-x ] unit-test
|
||||
[ 200 ] [ "p" get point-y ] unit-test
|
||||
[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
|
||||
[ 100 ] [ "p" get x>> ] unit-test
|
||||
[ 200 ] [ "p" get y>> ] unit-test
|
||||
[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
|
||||
|
||||
300 "p" get "set-point-z" "tuples.tests" lookup execute
|
||||
"p" get 300 ">>z" "accessors" lookup execute drop
|
||||
|
||||
[ 4 ] [ "p" get tuple-size ] unit-test
|
||||
|
||||
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
|
||||
|
||||
"IN: tuples.tests TUPLE: point z y ;" eval
|
||||
|
||||
[ "p" get point-x ] must-fail
|
||||
[ 200 ] [ "p" get point-y ] unit-test
|
||||
[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
|
||||
[ 3 ] [ "p" get tuple-size ] unit-test
|
||||
|
||||
[ "p" get x>> ] must-fail
|
||||
[ 200 ] [ "p" get y>> ] unit-test
|
||||
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
|
||||
|
||||
TUPLE: predicate-test ;
|
||||
|
||||
|
|
@ -68,10 +87,10 @@ PREDICATE: tuple silly-pred
|
|||
class \ rect = ;
|
||||
|
||||
GENERIC: area
|
||||
M: silly-pred area dup rect-w swap rect-h * ;
|
||||
M: silly-pred area dup w>> swap h>> * ;
|
||||
|
||||
TUPLE: circle radius ;
|
||||
M: circle area circle-radius sq pi * ;
|
||||
M: circle area radius>> sq pi * ;
|
||||
|
||||
[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
|
||||
|
||||
|
|
@ -88,7 +107,7 @@ TUPLE: delegate-clone ;
|
|||
[ T{ delegate-clone T{ empty f } } clone ] unit-test
|
||||
|
||||
! Compiler regression
|
||||
[ t length ] [ no-method-object t eq? ] must-fail-with
|
||||
[ t length ] [ object>> t eq? ] must-fail-with
|
||||
|
||||
[ "<constructor-test>" ]
|
||||
[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
|
||||
|
|
@ -96,7 +115,7 @@ TUPLE: delegate-clone ;
|
|||
TUPLE: size-test a b c d ;
|
||||
|
||||
[ t ] [
|
||||
T{ size-test } array-capacity
|
||||
T{ size-test } tuple-size
|
||||
size-test tuple-size =
|
||||
] unit-test
|
||||
|
||||
|
|
@ -213,55 +232,50 @@ C: <erg's-reshape-problem> erg's-reshape-problem
|
|||
! tuples are reshaped
|
||||
: cons-test-1 \ erg's-reshape-problem construct-empty ;
|
||||
: cons-test-2 \ erg's-reshape-problem construct-boa ;
|
||||
: cons-test-3
|
||||
{ set-erg's-reshape-problem-a }
|
||||
\ erg's-reshape-problem construct ;
|
||||
|
||||
"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
|
||||
|
||||
[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
|
||||
|
||||
[ t ] [ cons-test-1 array-capacity "a" get array-capacity = ] unit-test
|
||||
|
||||
[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test
|
||||
|
||||
[
|
||||
"IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
|
||||
] [ [ no-tuple-class? ] is? ] must-fail-with
|
||||
|
||||
! Hardcore unit tests
|
||||
USE: threads
|
||||
|
||||
\ thread "slot-names" word-prop "slot-names" set
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ thread { "xxx" } "slot-names" get append
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
|
||||
[ 1337 sleep ] "Test" spawn drop
|
||||
|
||||
[
|
||||
\ thread "slot-names" get
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
USE: vocabs
|
||||
|
||||
\ vocab "slot-names" word-prop "slot-names" set
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ vocab { "xxx" } "slot-names" get append
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
|
||||
all-words drop
|
||||
|
||||
[
|
||||
\ vocab "slot-names" get
|
||||
define-tuple-class
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
! "IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
|
||||
!
|
||||
! [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
|
||||
!
|
||||
! [ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
|
||||
!
|
||||
! [
|
||||
! "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
|
||||
! ] [ [ no-tuple-class? ] is? ] must-fail-with
|
||||
!
|
||||
! ! Hardcore unit tests
|
||||
! USE: threads
|
||||
!
|
||||
! \ thread "slot-names" word-prop "slot-names" set
|
||||
!
|
||||
! [ ] [
|
||||
! [
|
||||
! \ thread { "xxx" } "slot-names" get append
|
||||
! define-tuple-class
|
||||
! ] with-compilation-unit
|
||||
!
|
||||
! [ 1337 sleep ] "Test" spawn drop
|
||||
!
|
||||
! [
|
||||
! \ thread "slot-names" get
|
||||
! define-tuple-class
|
||||
! ] with-compilation-unit
|
||||
! ] unit-test
|
||||
!
|
||||
! USE: vocabs
|
||||
!
|
||||
! \ vocab "slot-names" word-prop "slot-names" set
|
||||
!
|
||||
! [ ] [
|
||||
! [
|
||||
! \ vocab { "xxx" } "slot-names" get append
|
||||
! define-tuple-class
|
||||
! ] with-compilation-unit
|
||||
!
|
||||
! all-words drop
|
||||
!
|
||||
! [
|
||||
! \ vocab "slot-names" get
|
||||
! define-tuple-class
|
||||
! ] with-compilation-unit
|
||||
! ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays definitions hashtables kernel
|
||||
kernel.private math namespaces sequences sequences.private
|
||||
strings vectors words quotations memory combinators generic
|
||||
classes classes.private slots slots.deprecated slots.private
|
||||
classes classes.private slots.deprecated slots.private slots
|
||||
compiler.units ;
|
||||
IN: tuples
|
||||
|
||||
|
|
@ -49,43 +49,6 @@ PRIVATE>
|
|||
2drop f
|
||||
] if ;
|
||||
|
||||
: permutation ( seq1 seq2 -- permutation )
|
||||
swap [ index ] curry map ;
|
||||
|
||||
: reshape-tuple ( oldtuple permutation -- newtuple )
|
||||
>r tuple>array 2 cut r>
|
||||
[ [ swap ?nth ] [ drop f ] if* ] with map
|
||||
append >tuple ;
|
||||
|
||||
: reshape-tuples ( class newslots -- )
|
||||
>r dup "slot-names" word-prop r> permutation
|
||||
[
|
||||
>r [ swap class eq? ] curry instances dup r>
|
||||
[ reshape-tuple ] curry map
|
||||
become
|
||||
] 2curry after-compilation ;
|
||||
|
||||
: old-slots ( class newslots -- seq )
|
||||
swap "slots" word-prop 1 tail-slice
|
||||
[ slot-spec-name swap member? not ] with subset ;
|
||||
|
||||
: forget-slots ( class newslots -- )
|
||||
dupd old-slots [
|
||||
2dup
|
||||
slot-spec-reader 2array forget
|
||||
slot-spec-writer 2array forget
|
||||
] with each ;
|
||||
|
||||
: check-shape ( class newslots -- )
|
||||
over tuple-class? [
|
||||
over "slot-names" word-prop over = [
|
||||
2dup forget-slots
|
||||
2dup reshape-tuples
|
||||
over changed-word
|
||||
over redefined
|
||||
] unless
|
||||
] when 2drop ;
|
||||
|
||||
M: tuple-class tuple-layout "layout" word-prop ;
|
||||
|
||||
: define-tuple-predicate ( class -- )
|
||||
|
|
@ -114,15 +77,59 @@ M: tuple-class tuple-layout "layout" word-prop ;
|
|||
dup "slot-names" word-prop length 1+ { } 0 <tuple-layout>
|
||||
"layout" set-word-prop ;
|
||||
|
||||
PRIVATE>
|
||||
: removed-slots ( class newslots -- seq )
|
||||
swap "slot-names" word-prop seq-diff ;
|
||||
|
||||
: define-tuple-class ( class slots -- )
|
||||
2dup check-shape
|
||||
over f tuple tuple-class define-class
|
||||
: forget-slots ( class newslots -- )
|
||||
dupd removed-slots [
|
||||
2dup
|
||||
reader-word forget-method
|
||||
writer-word forget-method
|
||||
] with each ;
|
||||
|
||||
: permutation ( seq1 seq2 -- permutation )
|
||||
swap [ index ] curry map ;
|
||||
|
||||
: reshape-tuple ( oldtuple permutation -- newtuple )
|
||||
>r tuple>array 2 cut r>
|
||||
[ [ swap ?nth ] [ drop f ] if* ] with map
|
||||
append >tuple ;
|
||||
|
||||
: reshape-tuples ( class newslots -- )
|
||||
>r dup "slot-names" word-prop r> permutation
|
||||
[
|
||||
>r [ swap class eq? ] curry instances dup r>
|
||||
[ reshape-tuple ] curry map
|
||||
become
|
||||
] 2curry after-compilation ;
|
||||
|
||||
: tuple-class-unchanged 2drop ;
|
||||
|
||||
: prepare-tuple-class ( class slots -- )
|
||||
dupd define-tuple-slots
|
||||
dup define-tuple-layout
|
||||
define-tuple-predicate ;
|
||||
|
||||
: redefine-tuple-class ( class slots -- )
|
||||
2dup forget-slots
|
||||
2dup reshape-tuples
|
||||
over changed-word
|
||||
over redefined
|
||||
prepare-tuple-class ;
|
||||
|
||||
: define-new-tuple-class ( class slots -- )
|
||||
over f tuple tuple-class define-class
|
||||
prepare-tuple-class ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: define-tuple-class ( class slots -- )
|
||||
{
|
||||
{ [ over tuple-class? not ] [ define-new-tuple-class ] }
|
||||
{ [ over "slot-names" word-prop over = ] [ tuple-class-unchanged ] }
|
||||
{ [ t ] [ redefine-tuple-class ] }
|
||||
} cond ;
|
||||
|
||||
M: tuple clone
|
||||
(clone) dup delegate clone over set-delegate ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue