Doug Coleman
parent
02886132f3
commit
ce57aca4f5
|
|
@ -64,9 +64,9 @@ HELP: alist>quot
|
|||
{ $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ;
|
||||
|
||||
HELP: cond
|
||||
{ $values { "assoc" "a sequence of quotation pairs" } }
|
||||
{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
|
||||
{ $description
|
||||
"Calls the second quotation in the first pair whose first quotation yields a true value."
|
||||
"Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value."
|
||||
$nl
|
||||
"The following two phrases are equivalent:"
|
||||
{ $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" }
|
||||
|
|
@ -78,7 +78,7 @@ HELP: cond
|
|||
"{"
|
||||
" { [ dup 0 > ] [ \"positive\" ] }"
|
||||
" { [ dup 0 < ] [ \"negative\" ] }"
|
||||
" { [ dup zero? ] [ \"zero\" ] }"
|
||||
" [ \"zero\" ]"
|
||||
"} cond"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -88,9 +88,9 @@ HELP: no-cond
|
|||
{ $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ;
|
||||
|
||||
HELP: case
|
||||
{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } }
|
||||
{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } }
|
||||
{ $description
|
||||
"Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
|
||||
"Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
|
||||
$nl
|
||||
"If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -1,7 +1,54 @@
|
|||
IN: combinators.tests
|
||||
USING: alien strings kernel math tools.test io prettyprint
|
||||
namespaces combinators words ;
|
||||
namespaces combinators words classes sequences ;
|
||||
IN: combinators.tests
|
||||
|
||||
! Compiled
|
||||
: cond-test-1 ( obj -- str )
|
||||
{
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
} cond ;
|
||||
|
||||
\ cond-test-1 must-infer
|
||||
|
||||
[ "even" ] [ 2 cond-test-1 ] unit-test
|
||||
[ "odd" ] [ 3 cond-test-1 ] unit-test
|
||||
|
||||
: cond-test-2 ( obj -- str )
|
||||
{
|
||||
{ [ dup t = ] [ drop "true" ] }
|
||||
{ [ dup f = ] [ drop "false" ] }
|
||||
[ drop "something else" ]
|
||||
} cond ;
|
||||
|
||||
\ cond-test-2 must-infer
|
||||
|
||||
[ "true" ] [ t cond-test-2 ] unit-test
|
||||
[ "false" ] [ f cond-test-2 ] unit-test
|
||||
[ "something else" ] [ "ohio" cond-test-2 ] unit-test
|
||||
|
||||
: cond-test-3 ( obj -- str )
|
||||
{
|
||||
[ drop "something else" ]
|
||||
{ [ dup t = ] [ drop "true" ] }
|
||||
{ [ dup f = ] [ drop "false" ] }
|
||||
} cond ;
|
||||
|
||||
\ cond-test-3 must-infer
|
||||
|
||||
[ "something else" ] [ t cond-test-3 ] unit-test
|
||||
[ "something else" ] [ f cond-test-3 ] unit-test
|
||||
[ "something else" ] [ "ohio" cond-test-3 ] unit-test
|
||||
|
||||
: cond-test-4 ( -- )
|
||||
{
|
||||
} cond ;
|
||||
|
||||
\ cond-test-4 must-infer
|
||||
|
||||
[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
|
||||
|
||||
! Interpreted
|
||||
[ "even" ] [
|
||||
2 {
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
|
|
@ -21,11 +68,66 @@ namespaces combinators words ;
|
|||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
{ [ t ] [ drop "neither" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
: case-test-1
|
||||
[ "neither" ] [
|
||||
3 {
|
||||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "neither" ] [
|
||||
3 {
|
||||
{ [ dup string? ] [ drop "string" ] }
|
||||
{ [ dup float? ] [ drop "float" ] }
|
||||
{ [ dup alien? ] [ drop "alien" ] }
|
||||
[ drop "neither" ]
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "early" ] [
|
||||
2 {
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
[ drop "early" ]
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "really early" ] [
|
||||
2 {
|
||||
[ drop "really early" ]
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ { } cond ] [ class \ no-cond = ] must-fail-with
|
||||
|
||||
[ "early" ] [
|
||||
2 {
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
[ drop "early" ]
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ "really early" ] [
|
||||
2 {
|
||||
[ drop "really early" ]
|
||||
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
|
||||
{ [ dup 2 mod 0 = ] [ drop "even" ] }
|
||||
} cond
|
||||
] unit-test
|
||||
|
||||
[ { } cond ] [ class \ no-cond = ] must-fail-with
|
||||
|
||||
! Compiled
|
||||
: case-test-1 ( obj -- obj' )
|
||||
{
|
||||
{ 1 [ "one" ] }
|
||||
{ 2 [ "two" ] }
|
||||
|
|
@ -33,6 +135,8 @@ namespaces combinators words ;
|
|||
{ 4 [ "four" ] }
|
||||
} case ;
|
||||
|
||||
\ case-test-1 must-infer
|
||||
|
||||
[ "two" ] [ 2 case-test-1 ] unit-test
|
||||
|
||||
! Interpreted
|
||||
|
|
@ -40,7 +144,7 @@ namespaces combinators words ;
|
|||
|
||||
[ "x" case-test-1 ] must-fail
|
||||
|
||||
: case-test-2
|
||||
: case-test-2 ( obj -- obj' )
|
||||
{
|
||||
{ 1 [ "one" ] }
|
||||
{ 2 [ "two" ] }
|
||||
|
|
@ -49,12 +153,14 @@ namespaces combinators words ;
|
|||
[ sq ]
|
||||
} case ;
|
||||
|
||||
\ case-test-2 must-infer
|
||||
|
||||
[ 25 ] [ 5 case-test-2 ] unit-test
|
||||
|
||||
! Interpreted
|
||||
[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test
|
||||
|
||||
: case-test-3
|
||||
: case-test-3 ( obj -- obj' )
|
||||
{
|
||||
{ 1 [ "one" ] }
|
||||
{ 2 [ "two" ] }
|
||||
|
|
@ -65,8 +171,122 @@ namespaces combinators words ;
|
|||
[ sq ]
|
||||
} case ;
|
||||
|
||||
\ case-test-3 must-infer
|
||||
|
||||
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
|
||||
|
||||
: case-const-1 1 ;
|
||||
: case-const-2 2 ; inline
|
||||
|
||||
! Compiled
|
||||
: case-test-4 ( obj -- str )
|
||||
{
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case ;
|
||||
|
||||
\ case-test-4 must-infer
|
||||
|
||||
[ "uno" ] [ 1 case-test-4 ] unit-test
|
||||
[ "dos" ] [ 2 case-test-4 ] unit-test
|
||||
[ "tres" ] [ 3 case-test-4 ] unit-test
|
||||
[ "demasiado" ] [ 100 case-test-4 ] unit-test
|
||||
|
||||
: case-test-5 ( obj -- )
|
||||
{
|
||||
{ case-const-1 [ "uno" print ] }
|
||||
{ case-const-2 [ "dos" print ] }
|
||||
{ 3 [ "tres" print ] }
|
||||
{ 4 [ "cuatro" print ] }
|
||||
{ 5 [ "cinco" print ] }
|
||||
[ drop "demasiado" print ]
|
||||
} case ;
|
||||
|
||||
\ case-test-5 must-infer
|
||||
|
||||
[ ] [ 1 case-test-5 ] unit-test
|
||||
|
||||
! Interpreted
|
||||
[ "uno" ] [
|
||||
1 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "dos" ] [
|
||||
2 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "tres" ] [
|
||||
3 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "demasiado" ] [
|
||||
100 {
|
||||
{ case-const-1 [ "uno" ] }
|
||||
{ case-const-2 [ "dos" ] }
|
||||
{ 3 [ "tres" ] }
|
||||
{ 4 [ "cuatro" ] }
|
||||
{ 5 [ "cinco" ] }
|
||||
[ drop "demasiado" ]
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
: do-not-call "do not call" throw ;
|
||||
|
||||
: test-case-6
|
||||
{
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case ;
|
||||
|
||||
[ "three" ] [ 3 test-case-6 ] unit-test
|
||||
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
|
||||
|
||||
[ "three" ] [
|
||||
3 {
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "do-not-call" ] [
|
||||
[ do-not-call ] first {
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
[ "do-not-call" ] [
|
||||
\ do-not-call {
|
||||
{ \ do-not-call [ "do-not-call" ] }
|
||||
{ 3 [ "three" ] }
|
||||
} case
|
||||
] unit-test
|
||||
|
||||
! Interpreted
|
||||
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
IN: combinators
|
||||
USING: arrays sequences sequences.private math.private
|
||||
kernel kernel.private math assocs quotations vectors
|
||||
hashtables sorting ;
|
||||
hashtables sorting words ;
|
||||
|
||||
: cleave ( x seq -- )
|
||||
[ call ] with each ;
|
||||
|
|
@ -34,13 +34,24 @@ hashtables sorting ;
|
|||
ERROR: no-cond ;
|
||||
|
||||
: cond ( assoc -- )
|
||||
[ first call ] find nip dup [ second call ] [ no-cond ] if ;
|
||||
[ dup callable? [ drop t ] [ first call ] if ] find nip
|
||||
[ dup callable? [ call ] [ second call ] if ]
|
||||
[ no-cond ] if* ;
|
||||
|
||||
ERROR: no-case ;
|
||||
: case-find ( obj assoc -- obj' )
|
||||
[
|
||||
dup array? [
|
||||
dupd first dup word? [
|
||||
execute
|
||||
] [
|
||||
dup wrapper? [ wrapped ] when
|
||||
] if =
|
||||
] [ quotation? ] if
|
||||
] find nip ;
|
||||
|
||||
: case ( obj assoc -- )
|
||||
[ dup array? [ dupd first = ] [ quotation? ] if ] find nip
|
||||
{
|
||||
case-find {
|
||||
{ [ dup array? ] [ nip second call ] }
|
||||
{ [ dup quotation? ] [ call ] }
|
||||
{ [ dup not ] [ no-case ] }
|
||||
|
|
@ -73,11 +84,14 @@ M: hashtable hashcode*
|
|||
[ rot \ if 3array append [ ] like ] assoc-each ;
|
||||
|
||||
: cond>quot ( assoc -- quot )
|
||||
[ dup callable? [ [ t ] swap 2array ] when ] map
|
||||
reverse [ no-cond ] swap alist>quot ;
|
||||
|
||||
: linear-case-quot ( default assoc -- quot )
|
||||
[ >r [ dupd = ] curry r> \ drop prefix ] assoc-map
|
||||
alist>quot ;
|
||||
[
|
||||
[ 1quotation \ dup prefix \ = suffix ]
|
||||
[ \ drop prefix ] bi*
|
||||
] assoc-map alist>quot ;
|
||||
|
||||
: (distribute-buckets) ( buckets pair keys -- )
|
||||
dup t eq? [
|
||||
|
|
@ -135,7 +149,9 @@ M: hashtable hashcode*
|
|||
dup empty? [
|
||||
drop
|
||||
] [
|
||||
dup length 4 <= [
|
||||
dup length 4 <=
|
||||
over keys [ word? ] contains? or
|
||||
[
|
||||
linear-case-quot
|
||||
] [
|
||||
dup keys contiguous-range? [
|
||||
|
|
|
|||
Loading…
Reference in New Issue