compiler.tree.finalization: record dependencies on inlined predicates
parent
b0ec82c64e
commit
c04de94b96
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences words memoize combinators
|
||||
classes classes.builtin classes.tuple classes.singleton
|
||||
math.partial-dispatch fry assocs combinators.short-circuit
|
||||
stack-checker.dependencies
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
@ -26,6 +27,9 @@ GENERIC: finalize* ( node -- nodes )
|
|||
|
||||
: splice-final ( quot -- nodes ) splice-quot finalize ;
|
||||
|
||||
: splice-predicate ( word -- nodes )
|
||||
[ depends-on-definition ] [ def>> splice-final ] bi ;
|
||||
|
||||
M: #copy finalize* drop f ;
|
||||
|
||||
M: #shuffle finalize*
|
||||
|
@ -44,8 +48,8 @@ GENERIC: finalize-word ( #call word -- nodes )
|
|||
M: predicate finalize-word
|
||||
"predicating" word-prop {
|
||||
{ [ dup builtin-class? ] [ drop word>> cached-expansion ] }
|
||||
{ [ dup tuple-class? ] [ drop word>> def>> splice-final ] }
|
||||
{ [ dup singleton-class? ] [ drop word>> def>> splice-final ] }
|
||||
{ [ dup tuple-class? ] [ drop word>> splice-predicate ] }
|
||||
{ [ dup singleton-class? ] [ drop word>> splice-predicate ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
|
|
|
@ -273,8 +273,14 @@ test-server-slot-values
|
|||
! Dynamically changing inheritance hierarchy
|
||||
TUPLE: electronic-device ;
|
||||
|
||||
: computer?' ( a -- b ) computer? ;
|
||||
|
||||
[ t ] [ laptop new computer?' ] unit-test
|
||||
|
||||
[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
|
||||
|
||||
[ t ] [ laptop new computer?' ] unit-test
|
||||
|
||||
[ f ] [ electronic-device laptop class<= ] unit-test
|
||||
[ t ] [ server electronic-device class<= ] unit-test
|
||||
[ t ] [ laptop server class-or electronic-device class<= ] unit-test
|
||||
|
|
Loading…
Reference in New Issue