diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index bc1e736b75..c449c26348 100644 --- a/basis/locals/locals-tests.factor +++ b/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 -- ? ) - [wlet | is-integer? [ a integer? ] - is-even? [ a even? ] - >10? [ a 10 > ] | - { [ is-integer? ] [ is-even? ] [ >10? ] } && +:: let-and-cond-test-1 ( -- a ) + [let | a [ 10 ] | + [let | a [ 20 ] | + { + { [ t ] [ [let | c [ 30 ] | a ] ] } + } cond + ] ] ; -! [ 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 +\ let-and-cond-test-1 must-infer + +[ 20 ] [ let-and-cond-test-1 ] 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 ] } @@ -340,4 +362,30 @@ M:: sequence method-with-locals ( a -- y ) a reverse ; { +gt+ [ gt-quot call ] } } case ; inline -[ [ ] [ ] [ ] compare-case ] must-infer \ No newline at end of file +[ [ ] [ ] [ ] 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 \ No newline at end of file diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index bbcc8a6745..0fb8cefc48 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -35,11 +35,15 @@ C: 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 ; : ( name -- word ) @@ -142,12 +146,12 @@ GENERIC: free-vars* ( form -- ) [ free-vars* ] { } make prune ; : add-if-free ( object -- ) - { - { [ dup local-writer? ] [ "local-reader" word-prop , ] } - { [ dup lexical? ] [ , ] } - { [ dup quote? ] [ local>> , ] } - { [ t ] [ free-vars* ] } - } cond ; + { + { [ dup local-writer? ] [ "local-reader" word-prop , ] } + { [ dup lexical? ] [ , ] } + { [ dup quote? ] [ local>> , ] } + { [ t ] [ free-vars* ] } + } cond ; M: object free-vars* drop ; @@ -195,6 +199,20 @@ M: block lambda-rewrite* swap point-free , ] keep length \ curry % ; +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 ; diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index d62c6bf466..c2fceffae6 100644 --- a/basis/macros/expander/expander.factor +++ b/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 -words continuations vectors effects math -stack-checker.transforms ; +USING: kernel sequences sequences.private namespaces make +quotations accessors words continuations vectors effects math +generalizations stack-checker.transforms fry ; IN: macros.expander GENERIC: expand-macros ( quot -- quot' ) -> literal ; +: expand-dispatch? ( word -- ? ) + \ dispatch eq? stack get length 1 >= and ; + +: expand-dispatch ( -- ) + stack get pop end + [ [ expand-macros ] [ ] map-as '[ _ dip ] % ] + [ + length [ ] 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> diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 4a362a7f9d..577dd153a1 100644 --- a/core/combinators/combinators.factor +++ b/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 - [ dispatch-case ] 2curry 2curry ; + [ + \ dup , + 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 {