Fix performance problem
							parent
							
								
									a4f1d4f243
								
							
						
					
					
						commit
						ab61e5cd8c
					
				| 
						 | 
				
			
			@ -102,8 +102,8 @@ ERROR: bad-superclass class ;
 | 
			
		|||
    dup dup tuple-layout echelon>>
 | 
			
		||||
    [ tuple-instance? ] 2curry define-predicate ;
 | 
			
		||||
 | 
			
		||||
: superclass-size ( class -- n )
 | 
			
		||||
    superclasses but-last [ "slots" word-prop length ] sigma ;
 | 
			
		||||
: class-size ( class -- n )
 | 
			
		||||
    superclasses [ "slots" word-prop length ] sigma ;
 | 
			
		||||
 | 
			
		||||
: (instance-check-quot) ( class -- quot )
 | 
			
		||||
    [
 | 
			
		||||
| 
						 | 
				
			
			@ -138,16 +138,12 @@ ERROR: bad-superclass class ;
 | 
			
		|||
: define-tuple-prototype ( class -- )
 | 
			
		||||
    dup tuple-prototype "prototype" set-word-prop ;
 | 
			
		||||
 | 
			
		||||
: finalize-tuple-slots ( class slots -- slots )
 | 
			
		||||
    swap superclass-size 2 + finalize-slots ;
 | 
			
		||||
 | 
			
		||||
: define-tuple-slots ( class -- )
 | 
			
		||||
    dup dup "slots" word-prop finalize-tuple-slots
 | 
			
		||||
    define-accessors ;
 | 
			
		||||
    dup "slots" word-prop define-accessors ;
 | 
			
		||||
 | 
			
		||||
: 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
 | 
			
		||||
    <tuple-layout> ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			@ -208,7 +204,6 @@ M: tuple-class update-class
 | 
			
		|||
    } cleave ;
 | 
			
		||||
 | 
			
		||||
: define-new-tuple-class ( class superclass slots -- )
 | 
			
		||||
    make-slots
 | 
			
		||||
    [ drop f f tuple-class define-class ]
 | 
			
		||||
    [ nip "slots" set-word-prop ]
 | 
			
		||||
    [ 2drop update-classes ]
 | 
			
		||||
| 
						 | 
				
			
			@ -241,16 +236,19 @@ M: tuple-class update-class
 | 
			
		|||
: check-superclass ( superclass -- )
 | 
			
		||||
    dup valid-superclass? [ bad-superclass ] unless drop ;
 | 
			
		||||
 | 
			
		||||
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
 | 
			
		||||
 | 
			
		||||
PRIVATE>
 | 
			
		||||
 | 
			
		||||
GENERIC# define-tuple-class 2 ( class superclass slots -- )
 | 
			
		||||
 | 
			
		||||
M: word define-tuple-class
 | 
			
		||||
: define-tuple-class ( class superclass slots -- )
 | 
			
		||||
    over check-superclass
 | 
			
		||||
    make-slots over class-size 2 + finalize-slots
 | 
			
		||||
    (define-tuple-class) ;
 | 
			
		||||
 | 
			
		||||
M: word (define-tuple-class)
 | 
			
		||||
    define-new-tuple-class ;
 | 
			
		||||
 | 
			
		||||
M: tuple-class define-tuple-class
 | 
			
		||||
    over check-superclass
 | 
			
		||||
M: tuple-class (define-tuple-class)
 | 
			
		||||
    3dup tuple-class-unchanged?
 | 
			
		||||
    [ 3drop ] [ redefine-tuple-class ] if ;
 | 
			
		||||
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
		Reference in New Issue