combinators.smart: Enable a unit test, handle M: object infer-known*, make sum-output...

Fixes inverse but still needs work, once I figure out how.

diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor
index a322b7bd0b7e39463518b4a2fccd148d508a231b..fde17fb81d73867c2371021c01a4c3d04f9725e8 100644 (file)
--- a/basis/combinators/smart/smart-tests.factor
+++ b/basis/combinators/smart/smart-tests.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators.smart kernel math
-tools.test ;
+stack-checker tools.test ;
 IN: combinators.smart.tests
 
 : test-bi ( -- 9 11 )
@@ -77,4 +77,4 @@ IN: combinators.smart.tests
 [ -1 ] [ 1 2 [ + odd? ] [ - ] smart-when* ] unit-test
 [ ] [ 2 2 [ + odd? ] [ ] smart-unless* ] unit-test
 
-! [ [ ] [ call ] curry output>array ] infer
+[ ( -- x ) ] [ [ [ ] [ call ] curry output>array ] infer ] unit-test

diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor
index 9f837fd48cc1d553e5725bec60dc8787ff8ad0ab..cacc335d08e74e4c69ea14c146c053bb4fb0204b 100644 (file)
--- a/basis/combinators/smart/smart.factor
+++ b/basis/combinators/smart/smart.factor
@@ -21,11 +21,17 @@ GENERIC: infer-known* ( known -- effect )
 : outputs ( quot -- n ) inputs/outputs nip ; inline
 
 \ inputs/outputs [
-    pop-d
-    [ 1array #drop, ] [ infer-known ] bi
-    [ in>> ] [ out>> ] bi [ length apply-object ] bi@
+    peek-d
+    infer-known [
+        [ pop-d 1array #drop, ]
+        [ [ in>> ] [ out>> ] bi [ length apply-object ] bi@ ] bi*
+    ] [
+        \ inputs/outputs dup required-stack-effect apply-word/effect
+    ] if*
 ] "special" set-word-prop
 
+! TODO: Handle the case where a nested call to infer-known returns f
+
 M: curried infer-known*
     quot>> infer-known curry-effect ;
 
@@ -38,7 +44,7 @@ M: declared-effect infer-known*
 
 M: input-parameter infer-known* \ inputs/outputs unknown-macro-input ;
 
-M: object infer-known* \ inputs/outputs bad-macro-input ;
+M: object infer-known* drop f ;
 
 : drop-inputs ( quot -- newquot )
     inputs ndrop ; inline
@@ -64,8 +70,8 @@ M: object infer-known* \ inputs/outputs bad-macro-input ;
 MACRO: reduce-outputs ( quot operation -- newquot )
     [ [ ] [ outputs 1 [-] ] bi ] dip swap '[ @ _ _ call-n ] ;
 
-: sum-outputs ( quot -- n )
-    [ + ] reduce-outputs ; inline
+MACRO: sum-outputs ( quot -- n )
+    '[ _ [ + ] reduce-outputs ] ;
 
 : map-outputs ( quot mapper -- )
     [ drop call ] [ swap outputs ] 2bi napply ; inline