From c04de94b96d6c2929e89878d6cefe09c50b68419 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 23 Jul 2010 16:31:15 -0700 Subject: [PATCH] compiler.tree.finalization: record dependencies on inlined predicates --- basis/compiler/tree/finalization/finalization.factor | 10 +++++++--- core/classes/tuple/tuple-tests.factor | 6 ++++++ 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index fca35a5653..72ea22422b 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -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 ; diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 5aec400fbe..722cdd998a 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -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 C: laptop C: 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