steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Tuple redefinition fixes

db4
Slava Pestov 2008-03-26 16:38:31 -05:00
parent e1ad21a439
commit 4844bae31a
2 changed files with 132 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
core/tuples/tuples-tests.factor
View File

@ -2,18 +2,18 @@ USING: definitions generic kernel kernel.private math
math.constants parser sequences tools.test words assocs math.constants parser sequences tools.test words assocs
namespaces quotations sequences.private classes continuations namespaces quotations sequences.private classes continuations
generic.standard effects tuples tuples.private arrays vectors generic.standard effects tuples tuples.private arrays vectors
strings compiler.units ; strings compiler.units accessors ;
IN: tuples.tests IN: tuples.tests
TUPLE: rect x y w h ; TUPLE: rect x y w h ;
: <rect> rect construct-boa ; : <rect> rect construct-boa ;
: move ( x rect -- ) : move ( x rect -- rect )
[ rect-x + ] keep set-rect-x ; [ + ] 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 GENERIC: delegation-test
M: object delegation-test drop 3 ; 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 [ 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! ! Make sure we handle changing shapes!
TUPLE: point x y ; TUPLE: point x y ;
C: <point> point C: <point> point
100 200 <point> "p" set [ ] [ 100 200 <point> "p" set ] unit-test
! Use eval to sequence parsing explicitly ! 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 [ 100 ] [ "p" get x>> ] unit-test
[ 200 ] [ "p" get point-y ] unit-test [ 200 ] [ "p" get y>> ] unit-test
[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] 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 "IN: tuples.tests TUPLE: point z y ;" eval
[ "p" get point-x ] must-fail [ 3 ] [ "p" get tuple-size ] unit-test
[ 200 ] [ "p" get point-y ] unit-test
[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] 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 ; TUPLE: predicate-test ;
@ -68,10 +87,10 @@ PREDICATE: tuple silly-pred
class \ rect = ; class \ rect = ;
GENERIC: area GENERIC: area
M: silly-pred area dup rect-w swap rect-h * ; M: silly-pred area dup w>> swap h>> * ;
TUPLE: circle radius ; 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 [ 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 [ T{ delegate-clone T{ empty f } } clone ] unit-test
! Compiler regression ! Compiler regression
[ t length ] [ no-method-object t eq? ] must-fail-with [ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ] [ "<constructor-test>" ]
[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-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 ; TUPLE: size-test a b c d ;
[ t ] [ [ t ] [
T{ size-test } array-capacity T{ size-test } tuple-size
size-test tuple-size = size-test tuple-size =
] unit-test ] unit-test
@ -213,55 +232,50 @@ C: <erg's-reshape-problem> erg's-reshape-problem
! tuples are reshaped ! tuples are reshaped
: cons-test-1 \ erg's-reshape-problem construct-empty ; : cons-test-1 \ erg's-reshape-problem construct-empty ;
: cons-test-2 \ erg's-reshape-problem construct-boa ; : 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 ! "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 ! [ ] [ 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 ] [ cons-test-1 tuple-size "a" get tuple-size = ] 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
"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
! Hardcore unit tests !
USE: threads ! \ thread "slot-names" word-prop "slot-names" set
!
\ thread "slot-names" word-prop "slot-names" set ! [ ] [
! [
[ ] [ ! \ thread { "xxx" } "slot-names" get append
[ ! define-tuple-class
\ thread { "xxx" } "slot-names" get append ! ] with-compilation-unit
define-tuple-class !
] with-compilation-unit ! [ 1337 sleep ] "Test" spawn drop
!
[ 1337 sleep ] "Test" spawn drop ! [
! \ thread "slot-names" get
[ ! define-tuple-class
\ thread "slot-names" get ! ] with-compilation-unit
define-tuple-class ! ] unit-test
] with-compilation-unit !
] unit-test ! USE: vocabs
!
USE: vocabs ! \ vocab "slot-names" word-prop "slot-names" set
!
\ vocab "slot-names" word-prop "slot-names" set ! [ ] [
! [
[ ] [ ! \ vocab { "xxx" } "slot-names" get append
[ ! define-tuple-class
\ vocab { "xxx" } "slot-names" get append ! ] with-compilation-unit
define-tuple-class !
] with-compilation-unit ! all-words drop
!
all-words drop ! [
! \ vocab "slot-names" get
[ ! define-tuple-class
\ vocab "slot-names" get ! ] with-compilation-unit
define-tuple-class ! ] unit-test
] with-compilation-unit
] unit-test

91
core/tuples/tuples.factor
View File

@ -3,7 +3,7 @@
USING: arrays definitions hashtables kernel USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic 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 ; compiler.units ;
IN: tuples IN: tuples
@ -49,43 +49,6 @@ PRIVATE>
2drop f 2drop f
] if ; ] 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 ; M: tuple-class tuple-layout "layout" word-prop ;
: define-tuple-predicate ( class -- ) : 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> dup "slot-names" word-prop length 1+ { } 0 <tuple-layout>
"layout" set-word-prop ; "layout" set-word-prop ;
PRIVATE> : removed-slots ( class newslots -- seq )
swap "slot-names" word-prop seq-diff ;
: define-tuple-class ( class slots -- ) : forget-slots ( class newslots -- )
2dup check-shape dupd removed-slots [
over f tuple tuple-class define-class 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 dupd define-tuple-slots
dup define-tuple-layout dup define-tuple-layout
define-tuple-predicate ; 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 M: tuple clone
(clone) dup delegate clone over set-delegate ; (clone) dup delegate clone over set-delegate ;