generalizations: Refactor stack-checker so that smart combinators can be used with...

diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor
index 8933c4bb39f1545572fa1ebedc316ab261423cee..a322b7bd0b7e39463518b4a2fccd148d508a231b 100644 (file)
--- a/basis/combinators/smart/smart-tests.factor
+++ b/basis/combinators/smart/smart-tests.factor
@@ -76,3 +76,5 @@ IN: combinators.smart.tests
 
 [ -1 ] [ 1 2 [ + odd? ] [ - ] smart-when* ] unit-test
 [ ] [ 2 2 [ + odd? ] [ ] smart-unless* ] unit-test
+
+! [ [ ] [ call ] curry output>array ] infer

diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor
index a350d0a72b80f6544763ac88c57edf72fc1e4cfd..efdb1b9e05504dc04df8f3e40a66387452ea13e6 100644 (file)
--- a/basis/combinators/smart/smart.factor
+++ b/basis/combinators/smart/smart.factor
@@ -1,41 +1,74 @@
-! Copyright (C) 2009 Doug Coleman.
+! Copyright (C) 2009, 2011 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors fry generalizations sequences.generalizations
-kernel macros math.order stack-checker math sequences ;
+USING: accessors arrays effects fry generalizations kernel
+macros math math.order sequences sequences.generalizations
+stack-checker stack-checker.backend stack-checker.errors
+stack-checker.values stack-checker.visitor words ;
 IN: combinators.smart
 
-MACRO: drop-outputs ( quot -- quot' )
-    dup outputs '[ @ _ ndrop ] ;
+GENERIC: infer-known* ( known -- effect )
 
-MACRO: keep-inputs ( quot -- quot' )
-    dup inputs '[ _ _ nkeep ] ;
+: infer-known ( value -- effect )
+    known dup (literal-value?) [
+        (literal) [ infer-literal-quot ] with-infer drop
+    ] [ infer-known* ] if ;
 
-MACRO: output>sequence ( quot exemplar -- newquot )
-    [ dup outputs ] dip
-    '[ @ _ _ nsequence ] ;
+: inputs/outputs ( quot -- in out )
+    infer [ in>> ] [ out>> ] bi [ length ] bi@ ;
 
-MACRO: output>array ( quot -- newquot )
-    '[ _ { } output>sequence ] ;
+: inputs ( quot -- n ) inputs/outputs drop ; inline
 
-MACRO: input<sequence ( quot -- newquot )
-    [ inputs ] keep
-    '[ _ firstn @ ] ;
+: outputs ( quot -- n ) inputs/outputs nip ; inline
 
-MACRO: input<sequence-unsafe ( quot -- newquot )
-    [ inputs ] keep
-    '[ _ firstn-unsafe @ ] ;
+\ inputs/outputs [
+    pop-d
+    [ 1array #drop, ] [ infer-known ] bi
+    [ in>> ] [ out>> ] bi [ length apply-object ] bi@
+] "special" set-word-prop
+
+M: curried infer-known*
+    quot>> infer-known curry-effect ;
+
+M: composed infer-known*
+    [ quot1>> ] [ quot2>> ] bi
+    [ infer-known ] bi@ compose-effects ;
+
+M: declared-effect infer-known*
+    known>> infer-known* ;
+
+M: input-parameter infer-known* \ inputs/outputs unknown-macro-input ;
+
+M: object infer-known* \ inputs/outputs bad-macro-input ;
+
+: drop-outputs ( quot -- )
+    [ call ] [ outputs ndrop ] bi ; inline
+
+: keep-inputs ( quot -- )
+    [ ] [ inputs ] bi nkeep ; inline
+
+: output>sequence ( quot exemplar -- )
+    [ [ call ] [ outputs ] bi ] dip nsequence ; inline
+
+: output>array ( quot -- )
+    { } output>sequence ; inline
+
+: input<sequence ( seq quot -- )
+    [ inputs firstn ] [ call ] bi ; inline
+
+: input<sequence-unsafe ( seq quot -- )
+    [ inputs firstn-unsafe ] [ call ] bi ; inline
 
 MACRO: reduce-outputs ( quot operation -- newquot )
     [ dup outputs 1 [-] ] dip n*quot compose ;
 
-MACRO: sum-outputs ( quot -- n )
-    '[ _ [ + ] reduce-outputs ] ;
+: sum-outputs ( quot -- n )
+    [ + ] reduce-outputs ; inline
+
+: map-outputs ( quot mapper -- )
+    [ drop call ] [ swap outputs ] 2bi napply ; inline
 
-MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
-    [ dup outputs ] 2dip
-    [ swap '[ _ _ napply ] ]
-    [ [ 1 [-] ] dip n*quot ] bi-curry* bi
-    '[ @ @ @ ] ;
+: map-reduce-outputs ( quot mapper reducer -- )
+    [ '[ _ _ map-outputs ] ] dip reduce-outputs ; inline
 
 MACRO: append-outputs-as ( quot exemplar -- newquot )
     [ dup outputs ] dip '[ @ _ _ nappend-as ] ;

diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor
index dee4605a3529a7acb663d4c9eb0728cb89fea78a..ab1a77b70d415a74c5b2f2b3b68476f7493c3840 100644 (file)
--- a/basis/compiler/tree/propagation/call-effect/call-effect.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor
@@ -41,17 +41,14 @@ GENERIC: cached-effect ( quot -- effect )
 
 M: object cached-effect drop +unknown+ ;
 
-GENERIC: curry-effect ( effect -- effect' )
+GENERIC: curry-effect* ( effect -- effect' )
 
-M: +unknown+ curry-effect ;
+M: +unknown+ curry-effect* ;
 
-M: effect curry-effect
-    [ in>> length ] [ out>> length ] [ terminated?>> ] tri
-    pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
-    [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
+M: effect curry-effect* curry-effect ;
 
 M: curry cached-effect
-    quot>> cached-effect curry-effect ;
+    quot>> cached-effect curry-effect* ;
 
 : compose-effects* ( effect1 effect2 -- effect' )
     {

diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index 2c6a9f1a21854e955b6f26d4b60c5da0d17b979c..99d57eded8f2e38dd6ff1622fac83ab059f8440e 100644 (file)
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -10,6 +10,9 @@ IN: generalizations
 
 ALIAS: n*quot (n*quot)
 
+MACRO: quot*n ( n -- )
+    [ call ] <repetition> '[ _ cleave ] ;
+
 : repeat ( n obj quot -- ) swapd times ; inline
 
 >>
@@ -23,8 +26,8 @@ MACRO: npick ( n -- )
 MACRO: nover ( n -- )
     dup 1 + '[ _ npick ] n*quot ;
 
-MACRO: ndup ( n -- )
-    dup '[ _ npick ] n*quot ;
+: ndup ( n -- )
+    [ '[ _ npick ] ] keep quot*n ; inline
 
 MACRO: dupn ( n -- )
     [ [ drop ] ]
@@ -36,23 +39,23 @@ MACRO: nrot ( n -- )
 MACRO: -nrot ( n -- )
     1 - [ ] [ '[ swap _ dip ] ] repeat ;
 
-MACRO: ndrop ( n -- )
-    [ drop ] n*quot ;
+: ndrop ( n -- )
+    [ drop ] swap quot*n ; inline
 
-MACRO: nnip ( n -- )
-    '[ [ _ ndrop ] dip ] ;
+: nnip ( n -- )
+    '[ _ ndrop ] dip ; inline
 
-MACRO: ndip ( n -- )
-    [ [ dip ] curry ] n*quot [ call ] compose ;
+: ndip ( n -- )
+    [ [ dip ] curry ] swap quot*n call ; inline
 
-MACRO: nkeep ( n -- )
-    dup '[ [ _ ndup ] dip _ ndip ] ;
+: nkeep ( n -- )
+    dup '[ [ _ ndup ] dip _ ndip ] call ; inline
 
-MACRO: ncurry ( n -- )
-    [ curry ] n*quot ;
+: ncurry ( n -- )
+    [ curry ] swap quot*n ; inline
 
-MACRO: nwith ( n -- )
-    [ with ] n*quot ;
+: nwith ( n -- )
+    [ with ] swap quot*n ; inline
 
 MACRO: nbi ( n -- )
     '[ [ _ nkeep ] dip call ] ;

diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
index b340d5ebacc54f3f43e03a1b0d39e828b713742d..a39bc658ea3f6377cfa1901e56e883a7f66624c3 100644 (file)
--- a/basis/locals/locals-tests.factor
+++ b/basis/locals/locals-tests.factor
@@ -2,7 +2,8 @@ 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 multiline ;
+definitions compiler.units fry lexer words.symbol see multiline
+combinators.smart ;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -491,3 +492,8 @@ M: integer ed's-bug neg ;
 
 ! multiple bind
 [ 3 1 2 ] [ [let 1 2 3 :> ( a b c ) c a b ] ] unit-test
+
+! Test smart combinators and locals interaction
+:: smart-combinator-locals ( a b c -- seq ) [ a b c ] output>array ;
+
+[ { 1 2 3 } ] [ 1 2 3 smart-combinator-locals ] unit-test

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 43885afc3fdc44bb3263223a8ea2fe93f2240778..99a5e7ace8432775d0a68449a35b13b8119c324c 100644 (file)
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -40,6 +40,7 @@ IN: stack-checker.known-words
 : infer-shuffle-word ( word -- )
     "shuffle" word-prop infer-shuffle ;
 
+! This is a hack for combinators combinators.short-circuit.smart.
 : infer-local-reader ( word -- )
     ( -- value ) apply-word/effect ;
 
@@ -89,6 +90,7 @@ IN: stack-checker.known-words
 
 \ declare [ infer-declare ] "special" set-word-prop
 
+! Call
 GENERIC: infer-call* ( value known -- )
 
 : (infer-call) ( value -- ) dup known infer-call* ;

diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index d56e70251770a16a15be4f243fa4c28fab78019a..a050a259f645da6859e73f527d4d870ce941cccc 100644 (file)
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -529,3 +529,13 @@ USING: alien.c-types alien ;
 [ [ drop drop ] [ f f f ] poly-input-output ] must-infer
 [ [ drop drop drop ] [ f f ] poly-input-output ] must-infer
 
+! Check that 'inputs' and 'outputs' work at compile-time
+
+: inputs-test0 ( -- n )
+    [ 5 + ] inputs ;
+
+: inputs-test1 ( x -- n )
+    [ + ] curry inputs ;
+
+[ 1 ] [ inputs-test0 ] unit-test
+[ 1 ] [ 10 inputs-test1 ] unit-test

diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor
index beb5026a2ba8af94032d0caac64843892e58e860..9c016f037a2f69393db58811ddb4c9b3a026451f 100644 (file)
--- a/basis/stack-checker/stack-checker.factor
+++ b/basis/stack-checker/stack-checker.factor
@@ -16,7 +16,3 @@ M: callable infer ( quot -- effect )
 : infer. ( quot -- )
     #! Safe to call from inference transforms.
     infer effect>string print ;
-
-: inputs ( quot -- n ) infer in>> length ;
-
-: outputs ( quot -- n ) infer out>> length ;

diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor
index 5f4a299ac84c6d154dfbffc99f273e162c85e15f..890bbb7e4e0529691073a6adc97c869dc92828a9 100644 (file)
--- a/core/effects/effects-tests.factor
+++ b/core/effects/effects-tests.factor
@@ -49,3 +49,8 @@ IN: effects.tests
 
 [ "( ..a: integer b c -- d )" eval( -- effect ) ]
 [ error>> row-variable-can't-have-type? ] must-fail-with
+
+! test curry-effect
+[ ( -- x ) ] [ ( c -- d ) curry-effect ] unit-test
+[ ( -- x x ) ] [ ( -- d ) curry-effect ] unit-test
+[ ( x -- ) ] [ ( a b -- ) curry-effect ] unit-test

diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index ffc59e21a1de29b6f4ce8687d7eb84342a0a3dd2..785a5d21f2ee102a94a4e5f01d7359776dcbd2a1 100644 (file)
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -120,3 +120,8 @@ M: effect clone
         [ [ "x" <array> ] bi@ ] dip
         <terminated-effect>
     ] if ; inline
+
+: curry-effect ( effect -- effect' )
+    [ in>> length ] [ out>> length ] [ terminated?>> ] tri
+    pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
+    [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;