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

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

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
+USING: accessors arrays effects fry generalizations kernel
-kernel macros math.order stack-checker math sequences ;
+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' )
+GENERIC: infer-known* ( known -- effect )
-    dup outputs '[ @ _ ndrop ] ;
 
-MACRO: keep-inputs ( quot -- quot' )
+: infer-known ( value -- effect )
-    dup inputs '[ _ _ nkeep ] ;
+    known dup (literal-value?) [
+        (literal) [ infer-literal-quot ] with-infer drop
+    ] [ infer-known* ] if ;
 
-MACRO: output>sequence ( quot exemplar -- newquot )
+: inputs/outputs ( quot -- in out )
-    [ dup outputs ] dip
+    infer [ in>> ] [ out>> ] bi [ length ] bi@ ;
-    '[ @ _ _ nsequence ] ;
 
-MACRO: output>array ( quot -- newquot )
+: inputs ( quot -- n ) inputs/outputs drop ; inline
-    '[ _ { } output>sequence ] ;
 
-MACRO: input<sequence ( quot -- newquot )
+: outputs ( quot -- n ) inputs/outputs nip ; inline
-    [ inputs ] keep
-    '[ _ firstn @ ] ;
 
-MACRO: input<sequence-unsafe ( quot -- newquot )
+\ inputs/outputs [
-    [ inputs ] keep
+    pop-d
-    '[ _ firstn-unsafe @ ] ;
+    [ 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 )
+: sum-outputs ( quot -- n )
-    '[ _ [ + ] reduce-outputs ] ;
+    [ + ] reduce-outputs ; inline
 
-MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
+: map-outputs ( quot mapper -- )
-    [ dup outputs ] 2dip
+    [ drop call ] [ swap outputs ] 2bi napply ; inline
-    [ 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 ] ;

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
+M: effect curry-effect* curry-effect ;
-    [ in>> length ] [ out>> length ] [ terminated?>> ] tri
-    pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if
-    [ [ "x" <array> ] bi@ ] dip <terminated-effect> ;
 
 M: curry cached-effect
-    quot>> cached-effect curry-effect ;
+    quot>> cached-effect curry-effect* ;
 
 : compose-effects* ( effect1 effect2 -- effect' )
     {

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 -- )
+: ndup ( n -- )
-    dup '[ _ npick ] n*quot ;
+    [ '[ _ 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 -- )
+: ndrop ( n -- )
-    [ drop ] n*quot ;
+    [ drop ] swap quot*n ; inline
 
-MACRO: nnip ( n -- )
+: nnip ( n -- )
-    '[ [ _ ndrop ] dip ] ;
+    '[ _ ndrop ] dip ; inline
 
-MACRO: ndip ( n -- )
+: ndip ( n -- )
-    [ [ dip ] curry ] n*quot [ call ] compose ;
+    [ [ dip ] curry ] swap quot*n call ; inline
 
-MACRO: nkeep ( n -- )
+: nkeep ( n -- )
-    dup '[ [ _ ndup ] dip _ ndip ] ;
+    dup '[ [ _ ndup ] dip _ ndip ] call ; inline
 
-MACRO: ncurry ( n -- )
+: ncurry ( n -- )
-    [ curry ] n*quot ;
+    [ curry ] swap quot*n ; inline
 
-MACRO: nwith ( n -- )
+: nwith ( n -- )
-    [ with ] n*quot ;
+    [ with ] swap quot*n ; inline
 
 MACRO: nbi ( n -- )
     '[ [ _ nkeep ] dip call ] ;

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

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

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

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 ;

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

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