Add some failing unit tests exposing bugs in initial-quot: implementation
parent
a0e3f356c3
commit
285c8cecc6
|
@ -327,4 +327,11 @@ C: <ro-box> ro-box
|
|||
|
||||
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
|
|
@ -733,7 +733,11 @@ DEFER: redefine-tuple-twice
|
|||
TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ;
|
||||
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:
|
||||
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 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
|
||||
|
|
|
@ -153,8 +153,7 @@ ERROR: bad-superclass class ;
|
|||
all-slots [ initial-quot>> ] filter
|
||||
[
|
||||
[
|
||||
[ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
|
||||
[ offset>> , ] bi \ set-slot ,
|
||||
[ initial-quot>> % \ over , ] [ offset>> , ] bi \ set-slot ,
|
||||
] each
|
||||
] [ ] make f like ;
|
||||
|
||||
|
@ -187,15 +186,10 @@ ERROR: bad-superclass class ;
|
|||
dup make-tuple-layout "layout" set-word-prop ;
|
||||
|
||||
: calculate-initial-value ( slot-spec -- value )
|
||||
dup initial>> [
|
||||
nip
|
||||
] [
|
||||
dup initial-quot>> [
|
||||
nip call( -- obj )
|
||||
] [
|
||||
drop f
|
||||
] if*
|
||||
] if* ;
|
||||
dup initial>> [ ] [
|
||||
dup initial-quot>>
|
||||
[ call( -- obj ) ] [ drop f ] ?if
|
||||
] ?if ;
|
||||
|
||||
: compute-slot-permutation ( new-slots old-slots -- triples )
|
||||
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
|
||||
|
|
Loading…
Reference in New Issue