98 lines
2.9 KiB
Factor
98 lines
2.9 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: inference
|
|
USING: generic interpreter kernel lists math namespaces
|
|
sequences words ;
|
|
|
|
: literal-inputs? ( in stack -- )
|
|
tail-slice* dup >list [ safe-literal? ] all? [
|
|
length #drop node, t
|
|
] [
|
|
drop f
|
|
] ifte ;
|
|
|
|
: literal-inputs ( out stack -- )
|
|
tail-slice* [ literal-value ] nmap ;
|
|
|
|
: literal-outputs ( out stack -- )
|
|
tail-slice* dup [ recursive-state get <literal> ] nmap
|
|
length #push node, ;
|
|
|
|
: partial-eval? ( word -- ? )
|
|
"infer-effect" word-prop car length
|
|
meta-d get literal-inputs? ;
|
|
|
|
: infer-eval ( word -- )
|
|
dup partial-eval? [
|
|
dup "infer-effect" word-prop 2unlist
|
|
>r length meta-d get
|
|
literal-inputs
|
|
host-word
|
|
r> length meta-d get literal-outputs
|
|
] [
|
|
dup "infer-effect" word-prop consume/produce
|
|
] ifte ;
|
|
|
|
: stateless ( word -- )
|
|
#! A stateless word can be evaluated at compile-time.
|
|
dup unit [ car infer-eval ] cons "infer" set-word-prop ;
|
|
|
|
! Could probably add more words here
|
|
[
|
|
eq?
|
|
car
|
|
cdr
|
|
cons
|
|
<
|
|
<=
|
|
>
|
|
>=
|
|
number=
|
|
+
|
|
-
|
|
*
|
|
/
|
|
/i
|
|
/f
|
|
mod
|
|
/mod
|
|
bitand
|
|
bitor
|
|
bitxor
|
|
shift
|
|
bitnot
|
|
>fixnum
|
|
>bignum
|
|
>float
|
|
real
|
|
imaginary
|
|
] [
|
|
stateless
|
|
] each
|
|
|
|
! Partially-evaluated words need their stack effects to be
|
|
! entered by hand.
|
|
\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
|
|
\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
|
|
\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
|
|
\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
|
|
\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
|
|
\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
|
|
\ number= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop
|
|
\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop
|
|
\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop
|
|
\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop
|
|
\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop
|
|
\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop
|
|
\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop
|
|
\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
|
|
\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
|
|
\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
|
|
\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
|
|
\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
|
|
\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop
|
|
\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop
|
|
\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
|
|
\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop
|
|
\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop
|