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

Add some failing unit tests exposing bugs in initial-quot: implementation

db4
Slava Pestov 2009-06-13 18:34:27 -05:00
parent a0e3f356c3
commit 285c8cecc6
3 changed files with 46 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
View File

@ -328,3 +328,10 @@ C: <ro-box> ro-box
TUPLE: empty-tuple ; TUPLE: empty-tuple ;
[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test [ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
! Make sure that initial-quot: doesn't inhibit unboxing
TUPLE: initial-quot-tuple { x read-only initial-quot: [ 0 ] } ;
[ 1 ] [
[ initial-quot-tuple new x>> ] count-unboxed-allocations
] unit-test

34
core/classes/tuple/tuple-tests.factor
View File

@ -733,7 +733,11 @@ DEFER: redefine-tuple-twice
TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ; TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ;
SLOT: winner? SLOT: winner?
[ f ] [ 100 [ lucky-number new ] replicate all-equal? ] unit-test [ t ] [ lucky-number new n>> integer? ] unit-test
: compiled-lucky-number ( -- tuple ) lucky-number new ;
[ t ] [ compiled-lucky-number n>> integer? ] unit-test
! Reshaping initial-quot: ! Reshaping initial-quot:
lucky-number new dup n>> 2array "luckiest-number" set lucky-number new dup n>> 2array "luckiest-number" set
@ -744,3 +748,31 @@ lucky-number new dup n>> 2array "luckiest-number" set
[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test [ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
[ t ] [ "luckiest-number" get first winner?>> ] unit-test [ t ] [ "luckiest-number" get first winner?>> ] unit-test
! invalid-quot: together with type declaration
TUPLE: decl-initial-quot { x integer initial-quot: [ 1 ] } ;
[ t ] [ decl-initial-quot new x>> integer? ] unit-test
: compiled-decl-initial-quot ( -- tuple ) decl-initial-quot new ;
[ t ] [ compiled-decl-initial-quot x>> integer? ] unit-test
! invalid-quot: with read-only
TUPLE: read-only-initial-quot { x integer read-only initial-quot: [ 1 ] } ;
[ t ] [ read-only-initial-quot new x>> integer? ] unit-test
: compiled-read-only-initial-quot ( -- tuple ) read-only-initial-quot new ;
[ t ] [ compiled-read-only-initial-quot x>> integer? ] unit-test
! Specifying both initial: and initial-quot: should fail
2 [
[
"IN: classes.tuple.test TUPLE: redundant-decl { x initial: 0 initial-quot: [ 0 ] } ;"
eval( -- )
]
[ error>> duplicate-initial-values? ]
must-fail-with
] times

16
core/classes/tuple/tuple.factor
View File

@ -153,8 +153,7 @@ ERROR: bad-superclass class ;
all-slots [ initial-quot>> ] filter all-slots [ initial-quot>> ] filter
[ [
[ [
[ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ] [ initial-quot>> % \ over , ] [ offset>> , ] bi \ set-slot ,
[ offset>> , ] bi \ set-slot ,
] each ] each
] [ ] make f like ; ] [ ] make f like ;
@ -187,15 +186,10 @@ ERROR: bad-superclass class ;
dup make-tuple-layout "layout" set-word-prop ; dup make-tuple-layout "layout" set-word-prop ;
: calculate-initial-value ( slot-spec -- value ) : calculate-initial-value ( slot-spec -- value )
dup initial>> [ dup initial>> [ ] [
nip dup initial-quot>>
] [ [ call( -- obj ) ] [ drop f ] ?if
dup initial-quot>> [ ] ?if ;
nip call( -- obj )
] [
drop f
] if*
] if* ;
: compute-slot-permutation ( new-slots old-slots -- triples ) : compute-slot-permutation ( new-slots old-slots -- triples )
[ [ [ name>> ] map ] bi@ [ index ] curry map ] [ [ [ name>> ] map ] bi@ [ index ] curry map ]