Dynamic scope inference
slava
parent
28050349c5
commit
fc8a1e5160
|
|
@ -1,6 +1,5 @@
|
|||
+ 0.87:
|
||||
|
||||
- cocoa: move window while factor is busy: mouse gets messed up!
|
||||
- live search: timer delay would be nice
|
||||
- menu should stay up if mouse button released
|
||||
- roundoff is still not quite right with tracks
|
||||
|
|
@ -19,7 +18,6 @@
|
|||
- intrinsic fixnum>float float>fixnum
|
||||
- mac intel: struct returns from objc methods
|
||||
- faster apropos
|
||||
- infer which variables are read, written in a quotation
|
||||
- compiled call traces
|
||||
|
||||
+ ui:
|
||||
|
|
|
|||
|
|
@ -7,7 +7,6 @@ optimizer parser sequences sequences-internals words ;
|
|||
[
|
||||
print-warnings off
|
||||
|
||||
[
|
||||
! Wrap everything in a catch which starts a listener so
|
||||
! you can see what went wrong, instead of dealing with a
|
||||
! fep
|
||||
|
|
@ -72,7 +71,6 @@ optimizer parser sequences sequences-internals words ;
|
|||
H{ } clone parent-graph set-global xref-help
|
||||
H{ } clone term-index set-global index-help
|
||||
] when
|
||||
] no-parse-hook
|
||||
|
||||
run-bootstrap-init
|
||||
|
||||
|
|
@ -83,6 +81,10 @@ optimizer parser sequences sequences-internals words ;
|
|||
0 exit
|
||||
] set-boot
|
||||
|
||||
"compile" get [
|
||||
[ recompile ] parse-hook set-global
|
||||
] when
|
||||
|
||||
f error set-global
|
||||
f error-continuation set-global
|
||||
|
||||
|
|
|
|||
|
|
@ -69,6 +69,7 @@ SYMBOL: architecture
|
|||
|
||||
: emit-object ( header tag quot -- addr )
|
||||
swap here-as >r swap tag-header emit call align-here r> ;
|
||||
inline
|
||||
|
||||
! Image header
|
||||
|
||||
|
|
@ -224,7 +225,7 @@ M: string '
|
|||
: emit-array ( list type -- pointer )
|
||||
>r [ ' ] map r> object-tag [
|
||||
dup length emit-fixnum
|
||||
( elements -- ) emit-seq
|
||||
emit-seq
|
||||
] emit-object ;
|
||||
|
||||
: transfer-tuple ( tuple -- tuple )
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ M: alien-callback-error summary
|
|||
alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
|
||||
|
||||
\ alien-callback [ string object quotation ] [ alien ] <effect>
|
||||
"infer-effect" set-word-prop
|
||||
"inferred-effect" set-word-prop
|
||||
|
||||
\ alien-callback [
|
||||
empty-node <alien-callback> dup node,
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ M: alien-indirect-error summary
|
|||
drop "Words calling ``alien-indirect'' cannot run in the interpreter. Compile the caller word and try again." ;
|
||||
|
||||
\ alien-indirect [ string object string ] [ ] <effect>
|
||||
"infer-effect" set-word-prop
|
||||
"inferred-effect" set-word-prop
|
||||
|
||||
\ alien-indirect [
|
||||
empty-node <alien-indirect>
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ TUPLE: alien-invoke library function return parameters ;
|
|||
C: alien-invoke make-node ;
|
||||
|
||||
: alien-invoke-stack ( node -- )
|
||||
dup alien-invoke-parameters length over consume-values
|
||||
dup alien-invoke-parameters over consume-values
|
||||
dup alien-invoke-return "void" = 0 1 ? swap produce-values ;
|
||||
|
||||
: alien-invoke-dlsym ( node -- symbol dll )
|
||||
|
|
@ -29,7 +29,7 @@ M: alien-invoke-error summary
|
|||
[ inference-warning ] recover ;
|
||||
|
||||
\ alien-invoke [ string object string object ] [ ] <effect>
|
||||
"infer-effect" set-word-prop
|
||||
"inferred-effect" set-word-prop
|
||||
|
||||
\ alien-invoke [
|
||||
empty-node <alien-invoke>
|
||||
|
|
|
|||
|
|
@ -121,7 +121,7 @@ H{ } clone objc-methods set-global
|
|||
\ (send) [ pop-literal nip infer-send ] "infer" set-word-prop
|
||||
|
||||
\ (send) [ object object ] [ ] <effect>
|
||||
"infer-effect" set-word-prop
|
||||
"inferred-effect" set-word-prop
|
||||
|
||||
: send ( ... selector -- ... ) f (send) ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -32,10 +32,10 @@ M: f batch-ends drop ;
|
|||
|
||||
: word-dataflow ( word -- dataflow )
|
||||
[
|
||||
dup ?no-effect
|
||||
dup "no-effect" word-prop [ no-effect ] when
|
||||
dup dup add-recursive-state
|
||||
dup specialized-def (dataflow)
|
||||
swap current-effect check-effect
|
||||
[ specialized-def (dataflow) ] keep
|
||||
finish-word 2drop
|
||||
] with-infer ;
|
||||
|
||||
: (compile) ( word -- )
|
||||
|
|
@ -50,11 +50,8 @@ M: f batch-ends drop ;
|
|||
[ (compile) ] with-compiler ;
|
||||
|
||||
: try-compile ( word -- )
|
||||
[
|
||||
compile
|
||||
] [
|
||||
batch-errors get compile-error update-xt
|
||||
] recover ;
|
||||
[ compile ]
|
||||
[ batch-errors get compile-error update-xt ] recover ;
|
||||
|
||||
: compile-batch ( seq -- )
|
||||
batch-errors get batch-begins
|
||||
|
|
@ -78,5 +75,3 @@ M: f batch-ends drop ;
|
|||
changed-words get [
|
||||
dup hash-keys compile-batch clear-hash
|
||||
] when* ;
|
||||
|
||||
[ recompile ] parse-hook set
|
||||
|
|
|
|||
|
|
@ -55,16 +55,41 @@ TUPLE: unbalanced-branches-error in out ;
|
|||
swap meta-r active-variable
|
||||
unify-effect meta-r set drop ;
|
||||
|
||||
TUPLE: unbalanced-namestacks ;
|
||||
|
||||
: unify-namestacks ( seq -- )
|
||||
flip
|
||||
[ H{ } clone [ dupd hash-update ] reduce ] map
|
||||
meta-n set ;
|
||||
|
||||
: namestack-effect ( seq -- )
|
||||
#! If the namestack is unbalanced, we don't throw an error
|
||||
meta-n active-variable
|
||||
dup [ length ] map all-equal? [
|
||||
<unbalanced-namestacks> inference-error
|
||||
] unless
|
||||
unify-namestacks ;
|
||||
|
||||
: unify-vars ( seq -- )
|
||||
#! Don't use active-variable here, because we want to
|
||||
#! consider variables set right before a throw too
|
||||
[ inferred-vars swap hash ] map apply-var-seq ;
|
||||
|
||||
: unify-effects ( seq -- )
|
||||
dup datastack-effect dup callstack-effect
|
||||
dup datastack-effect
|
||||
dup callstack-effect
|
||||
dup namestack-effect
|
||||
dup unify-vars
|
||||
[ terminated? swap hash ] all? terminated? set ;
|
||||
|
||||
: unify-dataflow ( effects -- nodes )
|
||||
[ dataflow-graph swap hash ] map ;
|
||||
|
||||
: copy-inference ( -- )
|
||||
meta-r [ clone ] change
|
||||
meta-d [ clone ] change
|
||||
meta-r [ clone ] change
|
||||
meta-n [ [ clone ] map ] change
|
||||
inferred-vars [ clone ] change
|
||||
d-in [ ] change
|
||||
dataflow-graph off
|
||||
current-node off ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: inference
|
||||
USING: arrays generic hashtables kernel math
|
||||
namespaces parser sequences words ;
|
||||
namespaces parser sequences words vectors ;
|
||||
|
||||
SYMBOL: d-in
|
||||
SYMBOL: meta-d
|
||||
|
|
|
|||
|
|
@ -28,6 +28,10 @@ M: too-many-r> summary
|
|||
drop
|
||||
"Quotation pops retain stack elements which it did not push" ;
|
||||
|
||||
M: too-many-n> summary
|
||||
drop
|
||||
"Quotation pops name stack elements which it did not push" ;
|
||||
|
||||
M: no-effect error.
|
||||
"The word " write
|
||||
no-effect-word pprint
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
IN: inference
|
||||
USING: arrays errors generic io kernel
|
||||
math namespaces parser prettyprint sequences strings
|
||||
vectors words ;
|
||||
vectors words tools ;
|
||||
|
||||
TUPLE: inference-error rstate major? ;
|
||||
|
||||
|
|
@ -29,17 +29,14 @@ M: object value-literal
|
|||
|
||||
: value-vector ( n -- vector ) [ drop <computed> ] map >vector ;
|
||||
|
||||
: add-inputs ( n stack -- n stack )
|
||||
tuck length - dup 0 >
|
||||
: add-inputs ( seq stack -- n stack )
|
||||
tuck [ length ] 2apply - dup 0 >
|
||||
[ dup value-vector [ rot nappend ] keep ]
|
||||
[ drop 0 swap ] if ;
|
||||
|
||||
: ensure-values ( n -- )
|
||||
: ensure-values ( seq -- )
|
||||
meta-d [ add-inputs ] change d-in [ + ] change ;
|
||||
|
||||
: short-effect ( -- pair )
|
||||
d-in get meta-d get length 2array ;
|
||||
|
||||
SYMBOL: terminated?
|
||||
|
||||
: current-effect ( -- effect )
|
||||
|
|
@ -50,8 +47,10 @@ SYMBOL: recorded
|
|||
|
||||
: init-inference ( recursive-state -- )
|
||||
terminated? off
|
||||
V{ } clone meta-r set
|
||||
V{ } clone meta-d set
|
||||
V{ } clone meta-r set
|
||||
V{ } clone meta-n set
|
||||
empty-vars inferred-vars set
|
||||
0 d-in set
|
||||
recursive-state set
|
||||
dataflow-graph off
|
||||
|
|
@ -97,9 +96,11 @@ TUPLE: too-many-r> ;
|
|||
] when ;
|
||||
|
||||
: undo-infer ( -- )
|
||||
recorded get
|
||||
[ "infer" word-prop not ] subset
|
||||
[ f "infer-effect" set-word-prop ] each ;
|
||||
recorded get [ "infer" word-prop not ] subset [
|
||||
dup
|
||||
f "inferred-vars" set-word-prop
|
||||
f "inferred-effect" set-word-prop
|
||||
] each ;
|
||||
|
||||
: with-infer ( quot -- )
|
||||
[
|
||||
|
|
@ -115,8 +116,19 @@ TUPLE: too-many-r> ;
|
|||
] recover
|
||||
] with-scope ;
|
||||
|
||||
: infer ( quot -- effect )
|
||||
[ infer-quot short-effect ] with-infer ;
|
||||
: infer ( quot -- effect infer-vars )
|
||||
[ infer-quot inferred-vars get current-effect ] with-infer ;
|
||||
|
||||
: vars. ( seq str -- )
|
||||
over empty? [ 2drop ] [ print [ . ] each ] if ;
|
||||
|
||||
: infer. ( quot -- )
|
||||
infer
|
||||
"* Stack effect:" print effect>string print
|
||||
dup inferred-vars-reads "* Reads free variables:" vars.
|
||||
dup inferred-vars-writes "* Writes free variables:" vars.
|
||||
dup inferred-vars-reads-globals "* Reads global variables:" vars.
|
||||
inferred-vars-writes-globals "* Writes global variables:" vars. ;
|
||||
|
||||
: (dataflow) ( quot -- dataflow )
|
||||
infer-quot f #return node, dataflow-graph get ;
|
||||
|
|
|
|||
|
|
@ -1,60 +1,62 @@
|
|||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: inference
|
||||
USING: arrays alien assembler errors generic hashtables
|
||||
hashtables-internals io io-internals kernel
|
||||
kernel-internals math math-internals memory parser
|
||||
sequences strings vectors words prettyprint ;
|
||||
sequences strings vectors words prettyprint namespaces ;
|
||||
|
||||
\ declare [
|
||||
pop-literal nip
|
||||
dup length ensure-values
|
||||
dup ensure-values
|
||||
dup length d-tail
|
||||
swap #declare
|
||||
[ 2dup set-node-in-d set-node-out-d ] keep
|
||||
node,
|
||||
] "infer" set-word-prop
|
||||
\ declare { object } { } <effect> "infer-effect" set-word-prop
|
||||
\ declare { object } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ fixnum< { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum< { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum< t "foldable" set-word-prop
|
||||
|
||||
\ fixnum<= { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum<= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum<= t "foldable" set-word-prop
|
||||
|
||||
\ fixnum> { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum> { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum> t "foldable" set-word-prop
|
||||
|
||||
\ fixnum>= { fixnum fixnum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum>= { fixnum fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum>= t "foldable" set-word-prop
|
||||
|
||||
\ eq? { object object } { object } <effect> "infer-effect" set-word-prop
|
||||
\ eq? { object object } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ eq? t "foldable" set-word-prop
|
||||
|
||||
! Primitive combinators
|
||||
\ call { object } { } <effect> "infer-effect" set-word-prop
|
||||
\ call { object } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ call [ pop-literal infer-quot-value ] "infer" set-word-prop
|
||||
|
||||
\ execute { word } { } <effect> "infer-effect" set-word-prop
|
||||
\ execute { word } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ execute [
|
||||
pop-literal unit infer-quot-value
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ if { object object object } { } <effect> "infer-effect" set-word-prop
|
||||
\ if { object object object } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ if [
|
||||
2 #drop node, pop-d pop-d swap 2array
|
||||
#if pop-d drop infer-branches
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ cond { object } { } <effect> "infer-effect" set-word-prop
|
||||
\ cond { object } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ cond [
|
||||
pop-literal <reversed>
|
||||
[ no-cond ] swap alist>quot infer-quot-value
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ dispatch { fixnum array } { } <effect> "infer-effect" set-word-prop
|
||||
\ dispatch { fixnum array } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ dispatch [
|
||||
pop-literal nip [ <value> ] map
|
||||
|
|
@ -64,300 +66,352 @@ sequences strings vectors words prettyprint ;
|
|||
! Non-standard control flow
|
||||
\ throw { object } { } <effect>
|
||||
t over set-effect-terminated?
|
||||
"infer-effect" set-word-prop
|
||||
"inferred-effect" set-word-prop
|
||||
|
||||
! Stack effects for all primitives
|
||||
\ rehash-string { string } { } <effect> "infer-effect" set-word-prop
|
||||
\ rehash-string { string } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ string>sbuf { string } { sbuf } <effect> "infer-effect" set-word-prop
|
||||
\ string>sbuf { string } { sbuf } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ bignum>fixnum { bignum } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum>fixnum { bignum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum>fixnum t "foldable" set-word-prop
|
||||
|
||||
\ float>fixnum { float } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ float>fixnum { float } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum>fixnum t "foldable" set-word-prop
|
||||
|
||||
\ fixnum>bignum { fixnum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum>bignum { fixnum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum>bignum t "foldable" set-word-prop
|
||||
|
||||
\ float>bignum { float } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ float>bignum { float } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ float>bignum t "foldable" set-word-prop
|
||||
|
||||
\ fixnum>float { fixnum } { float } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum>float { fixnum } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum>float t "foldable" set-word-prop
|
||||
|
||||
\ bignum>float { bignum } { float } <effect> "infer-effect" set-word-prop
|
||||
\ bignum>float { bignum } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum>float t "foldable" set-word-prop
|
||||
|
||||
\ (fraction>) { integer integer } { rational } <effect> "infer-effect" set-word-prop
|
||||
\ (fraction>) { integer integer } { rational } <effect> "inferred-effect" set-word-prop
|
||||
\ (fraction>) t "foldable" set-word-prop
|
||||
|
||||
\ string>float { string } { float } <effect> "infer-effect" set-word-prop
|
||||
\ string>float { string } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ string>float t "foldable" set-word-prop
|
||||
|
||||
\ float>string { float } { string } <effect> "infer-effect" set-word-prop
|
||||
\ float>string { float } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ float>string t "foldable" set-word-prop
|
||||
|
||||
\ float>bits { real } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ float>bits { real } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ float>bits t "foldable" set-word-prop
|
||||
|
||||
\ double>bits { real } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ double>bits { real } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ double>bits t "foldable" set-word-prop
|
||||
|
||||
\ bits>float { integer } { float } <effect> "infer-effect" set-word-prop
|
||||
\ bits>float { integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ bits>float t "foldable" set-word-prop
|
||||
|
||||
\ bits>double { integer } { float } <effect> "infer-effect" set-word-prop
|
||||
\ bits>double { integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ bits>double t "foldable" set-word-prop
|
||||
|
||||
\ <complex> { real real } { number } <effect> "infer-effect" set-word-prop
|
||||
\ <complex> { real real } { number } <effect> "inferred-effect" set-word-prop
|
||||
\ <complex> t "foldable" set-word-prop
|
||||
|
||||
\ fixnum+ { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum+ { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum+ t "foldable" set-word-prop
|
||||
|
||||
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum+fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum+fast t "foldable" set-word-prop
|
||||
|
||||
\ fixnum- { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum- { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum- t "foldable" set-word-prop
|
||||
|
||||
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-fast t "foldable" set-word-prop
|
||||
|
||||
\ fixnum* { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum* { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum* t "foldable" set-word-prop
|
||||
|
||||
\ fixnum/i { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum/i { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum/i t "foldable" set-word-prop
|
||||
|
||||
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum-mod { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-mod t "foldable" set-word-prop
|
||||
|
||||
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum/mod t "foldable" set-word-prop
|
||||
|
||||
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-bitand t "foldable" set-word-prop
|
||||
|
||||
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-bitor t "foldable" set-word-prop
|
||||
|
||||
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-bitxor t "foldable" set-word-prop
|
||||
|
||||
\ fixnum-bitnot { fixnum } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum-bitnot { fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-bitnot t "foldable" set-word-prop
|
||||
|
||||
\ fixnum-shift { fixnum fixnum } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ fixnum-shift t "foldable" set-word-prop
|
||||
|
||||
\ bignum= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum= t "foldable" set-word-prop
|
||||
|
||||
\ bignum+ { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum+ { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum+ t "foldable" set-word-prop
|
||||
|
||||
\ bignum- { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum- { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum- t "foldable" set-word-prop
|
||||
|
||||
\ bignum* { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum* { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum* t "foldable" set-word-prop
|
||||
|
||||
\ bignum/i { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum/i { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum/i t "foldable" set-word-prop
|
||||
|
||||
\ bignum-mod { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum-mod { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-mod t "foldable" set-word-prop
|
||||
|
||||
\ bignum/mod { bignum bignum } { bignum bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum/mod { bignum bignum } { bignum bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum/mod t "foldable" set-word-prop
|
||||
|
||||
\ bignum-bitand { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum-bitand { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-bitand t "foldable" set-word-prop
|
||||
|
||||
\ bignum-bitor { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum-bitor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-bitor t "foldable" set-word-prop
|
||||
|
||||
\ bignum-bitxor { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum-bitxor { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-bitxor t "foldable" set-word-prop
|
||||
|
||||
\ bignum-bitnot { bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum-bitnot { bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-bitnot t "foldable" set-word-prop
|
||||
|
||||
\ bignum-shift { bignum bignum } { bignum } <effect> "infer-effect" set-word-prop
|
||||
\ bignum-shift { bignum bignum } { bignum } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum-shift t "foldable" set-word-prop
|
||||
|
||||
\ bignum< { bignum bignum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ bignum< { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum< t "foldable" set-word-prop
|
||||
|
||||
\ bignum<= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ bignum<= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum<= t "foldable" set-word-prop
|
||||
|
||||
\ bignum> { bignum bignum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ bignum> { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum> t "foldable" set-word-prop
|
||||
|
||||
\ bignum>= { bignum bignum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ bignum>= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ bignum>= t "foldable" set-word-prop
|
||||
|
||||
\ float+ { float float } { float } <effect> "infer-effect" set-word-prop
|
||||
\ float+ { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float+ t "foldable" set-word-prop
|
||||
|
||||
\ float- { float float } { float } <effect> "infer-effect" set-word-prop
|
||||
\ float- { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float- t "foldable" set-word-prop
|
||||
|
||||
\ float* { float float } { float } <effect> "infer-effect" set-word-prop
|
||||
\ float* { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float* t "foldable" set-word-prop
|
||||
|
||||
\ float/f { float float } { float } <effect> "infer-effect" set-word-prop
|
||||
\ float/f { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float/f t "foldable" set-word-prop
|
||||
|
||||
\ float< { float float } { object } <effect> "infer-effect" set-word-prop
|
||||
\ float< { float float } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ float< t "foldable" set-word-prop
|
||||
|
||||
\ float-mod { float float } { float } <effect> "infer-effect" set-word-prop
|
||||
\ float-mod { float float } { float } <effect> "inferred-effect" set-word-prop
|
||||
\ float-mod t "foldable" set-word-prop
|
||||
|
||||
\ float<= { float float } { object } <effect> "infer-effect" set-word-prop
|
||||
\ float<= { float float } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ float<= t "foldable" set-word-prop
|
||||
|
||||
\ float> { float float } { object } <effect> "infer-effect" set-word-prop
|
||||
\ float> { float float } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ float> t "foldable" set-word-prop
|
||||
|
||||
\ float>= { float float } { object } <effect> "infer-effect" set-word-prop
|
||||
\ float>= { float float } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ float>= t "foldable" set-word-prop
|
||||
|
||||
\ (word) { object object } { word } <effect> "infer-effect" set-word-prop
|
||||
\ (word) { object object } { word } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ update-xt { word } { } <effect> "infer-effect" set-word-prop
|
||||
\ update-xt { word } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ word-xt { word } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ word-xt { word } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ getenv { fixnum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ setenv { object fixnum } { } <effect> "infer-effect" set-word-prop
|
||||
\ stat { string } { object object object object } <effect> "infer-effect" set-word-prop
|
||||
\ (directory) { string } { array } <effect> "infer-effect" set-word-prop
|
||||
\ data-gc { integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ getenv { fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ setenv { object fixnum } { } <effect> "inferred-effect" set-word-prop
|
||||
\ stat { string } { object object object object } <effect> "inferred-effect" set-word-prop
|
||||
\ (directory) { string } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ data-gc { integer } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
! code-gc does not declare a stack effect since it might be
|
||||
! called from a compiled word which becomes unreachable during
|
||||
! the course of its execution, resulting in a crash
|
||||
|
||||
\ gc-time { } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ save-image { string } { } <effect> "infer-effect" set-word-prop
|
||||
\ exit { integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ data-room { } { integer integer array } <effect> "infer-effect" set-word-prop
|
||||
\ code-room { } { integer integer } <effect> "infer-effect" set-word-prop
|
||||
\ os-env { string } { object } <effect> "infer-effect" set-word-prop
|
||||
\ millis { } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ gc-time { } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ save-image { string } { } <effect> "inferred-effect" set-word-prop
|
||||
\ exit { integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ data-room { } { integer integer array } <effect> "inferred-effect" set-word-prop
|
||||
\ code-room { } { integer integer } <effect> "inferred-effect" set-word-prop
|
||||
\ os-env { string } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ millis { } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ type { object } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ type { object } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ type t "foldable" set-word-prop
|
||||
|
||||
\ tag { object } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ tag { object } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
\ tag t "foldable" set-word-prop
|
||||
|
||||
\ cwd { } { string } <effect> "infer-effect" set-word-prop
|
||||
\ cd { string } { } <effect> "infer-effect" set-word-prop
|
||||
\ cwd { } { string } <effect> "inferred-effect" set-word-prop
|
||||
\ cd { string } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ dlopen { string } { dll } <effect> "infer-effect" set-word-prop
|
||||
\ dlsym { string object } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ dlclose { dll } { } <effect> "infer-effect" set-word-prop
|
||||
\ dlopen { string } { dll } <effect> "inferred-effect" set-word-prop
|
||||
\ dlsym { string object } { integer } <effect> "inferred-effect" set-word-prop
|
||||
\ dlclose { dll } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ <byte-array> { integer } { byte-array } <effect> "infer-effect" set-word-prop
|
||||
\ <byte-array> { integer } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "infer-effect" set-word-prop
|
||||
\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-signed-cell { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ alien-signed-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-signed-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-cell { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-signed-8 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-signed-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-8 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-signed-4 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-signed-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-4 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-signed-2 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-2 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-unsigned-2 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-signed-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-2 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-signed-1 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-signed-1 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-unsigned-1 { c-ptr integer } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-signed-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-unsigned-1 { c-ptr integer } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-float { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-float { float c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-float { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-float { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-float { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-alien-double { float c-ptr integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ alien-double { c-ptr integer } { float } <effect> "infer-effect" set-word-prop
|
||||
\ set-alien-double { float c-ptr integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ alien-double { c-ptr integer } { float } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien>char-string { c-ptr } { string } <effect> "infer-effect" set-word-prop
|
||||
\ alien>char-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ string>char-alien { string } { byte-array } <effect> "infer-effect" set-word-prop
|
||||
\ string>char-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien>u16-string { c-ptr } { string } <effect> "infer-effect" set-word-prop
|
||||
\ alien>u16-string { c-ptr } { string } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ string>u16-alien { string } { byte-array } <effect> "infer-effect" set-word-prop
|
||||
\ string>u16-alien { string } { byte-array } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ string>memory { string integer } { } <effect> "infer-effect" set-word-prop
|
||||
\ memory>string { integer integer } { string } <effect> "infer-effect" set-word-prop
|
||||
\ string>memory { string integer } { } <effect> "inferred-effect" set-word-prop
|
||||
\ memory>string { integer integer } { string } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ alien-address { alien } { integer } <effect> "infer-effect" set-word-prop
|
||||
\ alien-address { alien } { integer } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ slot { object fixnum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ slot { object fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-slot { object object fixnum } { } <effect> "infer-effect" set-word-prop
|
||||
\ set-slot { object object fixnum } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ char-slot { fixnum object } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ char-slot { fixnum object } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-char-slot { fixnum fixnum object } { } <effect> "infer-effect" set-word-prop
|
||||
\ resize-array { integer array } { array } <effect> "infer-effect" set-word-prop
|
||||
\ resize-string { integer string } { string } <effect> "infer-effect" set-word-prop
|
||||
\ set-char-slot { fixnum fixnum object } { } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-array { integer array } { array } <effect> "inferred-effect" set-word-prop
|
||||
\ resize-string { integer string } { string } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ (hashtable) { } { hashtable } <effect> "infer-effect" set-word-prop
|
||||
\ (hashtable) { } { hashtable } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ <array> { integer object } { array } <effect> "infer-effect" set-word-prop
|
||||
\ <array> { integer object } { array } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ begin-scan { } { } <effect> "infer-effect" set-word-prop
|
||||
\ next-object { } { object } <effect> "infer-effect" set-word-prop
|
||||
\ end-scan { } { } <effect> "infer-effect" set-word-prop
|
||||
\ begin-scan { } { } <effect> "inferred-effect" set-word-prop
|
||||
\ next-object { } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ end-scan { } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ size { object } { fixnum } <effect> "infer-effect" set-word-prop
|
||||
\ size { object } { fixnum } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ die { } { } <effect> "infer-effect" set-word-prop
|
||||
\ fopen { string string } { alien } <effect> "infer-effect" set-word-prop
|
||||
\ fgetc { alien } { object } <effect> "infer-effect" set-word-prop
|
||||
\ fwrite { string alien } { } <effect> "infer-effect" set-word-prop
|
||||
\ fflush { alien } { } <effect> "infer-effect" set-word-prop
|
||||
\ fclose { alien } { } <effect> "infer-effect" set-word-prop
|
||||
\ expired? { object } { object } <effect> "infer-effect" set-word-prop
|
||||
\ die { } { } <effect> "inferred-effect" set-word-prop
|
||||
\ fopen { string string } { alien } <effect> "inferred-effect" set-word-prop
|
||||
\ fgetc { alien } { object } <effect> "inferred-effect" set-word-prop
|
||||
\ fwrite { string alien } { } <effect> "inferred-effect" set-word-prop
|
||||
\ fflush { alien } { } <effect> "inferred-effect" set-word-prop
|
||||
\ fclose { alien } { } <effect> "inferred-effect" set-word-prop
|
||||
\ expired? { object } { object } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ <wrapper> { object } { wrapper } <effect> "infer-effect" set-word-prop
|
||||
\ <wrapper> { object } { wrapper } <effect> "inferred-effect" set-word-prop
|
||||
\ <wrapper> t "foldable" set-word-prop
|
||||
|
||||
\ (clone) { object } { object } <effect> "infer-effect" set-word-prop
|
||||
\ (clone) { object } { object } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ become { object fixnum } { object } <effect> "infer-effect" set-word-prop
|
||||
\ become { object fixnum } { object } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ array>vector { array } { vector } <effect> "infer-effect" set-word-prop
|
||||
\ array>vector { array } { vector } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ finalize-compile { array } { } <effect> "infer-effect" set-word-prop
|
||||
\ finalize-compile { array } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ <string> { integer integer } { string } <effect> "infer-effect" set-word-prop
|
||||
\ <string> { integer integer } { string } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ <quotation> { integer } { quotation } <effect> "infer-effect" set-word-prop
|
||||
\ <quotation> { integer } { quotation } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
! Dynamic scope inference
|
||||
: if-tos-literal ( quot -- )
|
||||
peek-d dup value? [ value-literal swap call ] [ 2drop ] if ;
|
||||
inline
|
||||
|
||||
\ >n [ H{ } clone push-n ] "infer-vars" set-word-prop
|
||||
|
||||
\ >n { object } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
TUPLE: too-many-n> ;
|
||||
|
||||
: apply-n> ( -- )
|
||||
meta-n get empty? [
|
||||
<too-many-n>> inference-error
|
||||
] [
|
||||
pop-n drop
|
||||
] if ;
|
||||
|
||||
\ n> [ apply-n> ] "infer-vars" set-word-prop
|
||||
|
||||
\ n> { } { object } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ ndrop [ apply-n> ] "infer-vars" set-word-prop
|
||||
|
||||
\ ndrop { } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ get [
|
||||
[ apply-var-read ] if-tos-literal
|
||||
] "infer-vars" set-word-prop
|
||||
|
||||
\ get { object } { object } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set [
|
||||
[ apply-var-write ] if-tos-literal
|
||||
] "infer-vars" set-word-prop
|
||||
|
||||
\ set { object object } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ get-global [
|
||||
[ apply-global-read ]
|
||||
if-tos-literal
|
||||
] "infer-vars" set-word-prop
|
||||
|
||||
\ get-global { object } { object } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ set-global [
|
||||
[ apply-global-write ]
|
||||
if-tos-literal
|
||||
] "infer-vars" set-word-prop
|
||||
|
||||
\ set-global { object object } { } <effect> "inferred-effect" set-word-prop
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ sequences words parser words ;
|
|||
infer-shuffle-outputs ;
|
||||
|
||||
: define-shuffle ( word shuffle -- )
|
||||
[ "infer-effect" set-word-prop ] 2keep
|
||||
[ "inferred-effect" set-word-prop ] 2keep
|
||||
[ infer-shuffle ] curry "infer" set-word-prop ;
|
||||
|
||||
{
|
||||
|
|
@ -47,7 +47,7 @@ sequences words parser words ;
|
|||
0 1 rot node-outputs
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ >r { object } { } <effect> "infer-effect" set-word-prop
|
||||
\ >r { object } { } <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ r> [
|
||||
check-r>
|
||||
|
|
@ -57,4 +57,4 @@ sequences words parser words ;
|
|||
1 0 rot node-outputs
|
||||
] "infer" set-word-prop
|
||||
|
||||
\ r> { } { object } <effect> "infer-effect" set-word-prop
|
||||
\ r> { } { object } <effect> "inferred-effect" set-word-prop
|
||||
|
|
|
|||
|
|
@ -0,0 +1,54 @@
|
|||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: inference
|
||||
USING: kernel sequences hashtables kernel-internals words
|
||||
namespaces generic vectors namespaces ;
|
||||
|
||||
! Name stack and variable binding simulation
|
||||
SYMBOL: meta-n
|
||||
|
||||
: push-n meta-n get push ;
|
||||
: pop-n meta-n get pop ;
|
||||
: peek-n meta-n get peek ;
|
||||
|
||||
TUPLE: inferred-vars reads writes reads-globals writes-globals ;
|
||||
|
||||
: vars-trivial? ( vars -- ? ) tuple-slots [ empty? ] all? ;
|
||||
|
||||
: empty-vars ( -- vars )
|
||||
V{ } clone V{ } clone V{ } clone V{ } clone
|
||||
<inferred-vars> ;
|
||||
|
||||
: apply-var-seq ( seq -- )
|
||||
inferred-vars [
|
||||
>r [ tuple-slots ] map r> tuple-slots add flip
|
||||
[ concat prune >vector ] map first4 <inferred-vars>
|
||||
] change ;
|
||||
|
||||
: apply-var-read ( symbol -- )
|
||||
dup meta-n get [ hash-member? ] contains-with? [
|
||||
drop
|
||||
] [
|
||||
inferred-vars get inferred-vars-reads push-new
|
||||
] if ;
|
||||
|
||||
: apply-var-write ( symbol -- )
|
||||
meta-n get empty? [
|
||||
inferred-vars get inferred-vars-writes push-new
|
||||
] [
|
||||
dup peek-n set-hash
|
||||
] if ;
|
||||
|
||||
: apply-global-read ( symbol -- )
|
||||
inferred-vars get inferred-vars-reads-globals push-new ;
|
||||
|
||||
: apply-global-write ( symbol -- )
|
||||
inferred-vars get inferred-vars-writes-globals push-new ;
|
||||
|
||||
: apply-vars ( vars -- )
|
||||
[
|
||||
dup inferred-vars-reads [ apply-var-read ] each
|
||||
dup inferred-vars-writes [ apply-var-write ] each
|
||||
dup inferred-vars-reads-globals [ apply-global-read ] each
|
||||
inferred-vars-writes-globals [ apply-global-write ] each
|
||||
] when* ;
|
||||
|
|
@ -5,29 +5,32 @@ math math-internals namespaces parser prettyprint sequences
|
|||
strings vectors words ;
|
||||
IN: inference
|
||||
|
||||
: consume-values ( n node -- )
|
||||
: consume-values ( seq node -- )
|
||||
>r length r>
|
||||
over ensure-values
|
||||
over 0 rot node-inputs
|
||||
meta-d get [ length swap - ] keep set-length ;
|
||||
|
||||
: produce-values ( n node -- )
|
||||
: produce-values ( seq node -- )
|
||||
>r [ drop <computed> ] map dup r> set-node-out-d
|
||||
meta-d get swap nappend ;
|
||||
|
||||
: recursing? ( word -- label/f )
|
||||
recursive-state get <reversed> assoc ;
|
||||
|
||||
: if-inline ( word true false -- )
|
||||
>r >r dup "inline" word-prop r> r> if ; inline
|
||||
|
||||
: make-call-node ( word -- node )
|
||||
dup "inline" word-prop
|
||||
[ dup recursing? [ #call-label ] [ #call ] ?if ]
|
||||
[ #call ]
|
||||
if ;
|
||||
if-inline ;
|
||||
|
||||
: consume/produce ( word effect -- )
|
||||
: consume/produce ( effect word -- )
|
||||
meta-d get clone >r
|
||||
swap make-call-node dup node,
|
||||
over effect-in length over consume-values
|
||||
over effect-out length over produce-values
|
||||
over effect-in over consume-values
|
||||
over effect-out over produce-values
|
||||
r> over #call-label? [ swap set-node-in-d ] [ 2drop ] if
|
||||
effect-terminated? [ terminate ] when ;
|
||||
|
||||
|
|
@ -45,7 +48,7 @@ TUPLE: no-effect word ;
|
|||
: add-recursive-state ( word label -- )
|
||||
2array recursive-state [ swap add ] change ;
|
||||
|
||||
: inline-block ( word -- node-block variables )
|
||||
: inline-block ( word -- node-block data )
|
||||
[
|
||||
copy-inference nest-node
|
||||
gensym 2dup add-recursive-state
|
||||
|
|
@ -87,15 +90,14 @@ M: #call-label collect-recursion*
|
|||
apply-infer node-child node-successor splice-node drop
|
||||
] if ;
|
||||
|
||||
: infer-compound ( word -- effect )
|
||||
: infer-compound ( word -- hash )
|
||||
[
|
||||
recursive-state get init-inference
|
||||
[ inline-block nip [ current-effect ] bind ] keep
|
||||
] with-scope over consume/produce ;
|
||||
recursive-state get init-inference inline-block nip
|
||||
] with-scope ;
|
||||
|
||||
GENERIC: apply-word
|
||||
GENERIC: infer-word ( word -- effect data )
|
||||
|
||||
M: object apply-word no-effect ;
|
||||
M: word infer-word no-effect ;
|
||||
|
||||
TUPLE: effect-error word effect ;
|
||||
|
||||
|
|
@ -104,57 +106,76 @@ TUPLE: effect-error word effect ;
|
|||
|
||||
: check-effect ( word effect -- )
|
||||
over "infer" word-prop [
|
||||
2drop
|
||||
] [
|
||||
over recorded get push
|
||||
dup pick "declared-effect" word-prop dup
|
||||
[ effect<= [ effect-error ] unless ] [ 2drop ] if
|
||||
"infer-effect" set-word-prop
|
||||
] if ;
|
||||
over "declared-effect" word-prop 2dup
|
||||
[ swap effect<= [ effect-error ] unless ] [ 2drop ] if
|
||||
] unless 2drop ;
|
||||
|
||||
M: compound apply-word
|
||||
[
|
||||
dup infer-compound check-effect
|
||||
] [
|
||||
swap t "no-effect" set-word-prop rethrow
|
||||
] recover ;
|
||||
: save-inferred-data ( word effect vars -- )
|
||||
>r over r>
|
||||
dup vars-trivial? [ drop f ] when
|
||||
"inferred-vars" set-word-prop
|
||||
"inferred-effect" set-word-prop ;
|
||||
|
||||
: ?no-effect ( word -- )
|
||||
dup "no-effect" word-prop [ no-effect ] [ drop ] if ;
|
||||
: finish-word ( word -- effect vars )
|
||||
current-effect 2dup check-effect
|
||||
inferred-vars get
|
||||
[ save-inferred-data ] 2keep ;
|
||||
|
||||
: apply-default ( word -- )
|
||||
dup ?no-effect
|
||||
dup "infer-effect" word-prop [
|
||||
over "infer" word-prop [
|
||||
swap effect-in length ensure-values call drop
|
||||
] [
|
||||
consume/produce
|
||||
] if*
|
||||
] [
|
||||
apply-word
|
||||
] if* ;
|
||||
M: compound infer-word
|
||||
[ dup infer-compound [ finish-word ] bind ]
|
||||
[ swap t "no-effect" set-word-prop rethrow ] recover ;
|
||||
|
||||
M: word apply-object apply-default ;
|
||||
: custom-infer ( word -- )
|
||||
#! Customized inference behavior
|
||||
dup "inferred-vars" word-prop apply-vars
|
||||
dup "inferred-effect" word-prop effect-in ensure-values
|
||||
"infer" word-prop call ;
|
||||
|
||||
: apply-effect/vars ( word effect vars -- )
|
||||
apply-vars consume/produce ;
|
||||
|
||||
: cached-infer ( word -- )
|
||||
dup "inferred-effect" word-prop
|
||||
over "inferred-vars" word-prop
|
||||
apply-effect/vars ;
|
||||
|
||||
: apply-word ( word -- )
|
||||
{
|
||||
{ [ dup "no-effect" word-prop ] [ no-effect ] }
|
||||
{ [ dup "infer" word-prop ] [ custom-infer ] }
|
||||
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
|
||||
{ [ t ] [ dup infer-word apply-effect/vars ] }
|
||||
} cond ;
|
||||
|
||||
M: word apply-object apply-word ;
|
||||
|
||||
M: symbol apply-object apply-literal ;
|
||||
|
||||
TUPLE: recursive-declare-error word ;
|
||||
|
||||
: recursive-effect ( word -- effect )
|
||||
dup stack-effect
|
||||
[ ] [ <recursive-declare-error> inference-error ] ?if ;
|
||||
: declared-infer ( word -- )
|
||||
dup stack-effect [
|
||||
consume/produce
|
||||
] [
|
||||
<recursive-declare-error> inference-error
|
||||
] if* ;
|
||||
|
||||
: apply-inline ( word -- )
|
||||
dup recursive-state get peek first eq?
|
||||
[ declared-infer ] [ inline-closure ] if ;
|
||||
|
||||
: apply-compound ( word -- )
|
||||
dup recursing? [ declared-infer ] [ apply-word ] if ;
|
||||
|
||||
: custom-infer-vars ( word -- )
|
||||
dup "infer-vars" word-prop dup [
|
||||
swap "inferred-effect" word-prop effect-in ensure-values
|
||||
call
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: compound apply-object
|
||||
dup "inline" word-prop [
|
||||
dup recursive-state get peek first eq? [
|
||||
dup recursive-effect consume/produce
|
||||
] [
|
||||
inline-closure
|
||||
] if
|
||||
] [
|
||||
dup recursing? [
|
||||
dup recursive-effect consume/produce
|
||||
] [
|
||||
apply-default
|
||||
] if
|
||||
] if ;
|
||||
dup custom-infer-vars
|
||||
[ apply-inline ] [ apply-compound ] if-inline ;
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@ PROVIDE: library/compiler
|
|||
{ +files+ {
|
||||
"inference/shuffle.factor"
|
||||
"inference/dataflow.factor"
|
||||
"inference/variables.factor"
|
||||
"inference/inference.factor"
|
||||
"inference/branches.factor"
|
||||
"inference/words.factor"
|
||||
|
|
|
|||
|
|
@ -119,7 +119,7 @@ M: node child-ties
|
|||
dup node-param "output-classes" word-prop [
|
||||
call
|
||||
] [
|
||||
node-param "infer-effect" word-prop effect-out
|
||||
node-param "inferred-effect" word-prop effect-out
|
||||
dup [ word? ] all? [ drop f ] unless
|
||||
] if* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,6 +3,9 @@ math math-internals namespaces parser sequences strings test
|
|||
vectors words ;
|
||||
IN: temporary
|
||||
|
||||
: short-effect
|
||||
dup effect-in length swap effect-out length 2array nip ;
|
||||
|
||||
[ f ] [ f [ [ ] map-nodes ] with-node-iterator ] unit-test
|
||||
|
||||
[ t ] [ [ ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test
|
||||
|
|
@ -11,20 +14,20 @@ IN: temporary
|
|||
|
||||
[ t ] [ [ [ ] [ ] if ] dataflow dup [ [ ] map-nodes ] with-node-iterator = ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ f infer ] unit-test
|
||||
[ { 0 2 } ] [ [ 2 "Hello" ] infer ] unit-test
|
||||
[ { 1 2 } ] [ [ dup ] infer ] unit-test
|
||||
[ { 0 0 } ] [ f infer short-effect ] unit-test
|
||||
[ { 0 2 } ] [ [ 2 "Hello" ] infer short-effect ] unit-test
|
||||
[ { 1 2 } ] [ [ dup ] infer short-effect ] unit-test
|
||||
|
||||
[ { 1 2 } ] [ [ [ dup ] call ] infer ] unit-test
|
||||
[ [ call ] infer ] unit-test-fails
|
||||
[ { 1 2 } ] [ [ [ dup ] call ] infer short-effect ] unit-test
|
||||
[ [ call ] infer short-effect ] unit-test-fails
|
||||
|
||||
[ { 2 4 } ] [ [ 2dup ] infer ] unit-test
|
||||
[ { 2 4 } ] [ [ 2dup ] infer short-effect ] unit-test
|
||||
|
||||
[ { 1 0 } ] [ [ [ ] [ ] if ] infer ] unit-test
|
||||
[ [ if ] infer ] unit-test-fails
|
||||
[ [ [ ] if ] infer ] unit-test-fails
|
||||
[ [ [ 2 ] [ ] if ] infer ] unit-test-fails
|
||||
[ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer ] unit-test
|
||||
[ { 1 0 } ] [ [ [ ] [ ] if ] infer short-effect ] unit-test
|
||||
[ [ if ] infer short-effect ] unit-test-fails
|
||||
[ [ [ ] if ] infer short-effect ] unit-test-fails
|
||||
[ [ [ 2 ] [ ] if ] infer short-effect ] unit-test-fails
|
||||
[ { 4 3 } ] [ [ [ rot ] [ -rot ] if ] infer short-effect ] unit-test
|
||||
|
||||
[ { 4 3 } ] [
|
||||
[
|
||||
|
|
@ -33,18 +36,18 @@ IN: temporary
|
|||
] [
|
||||
-rot
|
||||
] if
|
||||
] infer
|
||||
] infer short-effect
|
||||
] unit-test
|
||||
|
||||
[ { 1 1 } ] [ [ dup [ ] when ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ dup [ ] when ] infer short-effect ] unit-test
|
||||
[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer short-effect ] unit-test
|
||||
|
||||
[ { 1 0 } ] [ [ [ drop ] when* ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test
|
||||
[ { 1 0 } ] [ [ [ drop ] when* ] infer short-effect ] unit-test
|
||||
[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer short-effect ] unit-test
|
||||
|
||||
[ { 0 1 } ] [
|
||||
[ [ 2 2 fixnum+ ] dup [ ] when call ] infer
|
||||
[ [ 2 2 fixnum+ ] dup [ ] when call ] infer short-effect
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
@ -57,37 +60,37 @@ IN: temporary
|
|||
|
||||
: termination-test-2 [ termination-test-1 ] [ 3 ] if ;
|
||||
|
||||
[ { 1 1 } ] [ [ termination-test-2 ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ termination-test-2 ] infer short-effect ] unit-test
|
||||
|
||||
: infinite-loop infinite-loop ;
|
||||
|
||||
[ [ infinite-loop ] infer ] unit-test-fails
|
||||
[ [ infinite-loop ] infer short-effect ] unit-test-fails
|
||||
|
||||
: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ;
|
||||
[ [ no-base-case-1 ] infer ] unit-test-fails
|
||||
[ [ no-base-case-1 ] infer short-effect ] unit-test-fails
|
||||
|
||||
: simple-recursion-1 ( obj -- obj )
|
||||
dup [ simple-recursion-1 ] [ ] if ;
|
||||
|
||||
[ { 1 1 } ] [ [ simple-recursion-1 ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ simple-recursion-1 ] infer short-effect ] unit-test
|
||||
|
||||
: simple-recursion-2 ( obj -- obj )
|
||||
dup [ ] [ simple-recursion-2 ] if ;
|
||||
|
||||
[ { 1 1 } ] [ [ simple-recursion-2 ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ simple-recursion-2 ] infer short-effect ] unit-test
|
||||
|
||||
: bad-recursion-2 ( obj -- obj )
|
||||
dup [ dup first swap second bad-recursion-2 ] [ ] if ;
|
||||
|
||||
[ [ bad-recursion-2 ] infer ] unit-test-fails
|
||||
[ [ bad-recursion-2 ] infer short-effect ] unit-test-fails
|
||||
|
||||
: funny-recursion ( obj -- obj )
|
||||
dup [ funny-recursion 1 ] [ 2 ] if drop ;
|
||||
|
||||
[ { 1 1 } ] [ [ funny-recursion ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ funny-recursion ] infer short-effect ] unit-test
|
||||
|
||||
! Simple combinators
|
||||
[ { 1 2 } ] [ [ [ first ] keep second ] infer ] unit-test
|
||||
[ { 1 2 } ] [ [ [ first ] keep second ] infer short-effect ] unit-test
|
||||
|
||||
! Mutual recursion
|
||||
DEFER: foe
|
||||
|
|
@ -110,8 +113,8 @@ DEFER: foe
|
|||
2drop f
|
||||
] if ;
|
||||
|
||||
[ { 2 1 } ] [ [ fie ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ foe ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ fie ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ foe ] infer short-effect ] unit-test
|
||||
|
||||
: nested-when ( -- )
|
||||
t [
|
||||
|
|
@ -120,7 +123,7 @@ DEFER: foe
|
|||
] when
|
||||
] when ;
|
||||
|
||||
[ { 0 0 } ] [ [ nested-when ] infer ] unit-test
|
||||
[ { 0 0 } ] [ [ nested-when ] infer short-effect ] unit-test
|
||||
|
||||
: nested-when* ( obj -- )
|
||||
[
|
||||
|
|
@ -129,11 +132,11 @@ DEFER: foe
|
|||
] when*
|
||||
] when* ;
|
||||
|
||||
[ { 1 0 } ] [ [ nested-when* ] infer ] unit-test
|
||||
[ { 1 0 } ] [ [ nested-when* ] infer short-effect ] unit-test
|
||||
|
||||
SYMBOL: sym-test
|
||||
|
||||
[ { 0 1 } ] [ [ sym-test ] infer ] unit-test
|
||||
[ { 0 1 } ] [ [ sym-test ] infer short-effect ] unit-test
|
||||
|
||||
: terminator-branch
|
||||
dup [
|
||||
|
|
@ -142,7 +145,7 @@ SYMBOL: sym-test
|
|||
"foo" throw
|
||||
] if ;
|
||||
|
||||
[ { 1 1 } ] [ [ terminator-branch ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ terminator-branch ] infer short-effect ] unit-test
|
||||
|
||||
: recursive-terminator ( obj -- )
|
||||
dup [
|
||||
|
|
@ -151,12 +154,12 @@ SYMBOL: sym-test
|
|||
"Hi" throw
|
||||
] if ;
|
||||
|
||||
[ { 1 0 } ] [ [ recursive-terminator ] infer ] unit-test
|
||||
[ { 1 0 } ] [ [ recursive-terminator ] infer short-effect ] unit-test
|
||||
|
||||
GENERIC: potential-hang ( obj -- obj )
|
||||
M: fixnum potential-hang dup [ potential-hang ] when ;
|
||||
|
||||
[ ] [ [ 5 potential-hang ] infer drop ] unit-test
|
||||
[ ] [ [ 5 potential-hang ] infer short-effect drop ] unit-test
|
||||
|
||||
TUPLE: funny-cons car cdr ;
|
||||
GENERIC: iterate ( obj -- )
|
||||
|
|
@ -164,24 +167,24 @@ M: funny-cons iterate funny-cons-cdr iterate ;
|
|||
M: f iterate drop ;
|
||||
M: real iterate drop ;
|
||||
|
||||
[ { 1 0 } ] [ [ iterate ] infer ] unit-test
|
||||
[ { 1 0 } ] [ [ iterate ] infer short-effect ] unit-test
|
||||
|
||||
! Regression
|
||||
: cat ( obj -- * ) dup [ throw ] [ throw ] if ;
|
||||
: dog ( a b c -- ) dup [ cat ] [ 3drop ] if ;
|
||||
[ { 3 0 } ] [ [ dog ] infer ] unit-test
|
||||
[ { 3 0 } ] [ [ dog ] infer short-effect ] unit-test
|
||||
|
||||
! Regression
|
||||
DEFER: monkey
|
||||
: friend ( a b c -- ) dup [ friend ] [ monkey ] if ;
|
||||
: monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ;
|
||||
[ { 3 0 } ] [ [ friend ] infer ] unit-test
|
||||
[ { 3 0 } ] [ [ friend ] infer short-effect ] unit-test
|
||||
|
||||
! Regression -- same as above but we infer the second word first
|
||||
! Regression -- same as above but we infer short-effect the second word first
|
||||
DEFER: blah2
|
||||
: blah ( a b c -- ) dup [ blah ] [ blah2 ] if ;
|
||||
: blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ;
|
||||
[ { 3 0 } ] [ [ blah2 ] infer ] unit-test
|
||||
[ { 3 0 } ] [ [ blah2 ] infer short-effect ] unit-test
|
||||
|
||||
! Regression
|
||||
DEFER: blah4
|
||||
|
|
@ -189,7 +192,7 @@ DEFER: blah4
|
|||
dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ;
|
||||
: blah4 ( a b c -- )
|
||||
dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
|
||||
[ { 3 0 } ] [ [ blah4 ] infer ] unit-test
|
||||
[ { 3 0 } ] [ [ blah4 ] infer short-effect ] unit-test
|
||||
|
||||
! Regression
|
||||
: bad-combinator ( obj quot -- )
|
||||
|
|
@ -199,14 +202,14 @@ DEFER: blah4
|
|||
[ swap slip ] keep swap bad-combinator
|
||||
] if ; inline
|
||||
|
||||
[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
|
||||
[ [ [ 1 ] [ ] bad-combinator ] infer short-effect ] unit-test-fails
|
||||
|
||||
! Regression
|
||||
: bad-input#
|
||||
dup string? [ 2array throw ] unless
|
||||
over string? [ 2array throw ] unless ;
|
||||
|
||||
[ { 2 2 } ] [ [ bad-input# ] infer ] unit-test
|
||||
[ { 2 2 } ] [ [ bad-input# ] infer short-effect ] unit-test
|
||||
|
||||
! Regression
|
||||
|
||||
|
|
@ -214,18 +217,18 @@ DEFER: blah4
|
|||
DEFER: do-crap
|
||||
: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
|
||||
: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
|
||||
[ [ do-crap ] infer ] unit-test-fails
|
||||
[ [ do-crap ] infer short-effect ] unit-test-fails
|
||||
|
||||
! This one does not
|
||||
DEFER: do-crap*
|
||||
: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
|
||||
: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
|
||||
[ [ do-crap* ] infer ] unit-test-fails
|
||||
[ [ do-crap* ] infer short-effect ] unit-test-fails
|
||||
|
||||
! Regression
|
||||
: too-deep ( a b -- c )
|
||||
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline
|
||||
[ { 2 1 } ] [ [ too-deep ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ too-deep ] infer short-effect ] unit-test
|
||||
|
||||
! Error reporting is wrong
|
||||
G: xyz math-combination ;
|
||||
|
|
@ -233,7 +236,7 @@ M: fixnum xyz 2array ;
|
|||
M: ratio xyz
|
||||
[ >fraction ] 2apply swapd >r 2array swap r> 2array swap ;
|
||||
|
||||
[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test
|
||||
[ t ] [ [ [ xyz ] infer short-effect ] catch inference-error? ] unit-test
|
||||
|
||||
! Doug Coleman discovered this one while working on the
|
||||
! calendar library
|
||||
|
|
@ -265,17 +268,17 @@ DEFER: C
|
|||
[ dup B C ]
|
||||
} dispatch ;
|
||||
|
||||
[ { 1 0 } ] [ [ A ] infer ] unit-test
|
||||
[ { 1 0 } ] [ [ B ] infer ] unit-test
|
||||
[ { 1 0 } ] [ [ C ] infer ] unit-test
|
||||
[ { 1 0 } ] [ [ A ] infer short-effect ] unit-test
|
||||
[ { 1 0 } ] [ [ B ] infer short-effect ] unit-test
|
||||
[ { 1 0 } ] [ [ C ] infer short-effect ] unit-test
|
||||
|
||||
! I found this bug by thinking hard about the previous one
|
||||
DEFER: Y
|
||||
: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
|
||||
: Y ( a b -- c d ) X ;
|
||||
|
||||
[ { 2 2 } ] [ [ X ] infer ] unit-test
|
||||
[ { 2 2 } ] [ [ Y ] infer ] unit-test
|
||||
[ { 2 2 } ] [ [ X ] infer short-effect ] unit-test
|
||||
[ { 2 2 } ] [ [ Y ] infer short-effect ] unit-test
|
||||
|
||||
! This one comes from UI code
|
||||
DEFER: #1
|
||||
|
|
@ -284,68 +287,92 @@ DEFER: #1
|
|||
: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
|
||||
: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
|
||||
|
||||
[ \ #4 word-def infer ] unit-test-fails
|
||||
[ [ #1 ] infer ] unit-test-fails
|
||||
[ \ #4 word-def infer short-effect ] unit-test-fails
|
||||
[ [ #1 ] infer short-effect ] unit-test-fails
|
||||
|
||||
! Similar
|
||||
DEFER: bar
|
||||
: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
|
||||
: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
|
||||
|
||||
[ [ foo ] infer ] unit-test-fails
|
||||
[ [ foo ] infer short-effect ] unit-test-fails
|
||||
|
||||
[ 1234 infer ] unit-test-fails
|
||||
[ 1234 infer short-effect ] unit-test-fails
|
||||
|
||||
! This used to hang
|
||||
[ [ [ dup call ] dup call ] infer ] unit-test-fails
|
||||
[ [ [ dup call ] dup call ] infer short-effect ] unit-test-fails
|
||||
|
||||
! This form should not have a stack effect
|
||||
|
||||
: bad-recursion-1 ( a -- b )
|
||||
dup [ drop bad-recursion-1 5 ] [ ] if ;
|
||||
|
||||
[ [ bad-recursion-1 ] infer ] unit-test-fails
|
||||
[ [ bad-recursion-1 ] infer short-effect ] unit-test-fails
|
||||
|
||||
: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
|
||||
[ [ bad-bin ] infer ] unit-test-fails
|
||||
[ [ bad-bin ] infer short-effect ] unit-test-fails
|
||||
|
||||
[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test
|
||||
[ t ] [ [ [ r> ] infer short-effect ] catch inference-error? ] unit-test
|
||||
|
||||
! Test some random library words
|
||||
|
||||
[ { 1 1 } ] [ [ unit ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ unit ] infer short-effect ] unit-test
|
||||
|
||||
[ { 1 0 } ] [ [ >n ] infer ] unit-test
|
||||
[ { 0 1 } ] [ [ n> ] infer ] unit-test
|
||||
! Unbalanced >n/n> is an error now!
|
||||
! [ { 1 0 } ] [ [ >n ] infer short-effect ] unit-test
|
||||
! [ { 0 1 } ] [ [ n> ] infer short-effect ] unit-test
|
||||
|
||||
[ { 2 1 } ] [ [ bitor ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ bitand ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ bitxor ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ mod ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ /i ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ /f ] infer ] unit-test
|
||||
[ { 2 2 } ] [ [ /mod ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ + ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ - ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ * ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ / ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ < ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ <= ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ > ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ >= ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ number= ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ bitor ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ bitand ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ bitxor ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ mod ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ /i ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ /f ] infer short-effect ] unit-test
|
||||
[ { 2 2 } ] [ [ /mod ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ + ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ - ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ * ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ / ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ < ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ <= ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ > ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ >= ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ number= ] infer short-effect ] unit-test
|
||||
|
||||
[ { 1 1 } ] [ [ string>number ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ = ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ get ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ string>number ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ = ] infer short-effect ] unit-test
|
||||
[ { 1 1 } ] [ [ get ] infer short-effect ] unit-test
|
||||
|
||||
[ { 2 0 } ] [ [ push ] infer ] unit-test
|
||||
[ { 2 0 } ] [ [ set-length ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ append ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ peek ] infer ] unit-test
|
||||
[ { 2 0 } ] [ [ push ] infer short-effect ] unit-test
|
||||
[ { 2 0 } ] [ [ set-length ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ append ] infer short-effect ] unit-test
|
||||
[ { 1 1 } ] [ [ peek ] infer short-effect ] unit-test
|
||||
|
||||
[ { 1 1 } ] [ [ length ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ reverse ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ member? ] infer ] unit-test
|
||||
[ { 2 1 } ] [ [ remove ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ natural-sort ] infer ] unit-test
|
||||
[ { 1 1 } ] [ [ length ] infer short-effect ] unit-test
|
||||
[ { 1 1 } ] [ [ reverse ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ member? ] infer short-effect ] unit-test
|
||||
[ { 2 1 } ] [ [ remove ] infer short-effect ] unit-test
|
||||
[ { 1 1 } ] [ [ natural-sort ] infer short-effect ] unit-test
|
||||
|
||||
! Test scope inference
|
||||
SYMBOL: x
|
||||
|
||||
[ [ n> ] infer ] unit-test-fails
|
||||
[ [ ndrop ] infer ] unit-test-fails
|
||||
[ V{ x } ] [ [ x get ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ x } ] [ [ x set ] infer drop inferred-vars-writes ] unit-test
|
||||
[ V{ x } ] [ [ [ x get ] with-scope ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ } ] [ [ [ x set ] with-scope ] infer drop inferred-vars-writes ] unit-test
|
||||
[ V{ x } ] [ [ [ x get ] bind ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ } ] [ [ [ x set ] bind ] infer drop inferred-vars-writes ] unit-test
|
||||
[ V{ x } ] [ [ [ x get ] make-hash ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ } ] [ [ [ x set ] make-hash ] infer drop inferred-vars-writes ] unit-test
|
||||
[ V{ building } ] [ [ , ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ } ] [ [ [ 3 , ] { } make ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ x } ] [ [ [ x get ] [ 5 ] if ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ x } ] [ [ >n [ x get ] [ 5 ] if n> ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ } ] [ [ >n [ x set ] [ drop ] if x get n> ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ x } ] [ [ >n x get ndrop ] infer drop inferred-vars-reads ] unit-test
|
||||
[ V{ } ] [ [ >n x set ndrop ] infer drop inferred-vars-writes ] unit-test
|
||||
|
||||
[ [ >n ] [ ] if ] unit-test-fails
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ C: effect
|
|||
|
||||
: stack-effect ( word -- effect/f )
|
||||
dup "declared-effect" word-prop [ ] [
|
||||
dup "infer-effect" word-prop [ ] [ drop f ] ?if
|
||||
dup "inferred-effect" word-prop [ ] [ drop f ] ?if
|
||||
] ?if ;
|
||||
|
||||
M: effect clone
|
||||
|
|
|
|||
|
|
@ -34,7 +34,9 @@ SYMBOL: restarts
|
|||
error-continuation get continuation-name hash-stack ;
|
||||
|
||||
: :res ( n -- )
|
||||
restarts get nth first3 continue-with ;
|
||||
restarts get-global nth
|
||||
f restarts set-global
|
||||
first3 continue-with ;
|
||||
|
||||
: :edit ( -- )
|
||||
error get
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ M: gadget ungraft* drop ;
|
|||
: build-spec ( spec quot -- )
|
||||
swap (build-spec) call ;
|
||||
|
||||
\ build-spec 2 0 <effect> "infer-effect" set-word-prop
|
||||
\ build-spec 2 0 <effect> "inferred-effect" set-word-prop
|
||||
|
||||
\ build-spec [
|
||||
pop-literal pop-literal nip (build-spec) infer-quot-value
|
||||
|
|
|
|||
|
|
@ -85,8 +85,10 @@ SYMBOL: crossref
|
|||
{ [ dup "infer" word-prop ] [ drop ] }
|
||||
{ [ t ] [
|
||||
dup changed-word
|
||||
{ "infer-effect" "base-case" "no-effect" }
|
||||
reset-props
|
||||
{
|
||||
"inferred-effect" "inferred-vars"
|
||||
"base-case" "no-effect"
|
||||
} reset-props
|
||||
] }
|
||||
} cond ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue