row polymorphism new approach: wrap polymorphic quotation inputs in a "declared-effect" value. M\ declared-effect infer-call* will then assert the effect of declared-effect values during the normal course of stack inference

basis/stack-checker/branches/branches.factor

@@ -91,6 +91,9 @@ M: literal infer-branch
         [ value>> quotation set ] [ infer-literal-quot ] bi
     ] H{ } make-assoc ;
 
+M: declared-effect infer-branch
+    value>> infer-branch ;
+
 M: callable infer-branch
     [
         copy-inference
@@ -107,12 +110,18 @@ M: callable infer-branch
     infer-branches
     [ first2 #if, ] dip compute-phi-function ;
 
+GENERIC: curried/composed? ( known -- ? )
+M: object curried/composed? drop f ;
+M: curried curried/composed? drop t ;
+M: composed curried/composed? drop t ;
+M: declared-effect curried/composed? value>> known curried/composed? ;
+
 : infer-if ( -- )
     2 literals-available? [
         (infer-if)
     ] [
         drop 2 consume-d
-        dup [ known [ curried? ] [ composed? ] bi or ] any? [
+        dup [ known curried/composed? ] any? [
             output-d
             [ rot [ drop call ] [ nip call ] if ]
             infer-quot-here

basis/stack-checker/inlining/inlining.factor

@@ -142,7 +142,7 @@ SYMBOL: enter-out
 : inline-word ( word -- )
     commit-literals
     [ depends-on-definition ]
-    [ infer-polymorphic? get [ check-polymorphic-effect ] [ drop ] if ]
+    [ declare-input-effects ]
     [
         dup inline-recursive-label [
             call-recursive-inline-word

basis/stack-checker/known-words/known-words.factor

@@ -98,6 +98,16 @@ M: composed infer-call*
     1 infer->r infer-call
     terminated? get [ 1 infer-r> infer-call ] unless ;
 
+: Pdeclared-effect ( x -- x )
+    dup
+    [ word>> P. ]
+    [ effect>> P. ]
+    [ value>> known known>callable P. ] tri ;
+
+M: declared-effect infer-call*
+    Pdeclared-effect
+    nip value>> (infer-call) ;
+
 M: input-parameter infer-call* \ call unknown-macro-input ;
 M: object infer-call* \ call bad-macro-input ;
 

basis/stack-checker/row-polymorphism/row-polymorphism-tests.factor

@@ -1,80 +0,0 @@
-! (c)2010 Joe Groff bsd license
-USING: accessors effects fry io kernel make math namespaces sequences
-splitting system tools.test
-stack-checker
-stack-checker.backend
-stack-checker.errors
-stack-checker.row-polymorphism
-stack-checker.state
-stack-checker.values ;
-FROM: splitting.private => split, ;
-IN: stack-checker.row-polymorphism.tests
-
-: infer-polymorphic-quot ( quot -- vars )
-    t infer-polymorphic? [
-        unclip-last [
-            dup current-word set
-            init-inference
-            init-known-values
-            [ [ <literal> <value> [ set-known ] [ push-d ] bi ] each ]
-            [ stack-effect ] bi*
-            infer-polymorphic-vars
-        ] with-scope
-    ] with-variable ;
-
-: test-poly-infer ( effect quot -- )
-    [ '[ _ ] ] [ '[ _ infer-polymorphic-quot ] ] bi* unit-test ; inline
-
-: poly-infer-must-fail ( quot -- )
-    '[ _ infer-polymorphic-quot ] [ invalid-quotation-input? ] must-fail-with ; inline
-: poly-infer-must-fail-unknown ( quot -- )
-    '[ _ infer-polymorphic-quot ] [ unknown-macro-input? ] must-fail-with ; inline
-
-H{ { "." 0 } } [ [ write      ] each ] test-poly-infer
-H{ { "." 1 } } [ [ append     ] each ] test-poly-infer
-H{ { "." 0 } } [ [            ] map  ] test-poly-infer
-H{ { "." 0 } } [ [ reverse    ] map  ] test-poly-infer
-H{ { "." 1 } } [ [ append dup ] map  ] test-poly-infer
-H{ { "." 1 } } [ [ swap nth suffix dup ] map-index ] test-poly-infer
-
-H{ { "a" 3 } { "b" 1 } } [ [ 2drop ] [ 2nip    ] if ] test-poly-infer
-H{ { "a" 2 } { "b" 3 } } [ [ dup   ] [ over    ] if ] test-poly-infer
-H{ { "a" 0 } { "b" 1 } } [ [ os    ] [ cpu     ] if ] test-poly-infer
-H{ { "a" 1 } { "b" 2 } } [ [ os    ] [ 1 + cpu ] if ] test-poly-infer
-
-H{ { "a" 0 } { "b" 0 } } [ [ write     ] [ "(f)" write ] if* ] test-poly-infer
-H{ { "a" 0 } { "b" 1 } } [ [           ] [ f           ] if* ] test-poly-infer
-H{ { "a" 1 } { "b" 1 } } [ [ nip       ] [ drop f      ] if* ] test-poly-infer
-H{ { "a" 1 } { "b" 1 } } [ [ nip       ] [             ] if* ] test-poly-infer
-H{ { "a" 2 } { "b" 2 } } [ [ 3append f ] [             ] if* ] test-poly-infer
-H{ { "a" 0 } { "b" 0 } } [ [ drop      ] [             ] if* ] test-poly-infer
-
-H{ { "a" 0 } { "b" 1 } } [ [ 1 +       ] [ "oops" throw ] if* ] test-poly-infer
-
-H{ } [ [ [ member? ] curry split, ] { } make ] test-poly-infer
-
-[ (( x x -- x )) ] [
-    t infer-polymorphic? [
-        [ [ [ member? ] curry split, ] { } make ] infer
-    ] with-variable
-] unit-test
-
-[ [ write write ] each      ] poly-infer-must-fail
-[ [             ] each      ] poly-infer-must-fail
-[ [ dup         ] map       ] poly-infer-must-fail
-[ [ drop        ] map       ] poly-infer-must-fail
-[ [ 1 +         ] map-index ] poly-infer-must-fail
-
-[ [ dup  ] [      ] if ] poly-infer-must-fail
-[ [ 2dup ] [ over ] if ] poly-infer-must-fail
-[ [ drop ] [      ] if ] poly-infer-must-fail
-
-[ [      ] [       ] if* ] poly-infer-must-fail
-[ [ dup  ] [       ] if* ] poly-infer-must-fail
-[ [ drop ] [ drop  ] if* ] poly-infer-must-fail
-[ [      ] [ drop  ] if* ] poly-infer-must-fail
-[ [      ] [ 2dup  ] if* ] poly-infer-must-fail
-
-[ each ] poly-infer-must-fail-unknown
-[ [ "derp" ] if ] poly-infer-must-fail-unknown
-

basis/stack-checker/row-polymorphism/row-polymorphism.factor

@@ -10,94 +10,26 @@ stack-checker.values
 stack-checker.visitor ;
 IN: stack-checker.row-polymorphism
 
-<PRIVATE
+: ?quotation-effect ( in -- effect/f )
-SYMBOLS: current-effect-variables current-word-effect current-meta-d ;
+    dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
 
-: quotation-effect? ( in -- ? )
+:: declare-effect-d ( word effect variables n -- )
-    dup pair? [ second effect? ] [ drop f ] if ;
+    meta-d length :> d-length
+    n d-length < [
+        d-length 1 - n - :> n'
+        n' meta-d [| value |
+            value word effect variables <declared-effect> :> known'
+            <value> :> value'
+            known' value' set-known
+            value'
+        ] change-nth
+    ] [ word unknown-macro-input ] if ;
 
-SYMBOL: (unknown)
+:: declare-input-effects ( word -- )
+    H{ } clone :> variables
+    word stack-effect in>> <reversed> [| in n |
+        in ?quotation-effect [| effect |
+            word effect variables n declare-effect-d
+        ] when*
+    ] each-index ;
 
-GENERIC: >error-quot ( known -- quot )
-
-M: object >error-quot drop (unknown) ;
-M: literal >error-quot value>> ;
-M: composed >error-quot
-    [ quot1>> known >error-quot ] [ quot2>> known >error-quot ] bi
-    \ compose [ ] 3sequence ;
-M: curried >error-quot
-    [ obj>> known >error-quot ] [ quot>> known >error-quot ] bi
-    \ curry [ ] 3sequence ;
-
-: >error-branches-and-quots ( branch/values -- branches quots )
-    [ [ second ] [ known >error-quot ] bi* ] assoc-map unzip ;
-
-: abandon-check ( -- * )
-    current-word get
-    current-word-effect get in>> current-meta-d get zip
-    [ first quotation-effect? ] filter
-    >error-branches-and-quots
-    invalid-quotation-input ;
-
-:: check-variable ( actual-count declared-count variable -- difference )
-    actual-count declared-count -
-    variable [
-        variable current-effect-variables get at* nip
-        [ variable current-effect-variables get at -     ]
-        [ variable current-effect-variables get set-at 0 ] if
-    ] [
-        dup [ abandon-check ] unless-zero
-    ] if ;
-
-: adjust-variable ( diff var -- )
-    over 0 >=
-    [ current-effect-variables get at+ ]
-    [ 2drop ] if ; inline
-
-:: (check-input) ( declared actual -- )
-    actual terminated?>> [
-        actual declared [ in>>  length ] bi@ declared in-var>>
-            [ check-variable ] keep :> ( in-diff in-var ) 
-        actual declared [ out>> length ] bi@ declared out-var>>
-            [ check-variable ] keep :> ( out-diff out-var )
-        { [ in-var not ] [ out-var not ] [ in-diff out-diff = ] } 0||
-        [
-            in-var  [ in-diff  swap adjust-variable ] when*
-            out-var [ out-diff swap adjust-variable ] when*
-        ] [
-            abandon-check
-        ] if
-    ] unless ;
-
-: infer-value ( value -- effect )
-    dup known [ nest-visitor init-inference infer-call* current-effect ] with-scope ; inline
-
-: check-input ( in value -- )
-    over quotation-effect? [
-        [ second ] dip infer-value (check-input)
-    ] [ 2drop ] if ;
-
-: normalize-variables ( -- variables' )
-    current-effect-variables get dup values [
-        infimum dup 0 <
-        [ '[ _ - ] assoc-map ] [ drop ] if
-    ] unless-empty ;
-
-PRIVATE>
-
-: infer-polymorphic-vars ( effect -- variables )
-    H{ } clone current-effect-variables set
-    dup current-word-effect set
-    in>> dup length ensure-d dup current-meta-d set
-    [ check-input ] 2each
-    normalize-variables ;
-
-: check-polymorphic-effect ( word -- )
-    current-word get [
-        dup current-word set
-        stack-effect dup { [ in-var>> ] [ out-var>> ] } 1||
-        [ infer-polymorphic-vars ] when drop
-    ] dip current-word set ;
-
-SYMBOL: infer-polymorphic?
-infer-polymorphic? [ t ] initialize

basis/stack-checker/stack-checker-tests.factor

@@ -378,7 +378,9 @@ DEFER: eee'
 
 [ [ cond ] infer ] [ T{ unknown-macro-input f cond } = ] must-fail-with
 [ [ bi ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
-[ [ each ] infer ] [ T{ unknown-macro-input f call } = ] must-fail-with
+
+[ [ each ] infer ] [ T{ unknown-macro-input f each } = ] must-fail-with
+[ [ if* ] infer ] [ T{ unknown-macro-input f if* } = ] must-fail-with
 
 [ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
 

basis/stack-checker/values/values.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces kernel assocs sequences
-stack-checker.recursive-state stack-checker.errors ;
+stack-checker.recursive-state stack-checker.errors
+quotations ;
 IN: stack-checker.values
 
 ! Values
@@ -97,9 +98,39 @@ M: input-parameter (literal-value?) drop f ;
 
 M: input-parameter (literal) current-word get unknown-macro-input ;
 
+! Argument corresponding to polymorphic declared input of inline combinator
+
+TUPLE: declared-effect value word effect variables ;
+
+C: <declared-effect> declared-effect
+
+M: declared-effect (input-value?) value>> input-value? ;
+
+M: declared-effect (literal-value?) value>> literal-value? ;
+
+M: declared-effect (literal) value>> literal ;
+
 ! Computed values
 M: f (input-value?) drop f ;
 
 M: f (literal-value?) drop f ;
 
-M: f (literal) current-word get bad-macro-input ;
+M: f (literal) current-word get bad-macro-input ;
+
+SYMBOL: (_)
+ERROR: (@) ;
+
+GENERIC: known>callable ( known -- quot )
+
+: ?@ ( x -- y )
+    dup callable? [ drop [ (@) ] ] unless ;
+
+M: object known>callable drop (_) ;
+M: literal known>callable value>> ;
+M: composed known>callable
+    [ quot1>> known known>callable ?@ ] [ quot2>> known known>callable ?@ ] bi
+    append ;
+M: curried known>callable
+    [ quot>> known known>callable ] [ obj>> known known>callable ] bi
+    prefix ;
+