Condomization wraps lambdas in condoms to protect them from macro-transmitted diseases. cond, case and other macros work better now if lambdas appear where quotations are expected

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 ) ;

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 '[ @ ] ;

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 -- )