Remove more redundant branches from tuple type predicates and generic words with methods on tuple classes
parent
591d305d40
commit
a95bb533b5
|
@ -90,20 +90,29 @@ ERROR: bad-superclass class ;
|
||||||
2drop f
|
2drop f
|
||||||
] if ; inline
|
] if ; inline
|
||||||
|
|
||||||
|
: tuple-instance-1? ( object class -- ? )
|
||||||
|
swap dup tuple? [
|
||||||
|
layout-of 7 slot eq?
|
||||||
|
] [ 2drop f ] if ; inline
|
||||||
|
|
||||||
: tuple-instance? ( object class offset -- ? )
|
: tuple-instance? ( object class offset -- ? )
|
||||||
#! 4 slot == superclasses>>
|
|
||||||
rot dup tuple? [
|
rot dup tuple? [
|
||||||
layout-of
|
layout-of
|
||||||
2dup 1 slot fixnum<=
|
2dup 1 slot fixnum<=
|
||||||
[ swap slot eq? ] [ 3drop f ] if
|
[ swap slot eq? ] [ 3drop f ] if
|
||||||
] [ 3drop f ] if ; inline
|
] [ 3drop f ] if ; inline
|
||||||
|
|
||||||
: layout-class-offset ( class -- n )
|
: layout-class-offset ( echelon -- n )
|
||||||
tuple-layout third 2 * 5 + ;
|
2 * 5 + ;
|
||||||
|
|
||||||
|
: echelon-of ( class -- n )
|
||||||
|
tuple-layout third ;
|
||||||
|
|
||||||
: define-tuple-predicate ( class -- )
|
: define-tuple-predicate ( class -- )
|
||||||
dup dup layout-class-offset
|
dup dup echelon-of {
|
||||||
[ tuple-instance? ] 2curry define-predicate ;
|
{ 1 [ [ tuple-instance-1? ] curry ] }
|
||||||
|
[ layout-class-offset [ tuple-instance? ] 2curry ]
|
||||||
|
} case define-predicate ;
|
||||||
|
|
||||||
: class-size ( class -- n )
|
: class-size ( class -- n )
|
||||||
superclasses [ "slots" word-prop length ] sigma ;
|
superclasses [ "slots" word-prop length ] sigma ;
|
||||||
|
@ -292,7 +301,7 @@ M: tuple-class reset-class
|
||||||
M: tuple-class rank-class drop 0 ;
|
M: tuple-class rank-class drop 0 ;
|
||||||
|
|
||||||
M: tuple-class instance?
|
M: tuple-class instance?
|
||||||
dup layout-class-offset tuple-instance? ;
|
dup echelon-of layout-class-offset tuple-instance? ;
|
||||||
|
|
||||||
M: tuple-class (flatten-class) dup set ;
|
M: tuple-class (flatten-class) dup set ;
|
||||||
|
|
||||||
|
|
|
@ -48,10 +48,14 @@ TUPLE: tuple-dispatch-engine echelons ;
|
||||||
\ <tuple-dispatch-engine> convert-methods ;
|
\ <tuple-dispatch-engine> convert-methods ;
|
||||||
|
|
||||||
M: trivial-tuple-dispatch-engine engine>quot
|
M: trivial-tuple-dispatch-engine engine>quot
|
||||||
[
|
[ n>> ] [ methods>> ] bi dup assoc-empty? [
|
||||||
[ n>> nth-superclass% ]
|
2drop default get [ drop ] prepend
|
||||||
[ methods>> engines>quots* linear-dispatch-quot % ] bi
|
] [
|
||||||
] [ ] make ;
|
[
|
||||||
|
[ nth-superclass% ]
|
||||||
|
[ engines>quots* linear-dispatch-quot % ] bi*
|
||||||
|
] [ ] make
|
||||||
|
] if ;
|
||||||
|
|
||||||
: hash-methods ( n methods -- buckets )
|
: hash-methods ( n methods -- buckets )
|
||||||
>alist V{ } clone [ hashcode 1array ] distribute-buckets
|
>alist V{ } clone [ hashcode 1array ] distribute-buckets
|
||||||
|
@ -119,11 +123,19 @@ M: echelon-dispatch-engine engine>quot
|
||||||
] assoc-map
|
] assoc-map
|
||||||
alist>quot ;
|
alist>quot ;
|
||||||
|
|
||||||
|
: simplify-echelon-alist ( default alist -- default' alist' )
|
||||||
|
dup empty? [
|
||||||
|
dup first first 1 <= [
|
||||||
|
nip unclip second swap
|
||||||
|
simplify-echelon-alist
|
||||||
|
] when
|
||||||
|
] unless ;
|
||||||
|
|
||||||
: echelon-case-quot ( alist -- quot )
|
: echelon-case-quot ( alist -- quot )
|
||||||
#! We don't have to test for echelon 1 since all tuple
|
#! We don't have to test for echelon 1 since all tuple
|
||||||
#! classes are at least at depth 1 in the inheritance
|
#! classes are at least at depth 1 in the inheritance
|
||||||
#! hierarchy.
|
#! hierarchy.
|
||||||
dup first first 1 = [ unclip second ] [ default get ] if swap
|
default get swap simplify-echelon-alist
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
picker %
|
picker %
|
||||||
|
@ -140,8 +152,11 @@ M: tuple-dispatch-engine engine>quot
|
||||||
echelons>> unclip-last
|
echelons>> unclip-last
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
engine>quot define-engine-word
|
engine>quot
|
||||||
[ remember-engine ] [ 1quotation ] bi
|
over 0 = [
|
||||||
|
define-engine-word
|
||||||
|
[ remember-engine ] [ 1quotation ] bi
|
||||||
|
] unless
|
||||||
dup default set
|
dup default set
|
||||||
] assoc-map
|
] assoc-map
|
||||||
]
|
]
|
||||||
|
|
Loading…
Reference in New Issue