case now executes its keys if they are words

cond now accepts a default quotation

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

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
 

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? [