diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 8e3b59fe69..8e61e39faf 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -2,7 +2,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 math.functions -definitions compiler.units fry lexer words.symbol see ; +definitions compiler.units fry lexer words.symbol see multiline ; IN: locals.tests :: foo ( a b -- a a ) a a ; @@ -392,6 +392,65 @@ ERROR: punned-class x ; [ 9 ] [ 3 big-case-test ] unit-test +! Dan found this problem +: littledan-case-problem-1 ( a -- b ) + { + { t [ 3 ] } + { f [ 4 ] } + [| x | x 12 + { "howdy" } nth ] + } case ; + +\ littledan-case-problem-1 must-infer + +[ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test +[ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test + +:: littledan-case-problem-2 ( a -- b ) + a { + { t [ a not ] } + { f [ 4 ] } + [| x | x a - { "howdy" } nth ] + } case ; + +\ littledan-case-problem-2 must-infer + +[ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test +[ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test + +:: littledan-cond-problem-1 ( a -- b ) + a { + { [ dup 0 < ] [ drop a not ] } + { [| y | y y 0 > ] [ drop 4 ] } + [| x | x a - { "howdy" } nth ] + } cond ; + +\ littledan-cond-problem-1 must-infer + +[ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test +[ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test +[ "howdy" ] [ 0 \ littledan-cond-problem-1 def>> call ] unit-test +[ f ] [ -12 littledan-cond-problem-1 ] unit-test +[ 4 ] [ 12 littledan-cond-problem-1 ] unit-test +[ "howdy" ] [ 0 littledan-cond-problem-1 ] unit-test + +/* +:: littledan-case-problem-3 ( a quot -- b ) + a { + { t [ a not ] } + { f [ 4 ] } + quot + } case ; inline + +[ f ] [ t [ ] littledan-case-problem-3 ] unit-test +[ 144 ] [ 12 [ sq ] littledan-case-problem-3 ] unit-test +[| | [| a | a ] littledan-case-problem-3 ] must-infer + +: littledan-case-problem-4 ( a -- b ) + [ 1 + ] littledan-case-problem-3 ; + +\ littledan-case-problem-4 must-infer +*/ + GENERIC: lambda-method-forget-test ( a -- b ) M:: integer lambda-method-forget-test ( a -- b ) ; diff --git a/basis/locals/macros/macros.factor b/basis/locals/macros/macros.factor index 7bde67a792..2b52c53eb5 100644 --- a/basis/locals/macros/macros.factor +++ b/basis/locals/macros/macros.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel locals.types macros.expander ; +USING: accessors assocs kernel locals.types macros.expander fry ; IN: locals.macros M: lambda expand-macros clone [ expand-macros ] change-body ; @@ -14,3 +14,6 @@ M: binding-form expand-macros M: binding-form expand-macros* expand-macros literal ; +M: lambda condomize? drop t ; + +M: lambda condomize '[ @ ] ; \ No newline at end of file diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index cdd2b49d9c..25f754e92a 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private namespaces make quotations accessors words continuations vectors effects math -generalizations fry ; +generalizations fry arrays ; IN: macros.expander GENERIC: expand-macros ( quot -- quot' ) @@ -17,7 +17,23 @@ SYMBOL: stack [ delete-all ] bi ; -: literal ( obj -- ) stack get push ; +GENERIC: condomize? ( obj -- ? ) + +M: array condomize? [ condomize? ] any? ; + +M: callable condomize? [ condomize? ] any? ; + +M: object condomize? drop f ; + +GENERIC: condomize ( obj -- obj' ) + +M: array condomize [ condomize ] map ; + +M: callable condomize [ condomize ] map ; + +M: object condomize ; + +: literal ( obj -- ) dup condomize? [ condomize ] when stack get push ; GENERIC: expand-macros* ( obj -- )