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

compiler.tree.finalization: record dependencies on inlined predicates

db4
Slava Pestov 2010-07-23 16:31:15 -07:00
parent b0ec82c64e
commit c04de94b96
2 changed files with 13 additions and 3 deletions
basis/compiler/tree/finalization
core/classes/tuple

10
basis/compiler/tree/finalization/finalization.factor
View File

@ -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 ;

6
core/classes/tuple/tuple-tests.factor
View File

@ -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