Remove more redundant branches from tuple type predicates and generic words with methods on tuple classes

db4
Slava Pestov 2008-11-06 09:08:17 -06:00
parent 591d305d40
commit a95bb533b5
2 changed files with 37 additions and 13 deletions

View File

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

View File

@ -48,10 +48,14 @@ TUPLE: tuple-dispatch-engine echelons ;
\ <tuple-dispatch-engine> convert-methods ;
M: trivial-tuple-dispatch-engine engine>quot
[ n>> ] [ methods>> ] bi dup assoc-empty? [
2drop default get [ drop ] prepend
] [
[
[ n>> nth-superclass% ]
[ methods>> engines>quots* linear-dispatch-quot % ] bi
] [ ] make ;
[ 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
engine>quot
over 0 = [
define-engine-word
[ remember-engine ] [ 1quotation ] bi
] unless
dup default set
] assoc-map
]