Fix conflict

db4
Slava Pestov 2008-03-29 15:53:33 -05:00
commit f72336e70e
3 changed files with 37 additions and 27 deletions

View File

@ -2,7 +2,7 @@ USING: kernel words inspector slots quotations sequences assocs
math arrays inference effects shuffle continuations debugger
classes.tuple namespaces vectors bit-arrays byte-arrays strings
sbufs math.functions macros sequences.private combinators
mirrors ;
mirrors combinators.lib ;
IN: inverse
TUPLE: fail ;
@ -60,38 +60,44 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ;
PREDICATE: pop-inverse < word "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 ] }
{ [ dup word? over { if dispatch } member? not and ]
[ word-def [ inline-word ] each ] }
{ [ drop t ] [ "Quotation is not invertible" throw ] }
} cond ;
: enough? ( stack quot -- ? )
[ >r length r> 1quotation infer effect-in >= ] [ 3drop f ]
recover ;
: math-exp? ( n n word -- ? )
{ + - * / ^ } member? -rot [ number? ] both? and ;
: fold-word ( stack quot -- stack )
2dup enough?
[ 1quotation with-datastack ] [ >r % r> , { } ] if ;
: (fold-constants) ( quot -- )
dup length 3 < [ % ] [
dup first3 3dup math-exp?
[ execute , 3 ] [ 2drop , 1 ] if
tail-slice (fold-constants)
] if ;
: fold ( quot -- folded-quot )
[ { } swap [ fold-word ] each % ] [ ] make ;
: fold-constants ( quot -- folded )
[ (fold-constants) ] [ ] make ;
: flattenable? ( object -- ? )
[ [ word? ] [ primitive? not ] and? ] [
{ "inverse" "math-inverse" "pop-inverse" }
[ word-prop ] with contains? not
] and? ;
: do-inlining ( quot -- inlined-quot )
[ [ inline-word ] each ] [ ] make fold-constants ;
: (flatten) ( quot -- )
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
: retain-stack-overflow? ( error -- ? )
{ "kernel-error" 14 f f } = ;
: flatten ( quot -- expanded )
[ [ (flatten) ] [ ] make ] [
dup retain-stack-overflow?
[ drop "No inverse defined on recursive word" ] when
throw
] recover ;
GENERIC: inverse ( revquot word -- revquot* quot )
M: object inverse undo-literal ;
M: symbol inverse undo-literal ;
M: word inverse drop "Inverse is undefined" throw ;
M: normal-inverse inverse
"inverse" word-prop ;
@ -109,7 +115,7 @@ M: pop-inverse inverse
[ unclip-slice inverse % (undo) ] if ;
: [undo] ( quot -- undo )
do-inlining reverse [ (undo) ] [ ] make ;
flatten fold reverse [ (undo) ] [ ] make ;
MACRO: undo ( quot -- ) [undo] ;

View File

@ -15,9 +15,7 @@ IN: units.tests
[ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test
[ t ] [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test
! I want these to work, Dan
: km/L km 1 L d/ ;
: mpg miles 1 gallons d/ ;
! [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test

View File

@ -95,3 +95,9 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
: d-infimum ( v -- d ) unclip-slice [ d-min ] reduce ;
: d-supremum ( v -- d ) unclip-slice [ d-max ] reduce ;
\ d+ [ d- ] [ d- ] define-math-inverse
\ d- [ d+ ] [ d- ] define-math-inverse
\ d* [ d/ ] [ d/ ] define-math-inverse
\ d/ [ d* ] [ d/ ] define-math-inverse
\ d-recip [ d-recip ] define-inverse