Fix some bugs in locals

basis/locals/locals-tests.factor

@@ -1,7 +1,7 @@
 USING: locals math sequences tools.test hashtables words kernel
 namespaces arrays strings prettyprint io.streams.string parser
 accessors generic eval combinators combinators.short-circuit
-combinators.short-circuit.smart math.order ;
+combinators.short-circuit.smart math.order math.functions ;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -305,17 +305,29 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 [ f ] [ 8 &&-test ] unit-test
 [ t ] [ 12 &&-test ] unit-test
 
-:: wlet-&&-test ( a -- ? )
+:: let-and-cond-test-1 ( -- a )
-    [wlet | is-integer? [ a integer? ]
+    [let | a [ 10 ] |
-            is-even? [ a even? ]
+        [let | a [ 20 ] |
-            >10? [ a 10 > ] |
+            {
-        { [ is-integer? ] [ is-even? ] [ >10? ] } &&
+                { [ t ] [ [let | c [ 30 ] | a ] ] }
+            } cond
+        ]
     ] ;
 
-! [ f ] [ 1.5 wlet-&&-test ] unit-test
+\ let-and-cond-test-1 must-infer
-! [ f ] [ 3 wlet-&&-test ] unit-test
+
-! [ f ] [ 8 wlet-&&-test ] unit-test
+[ 20 ] [ let-and-cond-test-1 ] unit-test
-! [ t ] [ 12 wlet-&&-test ] unit-test
+
+:: let-and-cond-test-2 ( -- pair )
+    [let | A [ 10 ] |
+        [let | B [ 20 ] |
+            { { [ t ] [ { A B } ] } } cond
+        ]
+    ] ;
+
+\ let-and-cond-test-2 must-infer
+
+[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
 
 [ { 10       } ] [ 10       [| a     | { a     } ] call ] unit-test
 [ { 10 20    } ] [ 10 20    [| a b   | { a b   } ] call ] unit-test
@@ -333,6 +345,16 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 
 { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
 
+
+:: literal-identity-test ( -- a b )
+    { } V{ } ;
+
+[ t f ] [
+    literal-identity-test
+    literal-identity-test
+    swapd [ eq? ] [ eq? ] 2bi*
+] unit-test
+
 :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
     obj1 obj2 <=> {
         { +lt+ [ lt-quot call ] }
@@ -341,3 +363,29 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
     } case ; inline
 
 [ [ ] [ ] [ ] compare-case ] must-infer
+
+:: big-case-test ( a -- b )
+    a {
+        { 0 [ a 1 + ] }
+        { 1 [ a 1 - ] }
+        { 2 [ a 1 swap / ] }
+        { 3 [ a dup * ] }
+        { 4 [ a sqrt ] }
+        { 5 [ a a ^ ] }
+    } case ;
+
+\ big-case-test must-infer
+
+[ 9 ] [ 3 big-case-test ] unit-test
+
+! :: wlet-&&-test ( a -- ? )
+!     [wlet | is-integer? [ a integer? ]
+!             is-even? [ a even? ]
+!             >10? [ a 10 > ] |
+!         { [ is-integer? ] [ is-even? ] [ >10? ] } &&
+!     ] ;
+
+! [ f ] [ 1.5 wlet-&&-test ] unit-test
+! [ f ] [ 3 wlet-&&-test ] unit-test
+! [ f ] [ 8 wlet-&&-test ] unit-test
+! [ t ] [ 12 wlet-&&-test ] unit-test

basis/locals/locals.factor

@@ -35,11 +35,15 @@ C: <wlet> wlet
 
 M: lambda expand-macros clone [ expand-macros ] change-body ;
 
+M: lambda expand-macros* expand-macros literal ;
+
 M: binding-form expand-macros
     clone
         [ [ expand-macros ] assoc-map ] change-bindings
         [ expand-macros ] change-body ;
 
+M: binding-form expand-macros* expand-macros literal ;
+
 PREDICATE: local < word "local?" word-prop ;
 
 : <local> ( name -- word )
@@ -195,6 +199,20 @@ M: block lambda-rewrite*
         swap point-free ,
     ] keep length \ curry <repetition> % ;
 
+GENERIC: rewrite-literal? ( obj -- ? )
+
+M: special rewrite-literal? drop t ;
+
+M: array rewrite-literal? [ rewrite-literal? ] contains? ;
+
+M: hashtable rewrite-literal? drop t ;
+
+M: vector rewrite-literal? drop t ;
+
+M: tuple rewrite-literal? drop t ;
+
+M: object rewrite-literal? drop f ;
+
 GENERIC: rewrite-element ( obj -- )
 
 : rewrite-elements ( seq -- )
@@ -203,7 +221,8 @@ GENERIC: rewrite-element ( obj -- )
 : rewrite-sequence ( seq -- )
     [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
 
-M: array rewrite-element rewrite-sequence ;
+M: array rewrite-element
+    dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
 
 M: vector rewrite-element rewrite-sequence ;
 

basis/macros/expander/expander.factor

@@ -1,14 +1,12 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces make quotations accessors
+USING: kernel sequences sequences.private namespaces make
-words continuations vectors effects math
+quotations accessors words continuations vectors effects math
-stack-checker.transforms ;
+generalizations stack-checker.transforms fry ;
 IN: macros.expander
 
 GENERIC: expand-macros ( quot -- quot' )
 
-<PRIVATE
-
 SYMBOL: stack
 
 : begin ( -- ) V{ } clone stack set ;
@@ -28,6 +26,17 @@ GENERIC: expand-macros* ( obj -- )
 
 M: wrapper expand-macros* wrapped>> literal ;
 
+: expand-dispatch? ( word -- ? )
+    \ dispatch eq? stack get length 1 >= and ;
+
+: expand-dispatch ( -- )
+    stack get pop end
+    [ [ expand-macros ] [ ] map-as '[ _ dip ] % ]
+    [
+        length [ <reversed> ] keep
+        [ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
+    ] bi ;
+
 : expand-macro ( quot -- )
     stack [ swap with-datastack >vector ] change
     stack get pop >quotation end (expand-macros) ;
@@ -38,8 +47,14 @@ M: wrapper expand-macros* wrapped>> literal ;
         stack get length <=
     ] [ 2drop f f ] if ;
 
+: word, ( word -- ) end , ;
+
 M: word expand-macros*
-    dup expand-macro? [ nip expand-macro ] [ drop end , ] if ;
+    dup expand-dispatch? [ drop expand-dispatch ] [
+        dup expand-macro? [ nip expand-macro ] [
+            drop word,
+        ] if
+    ] if ;
 
 M: object expand-macros* literal ;
 
@@ -48,5 +63,3 @@ M: callable expand-macros*
 
 M: callable expand-macros ( quot -- quot' )
     [ begin (expand-macros) end ] [ ] make ;
-
-PRIVATE>

core/combinators/combinators.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays sequences sequences.private math.private
 kernel kernel.private math assocs quotations vectors
-hashtables sorting words sets math.order ;
+hashtables sorting words sets math.order make ;
 IN: combinators
 
 ! cleave
@@ -116,17 +116,16 @@ ERROR: no-case ;
         ] [ drop f ] if
     ] [ drop f ] if ;
 
-: dispatch-case ( value from to default array -- )
-    >r >r 3dup between? r> r> rot [
-        >r 2drop - >fixnum r> dispatch
-    ] [
-        drop 2nip call
-    ] if ; inline
-
 : dispatch-case-quot ( default assoc -- quot )
-    [ nip keys [ infimum ] [ supremum ] bi ] 2keep
+    [
-    sort-keys values [ >quotation ] map
+        \ dup ,
-    [ dispatch-case ] 2curry 2curry ;
+        dup keys [ infimum , ] [ supremum , ] bi \ between? ,
+        [
+            dup keys infimum , [ - >fixnum ] %
+            sort-keys values [ >quotation ] map ,
+            \ dispatch ,
+        ] [ ] make , , \ if ,
+    ] [ ] make ;
 
 : case>quot ( default assoc -- quot )
     dup keys {