: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
-[ f ] [
+[ t ] [
[ { bignum } declare annotate-entry-test-2 ]
\ annotate-entry-test-1 inlined?
] unit-test
+[ f ] [
+ [ { bignum } declare annotate-entry-test-2 ]
+ M\ fixnum annotate-entry-test-1 inlined?
+] unit-test
+
[ t ] [
[ { float } declare 10 [ 2.3 * ] times >float ]
\ >float inlined?
classes.algebra classes.union sets quotations assocs combinators
combinators.short-circuit words namespaces continuations classes
fry hints locals
+stack-checker.dependencies
compiler.tree
compiler.tree.builder
compiler.tree.recursive
ERROR: bad-splitting class generic ;
:: split-code ( class generic -- quot/f )
- class generic method-for-class
- [ class generic bad-splitting ] unless
+ class generic method-for-class :> method
+ method [ class generic bad-splitting ] unless
+ generic dispatch# (picker) :> picker
[
- dup class instance?
- [ generic execute ]
+ picker call class instance?
+ [ method execute ]
[ generic no-method ] if
] ;
-:: find-method-call ( class generic -- subclass/f )
- generic method-classes [ f ] [
- f swap [| last-class new-class |
- class new-class classes-intersect? [
- last-class [ f f ] [ new-class t ] if
- ] [ last-class t ] if
- ] all? swap and
- ] if-empty ;
-
:: split-method-call ( class generic -- quot/f )
- class generic find-method-call
- [ generic split-code ] [ f ] if* ;
+ class generic subclass-with-only-method [
+ class generic depends-on-single-method
+ generic split-code
+ ] [ f ] if* ;
: inlining-standard-method ( #call word -- class/f method/f )
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
hashtables classes assocs locals specialized-arrays system
sorting math.libm math.floats.private math.integers.private
math.intervals quotations effects alien alien.data sets
-strings.private ;
+strings.private classes.tuple ;
FROM: math => float ;
SPECIALIZED-ARRAY: double
SPECIALIZED-ARRAY: void*
GENERIC: whatever ( x -- y )
M: number whatever drop foo ; inline
-[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
+[ t ] [ [ 1 whatever new ] { new } M\ tuple-class new suffix inlined? ] unit-test
: that-thing ( -- class ) foo ;
-[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
+[ f ] [ [ that-thing new ] { new } M\ tuple-class new suffix inlined? ] unit-test
GENERIC: whatever2 ( x -- y )
M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs accessors classes classes.algebra fry
generic kernel math namespaces sequences words sets
-combinators.short-circuit classes.tuple alien.c-types ;
+combinators.short-circuit classes.tuple alien.c-types
+locals ;
FROM: classes.tuple.private => tuple-layout ;
FROM: assocs => change-at ;
FROM: namespaces => set ;
M: depends-on-final satisfied?
class>> { [ class? ] [ final-class? ] } 1&& ;
+TUPLE: depends-on-single-method class generic ;
+
+: depends-on-single-method ( class generic -- )
+ [ nip depends-on-conditionally ]
+ [ \ depends-on-single-method add-conditional-dependency ] 2bi ;
+
+:: subclass-with-only-method ( class generic -- subclass/f )
+ generic method-classes [ f ] [
+ f swap [| last-class new-class |
+ class new-class classes-intersect? [
+ last-class [ f f ] [ new-class t ] if
+ ] [ last-class t ] if
+ ] all? swap and
+ ] if-empty ;
+
+M: depends-on-single-method satisfied?
+ [ class>> ] [ generic>> ] bi subclass-with-only-method >boolean ;
+
: init-dependencies ( -- )
H{ } clone dependencies set
H{ } clone generic-dependencies set