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

combinators: fix broken optimization that made floats work for integer keys.

db4
John Benediktsson 2015-01-17 15:46:04 -08:00
parent be173c8a43
commit a85543a42f
2 changed files with 21 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
core/combinators/combinators-tests.factor
View File

@ -236,6 +236,7 @@ CONSTANT: case-const-2 2
[ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test [ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test
[ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test [ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
: test-case-7 ( obj -- str ) : test-case-7 ( obj -- str )
{ {
{ \ + [ "plus" ] } { \ + [ "plus" ] }
@ -324,3 +325,14 @@ DEFER: corner-case-1
[ ( x x -- x x ) ] [ [ ( x x -- x x ) ] [
[ { [ ] [ ] } spread ] infer [ { [ ] [ ] } spread ] infer
] unit-test ] unit-test
: test-case-13 ( a -- b )
{
{ 5 [ 5 ] }
{ 6 [ 6 ] }
{ 7 [ 7 ] }
{ 8 [ 8 ] }
{ 9 [ 9 ] }
} case ;
[ 5.0 test-case-13 ] [ no-case? ] must-fail-with

18
core/combinators/combinators.factor
View File

@ -159,20 +159,20 @@ ERROR: no-case object ;
: contiguous-range? ( keys -- ? ) : contiguous-range? ( keys -- ? )
dup [ fixnum? ] all? [ dup [ fixnum? ] all? [
dup all-unique? [ dup all-unique? [
[ length ] [ length ] [ supremum ] [ infimum ] tri - - 1 =
[ [ supremum ] [ infimum ] bi - ]
bi - 1 =
] [ drop f ] if ] [ drop f ] if
] [ drop f ] if ; ] [ drop f ] if ;
: dispatch-case-quot ( default assoc -- quot ) : dispatch-case-quot ( default assoc -- quot )
[ [
\ dup , \ dup , \ integer? , [
dup keys [ infimum , ] [ supremum , ] bi \ between? , \ integer>fixnum-strict , \ dup ,
[ dup keys [ infimum , ] [ supremum , ] bi \ between? ,
dup keys infimum , [ - >fixnum ] % [
sort-keys values [ >quotation ] map , dup keys infimum , \ - ,
\ dispatch , sort-keys values [ >quotation ] map ,
\ dispatch ,
] [ ] make , dup , \ if ,
] [ ] make , , \ if , ] [ ] make , , \ if ,
] [ ] make ; ] [ ] make ;