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

Fix performance problem

db4
Slava Pestov 2008-10-20 05:56:13 -05:00
parent a4f1d4f243
commit ab61e5cd8c
1 changed files with 12 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -102,8 +102,8 @@ ERROR: bad-superclass class ;
dup dup tuple-layout echelon>> dup dup tuple-layout echelon>>
[ tuple-instance? ] 2curry define-predicate ; [ tuple-instance? ] 2curry define-predicate ;
: superclass-size ( class -- n ) : class-size ( class -- n )
superclasses but-last [ "slots" word-prop length ] sigma ; superclasses [ "slots" word-prop length ] sigma ;
: (instance-check-quot) ( class -- quot ) : (instance-check-quot) ( class -- quot )
[ [
@ -138,16 +138,12 @@ ERROR: bad-superclass class ;
: define-tuple-prototype ( class -- ) : define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ; dup tuple-prototype "prototype" set-word-prop ;
: finalize-tuple-slots ( class slots -- slots )
swap superclass-size 2 + finalize-slots ;
: define-tuple-slots ( class -- ) : define-tuple-slots ( class -- )
dup dup "slots" word-prop finalize-tuple-slots dup "slots" word-prop define-accessors ;
define-accessors ;
: make-tuple-layout ( class -- layout ) : make-tuple-layout ( class -- layout )
[ ] [ ]
[ [ superclass-size ] [ "slots" word-prop length ] bi + ] [ [ superclass class-size ] [ "slots" word-prop length ] bi + ]
[ superclasses dup length 1- ] tri [ superclasses dup length 1- ] tri
<tuple-layout> ; <tuple-layout> ;
@ -208,7 +204,6 @@ M: tuple-class update-class
} cleave ; } cleave ;
: define-new-tuple-class ( class superclass slots -- ) : define-new-tuple-class ( class superclass slots -- )
make-slots
[ drop f f tuple-class define-class ] [ drop f f tuple-class define-class ]
[ nip "slots" set-word-prop ] [ nip "slots" set-word-prop ]
[ 2drop update-classes ] [ 2drop update-classes ]
@ -241,16 +236,19 @@ M: tuple-class update-class
: check-superclass ( superclass -- ) : check-superclass ( superclass -- )
dup valid-superclass? [ bad-superclass ] unless drop ; dup valid-superclass? [ bad-superclass ] unless drop ;
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
PRIVATE> PRIVATE>
GENERIC# define-tuple-class 2 ( class superclass slots -- ) : define-tuple-class ( class superclass slots -- )
M: word define-tuple-class
over check-superclass over check-superclass
make-slots over class-size 2 + finalize-slots
(define-tuple-class) ;
M: word (define-tuple-class)
define-new-tuple-class ; define-new-tuple-class ;
M: tuple-class define-tuple-class M: tuple-class (define-tuple-class)
over check-superclass
3dup tuple-class-unchanged? 3dup tuple-class-unchanged?
[ 3drop ] [ redefine-tuple-class ] if ; [ 3drop ] [ redefine-tuple-class ] if ;