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
Joe Groff
parent
68dd644233
commit
339cc8f04e
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -10,94 +10,26 @@ stack-checker.values
|
|||
stack-checker.visitor ;
|
||||
IN: stack-checker.row-polymorphism
|
||||
|
||||
<PRIVATE
|
||||
SYMBOLS: current-effect-variables current-word-effect current-meta-d ;
|
||||
: ?quotation-effect ( in -- effect/f )
|
||||
dup pair? [ second dup effect? [ drop f ] unless ] [ drop f ] if ;
|
||||
|
||||
: quotation-effect? ( in -- ? )
|
||||
dup pair? [ second effect? ] [ drop f ] if ;
|
||||
:: declare-effect-d ( word effect variables n -- )
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue