diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index f497fd20e5..54c62c44fa 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -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 diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 8abc53e43f..b612669b71 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -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 diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 96c4009ba9..11ad8d60e7 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -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? [