129 lines
2.9 KiB
Factor
129 lines
2.9 KiB
Factor
! Copyright (C) 2004, 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
IN: inference
|
|
USING: arrays errors generic io kernel
|
|
math namespaces parser prettyprint sequences strings
|
|
vectors words ;
|
|
|
|
TUPLE: inference-error rstate major? ;
|
|
|
|
C: inference-error ( msg rstate important? -- error )
|
|
[ set-inference-error-major? ] keep
|
|
[ set-inference-error-rstate ] keep
|
|
[ set-delegate ] keep ;
|
|
|
|
: inference-error ( msg -- * )
|
|
recursive-state get t <inference-error> throw ;
|
|
|
|
: inference-warning ( msg -- * )
|
|
recursive-state get f <inference-error> throw ;
|
|
|
|
TUPLE: literal-expected ;
|
|
|
|
M: object value-literal
|
|
<literal-expected> inference-warning ;
|
|
|
|
: pop-literal ( -- rstate obj )
|
|
1 #drop node,
|
|
pop-d dup value-recursion swap value-literal ;
|
|
|
|
: value-vector ( n -- vector ) [ drop <computed> ] map >vector ;
|
|
|
|
: add-inputs ( n stack -- n stack )
|
|
tuck length - dup 0 >
|
|
[ dup value-vector [ rot nappend ] keep ]
|
|
[ drop 0 swap ] if ;
|
|
|
|
: ensure-values ( n -- )
|
|
meta-d [ add-inputs ] change d-in [ + ] change ;
|
|
|
|
: short-effect ( -- pair )
|
|
d-in get meta-d get length 2array ;
|
|
|
|
SYMBOL: terminated?
|
|
|
|
: current-effect ( -- effect )
|
|
d-in get meta-d get length <effect>
|
|
terminated? get over set-effect-terminated? ;
|
|
|
|
SYMBOL: recorded
|
|
|
|
: init-inference ( recursive-state -- )
|
|
terminated? off
|
|
V{ } clone meta-r set
|
|
V{ } clone meta-d set
|
|
0 d-in set
|
|
recursive-state set
|
|
dataflow-graph off
|
|
current-node off ;
|
|
|
|
GENERIC: apply-object
|
|
|
|
: apply-literal ( obj -- )
|
|
#push dup node,
|
|
swap <value> push-d
|
|
1 d-tail swap set-node-out-d ;
|
|
|
|
M: object apply-object apply-literal ;
|
|
|
|
M: wrapper apply-object wrapped apply-literal ;
|
|
|
|
: terminate ( -- )
|
|
terminated? on #terminate node, ;
|
|
|
|
GENERIC: infer-quot ( quot -- )
|
|
|
|
M: f infer-quot drop ;
|
|
|
|
M: quotation infer-quot
|
|
[ apply-object terminated? get not ] all? drop ;
|
|
|
|
: infer-quot-value ( rstate quot -- )
|
|
recursive-state get >r swap recursive-state set
|
|
infer-quot r> recursive-state set ;
|
|
|
|
TUPLE: too-many->r ;
|
|
|
|
: check->r ( -- )
|
|
meta-r get empty? [
|
|
<too-many->r> inference-error
|
|
] unless ;
|
|
|
|
TUPLE: too-many-r> ;
|
|
|
|
: check-r> ( -- )
|
|
meta-r get empty? [
|
|
<too-many-r>> inference-error
|
|
] when ;
|
|
|
|
: undo-infer ( -- )
|
|
recorded get
|
|
[ "infer" word-prop not ] subset
|
|
[ f "infer-effect" set-word-prop ] each ;
|
|
|
|
: with-infer ( quot -- )
|
|
[
|
|
[
|
|
{ } recursive-state set
|
|
V{ } clone recorded set
|
|
f init-inference
|
|
call
|
|
check->r
|
|
] [
|
|
undo-infer
|
|
rethrow
|
|
] recover
|
|
] with-scope ;
|
|
|
|
: infer ( quot -- effect )
|
|
[ infer-quot short-effect ] with-infer ;
|
|
|
|
: (dataflow) ( quot -- dataflow )
|
|
infer-quot f #return node, dataflow-graph get ;
|
|
|
|
: dataflow ( quot -- dataflow )
|
|
[ (dataflow) ] with-infer ;
|
|
|
|
: dataflow-with ( quot stack -- effect )
|
|
[ meta-d set (dataflow) ] with-infer ;
|