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
|
||||
] if ; inline
|
||||
|
||||
: tuple-instance-1? ( object class -- ? )
|
||||
swap dup tuple? [
|
||||
layout-of 7 slot eq?
|
||||
] [ 2drop f ] if ; inline
|
||||
|
||||
: tuple-instance? ( object class offset -- ? )
|
||||
#! 4 slot == superclasses>>
|
||||
rot dup tuple? [
|
||||
layout-of
|
||||
2dup 1 slot fixnum<=
|
||||
[ swap slot eq? ] [ 3drop f ] if
|
||||
] [ 3drop f ] if ; inline
|
||||
|
||||
: layout-class-offset ( class -- n )
|
||||
tuple-layout third 2 * 5 + ;
|
||||
: layout-class-offset ( echelon -- n )
|
||||
2 * 5 + ;
|
||||
|
||||
: echelon-of ( class -- n )
|
||||
tuple-layout third ;
|
||||
|
||||
: define-tuple-predicate ( class -- )
|
||||
dup dup layout-class-offset
|
||||
[ tuple-instance? ] 2curry define-predicate ;
|
||||
dup dup echelon-of {
|
||||
{ 1 [ [ tuple-instance-1? ] curry ] }
|
||||
[ layout-class-offset [ tuple-instance? ] 2curry ]
|
||||
} case define-predicate ;
|
||||
|
||||
: class-size ( class -- n )
|
||||
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 instance?
|
||||
dup layout-class-offset tuple-instance? ;
|
||||
dup echelon-of layout-class-offset tuple-instance? ;
|
||||
|
||||
M: tuple-class (flatten-class) dup set ;
|
||||
|
||||
|
|
|
@ -48,10 +48,14 @@ TUPLE: tuple-dispatch-engine echelons ;
|
|||
\ <tuple-dispatch-engine> convert-methods ;
|
||||
|
||||
M: trivial-tuple-dispatch-engine engine>quot
|
||||
[
|
||||
[ n>> nth-superclass% ]
|
||||
[ methods>> engines>quots* linear-dispatch-quot % ] bi
|
||||
] [ ] make ;
|
||||
[ n>> ] [ methods>> ] bi dup assoc-empty? [
|
||||
2drop default get [ drop ] prepend
|
||||
] [
|
||||
[
|
||||
[ nth-superclass% ]
|
||||
[ engines>quots* linear-dispatch-quot % ] bi*
|
||||
] [ ] make
|
||||
] if ;
|
||||
|
||||
: hash-methods ( n methods -- buckets )
|
||||
>alist V{ } clone [ hashcode 1array ] distribute-buckets
|
||||
|
@ -119,11 +123,19 @@ M: echelon-dispatch-engine engine>quot
|
|||
] assoc-map
|
||||
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 )
|
||||
#! We don't have to test for echelon 1 since all tuple
|
||||
#! classes are at least at depth 1 in the inheritance
|
||||
#! hierarchy.
|
||||
dup first first 1 = [ unclip second ] [ default get ] if swap
|
||||
default get swap simplify-echelon-alist
|
||||
[
|
||||
[
|
||||
picker %
|
||||
|
@ -140,8 +152,11 @@ M: tuple-dispatch-engine engine>quot
|
|||
echelons>> unclip-last
|
||||
[
|
||||
[
|
||||
engine>quot define-engine-word
|
||||
[ remember-engine ] [ 1quotation ] bi
|
||||
engine>quot
|
||||
over 0 = [
|
||||
define-engine-word
|
||||
[ remember-engine ] [ 1quotation ] bi
|
||||
] unless
|
||||
dup default set
|
||||
] assoc-map
|
||||
]
|
||||
|
|
Loading…
Reference in New Issue