steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Half-assed constant folding in extra/inverse

release
Daniel Ehrenberg 2007-11-29 12:06:52 -05:00
parent 74e8fea55a
commit b04c9201d0
1 changed files with 39 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
extra/inverse/inverse.factor
View File

@ -1,7 +1,7 @@
USING: kernel words inspector slots quotations sequences assocs USING: kernel words inspector slots quotations sequences assocs
math arrays inference effects shuffle continuations debugger math arrays inference effects shuffle continuations debugger
tuples namespaces vectors bit-arrays byte-arrays strings sbufs tuples namespaces vectors bit-arrays byte-arrays strings sbufs
math.functions macros ; math.functions macros combinators.private combinators ;
IN: inverse IN: inverse
TUPLE: fail ; TUPLE: fail ;
@ -18,7 +18,7 @@ M: fail summary drop "Unification failed" ;
: define-inverse ( word quot -- ) "inverse" set-word-prop ; : define-inverse ( word quot -- ) "inverse" set-word-prop ;
: define-math-inverse ( word quot1 quot2 -- ) : define-math-inverse ( word quot1 quot2 -- )
2array "math-inverse" set-word-prop ; pick 1quotation 3array "math-inverse" set-word-prop ;
: define-pop-inverse ( word n quot -- ) : define-pop-inverse ( word n quot -- )
>r dupd "pop-length" set-word-prop r> >r dupd "pop-length" set-word-prop r>
@ -40,10 +40,7 @@ M: no-inverse summary
effect-in length 0 = and ; effect-in length 0 = and ;
: assure-constant ( constant -- quot ) : assure-constant ( constant -- quot )
dup word? [ dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
dup constant-word?
[ "Badly formed math inverse" throw ] unless
] when 1quotation ;
: swap-inverse ( math-inverse revquot -- revquot* quot ) : swap-inverse ( math-inverse revquot -- revquot* quot )
next assure-constant rot second [ swap ] swap 3compose ; next assure-constant rot second [ swap ] swap 3compose ;
@ -54,27 +51,52 @@ M: no-inverse summary
: ?word-prop ( word/object name -- value/f ) : ?word-prop ( word/object name -- value/f )
over word? [ word-prop ] [ 2drop f ] if ; over word? [ word-prop ] [ 2drop f ] if ;
GENERIC: inverse ( revquot word -- revquot* quot )
DEFER: [undo]
M: word inverse
dup "inverse" word-prop [ ]
[ dup primitive? [ no-inverse ] [ word-def [undo] ] if ] ?if ;
: undo-literal ( object -- quot ) : undo-literal ( object -- quot )
[ =/fail ] curry ; [ =/fail ] curry ;
PREDICATE: word normal-inverse "inverse" word-prop ;
PREDICATE: word math-inverse "math-inverse" word-prop ;
PREDICATE: word pop-inverse "pop-length" word-prop ;
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: inline-word ( word -- )
{
{ [ dup word? not over symbol? or ] [ , ] }
{ [ dup explicit-inverse? ] [ , ] }
{ [ dup compound? over { if dispatch } member? not and ]
[ word-def [ inline-word ] each ] }
{ [ drop t ] [ "Quotation is not invertible" throw ] }
} cond ;
: math-exp? ( n n word -- ? )
{ + - * / ^ } member? -rot [ number? ] 2apply and and ;
: (fold-constants) ( quot -- )
dup length 3 < [ % ] [
dup first3 3dup math-exp?
[ execute , 3 ] [ 2drop , 1 ] if
tail-slice (fold-constants)
] if ;
: fold-constants ( quot -- folded )
[ (fold-constants) ] [ ] make ;
: do-inlining ( quot -- inlined-quot )
[ [ inline-word ] each ] [ ] make fold-constants ;
GENERIC: inverse ( revquot word -- revquot* quot )
M: object inverse undo-literal ; M: object inverse undo-literal ;
M: symbol inverse undo-literal ; M: symbol inverse undo-literal ;
PREDICATE: word math-inverse "math-inverse" word-prop ; M: normal-inverse inverse
"inverse" word-prop ;
M: math-inverse inverse M: math-inverse inverse
"math-inverse" word-prop "math-inverse" word-prop
swap next dup \ swap = swap next dup \ swap =
[ drop swap-inverse ] [ pull-inverse ] if ; [ drop swap-inverse ] [ pull-inverse ] if ;
PREDICATE: word pop-inverse "pop-length" word-prop ;
M: pop-inverse inverse M: pop-inverse inverse
[ "pop-length" word-prop cut-slice swap ] keep [ "pop-length" word-prop cut-slice swap ] keep
"pop-inverse" word-prop compose call ; "pop-inverse" word-prop compose call ;
@ -84,7 +106,7 @@ M: pop-inverse inverse
[ unclip-slice inverse % (undo) ] if ; [ unclip-slice inverse % (undo) ] if ;
: [undo] ( quot -- undo ) : [undo] ( quot -- undo )
reverse [ (undo) ] [ ] make ; do-inlining reverse [ (undo) ] [ ] make ;
MACRO: undo ( quot -- ) [undo] ; MACRO: undo ( quot -- ) [undo] ;