steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
core/classes/tuple/tuple.factor
View File

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

25
core/generic/standard/engines/tuple/tuple.factor
View File

@ -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? [
2drop default get [ drop ] prepend
] [
[ [
[ n>> nth-superclass% ] [ nth-superclass% ]
[ methods>> engines>quots* linear-dispatch-quot % ] bi [ engines>quots* linear-dispatch-quot % ] bi*
] [ ] make ; ] [ ] 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
over 0 = [
define-engine-word
[ remember-engine ] [ 1quotation ] bi [ remember-engine ] [ 1quotation ] bi
] unless
dup default set dup default set
] assoc-map ] assoc-map
] ]