78 lines
		
	
	
		
			1.8 KiB
		
	
	
	
		
			Factor
		
	
	
			
		
		
	
	
			78 lines
		
	
	
		
			1.8 KiB
		
	
	
	
		
			Factor
		
	
	
! Copyright (C) 2008 Slava Pestov.
 | 
						|
! See http://factorcode.org/license.txt for BSD license.
 | 
						|
USING: functors sequences sequences.private prettyprint.custom
 | 
						|
kernel words classes math parser alien.c-types byte-arrays
 | 
						|
accessors summary ;
 | 
						|
IN: specialized-arrays.functor
 | 
						|
 | 
						|
ERROR: bad-byte-array-length byte-array type ;
 | 
						|
 | 
						|
M: bad-byte-array-length summary
 | 
						|
    drop "Byte array length doesn't divide type width" ;
 | 
						|
 | 
						|
: (c-array) ( n c-type -- array )
 | 
						|
    heap-size * (byte-array) ; inline
 | 
						|
 | 
						|
FUNCTOR: define-array ( T -- )
 | 
						|
 | 
						|
A            DEFINES-CLASS ${T}-array
 | 
						|
<A>          DEFINES <${A}>
 | 
						|
(A)          DEFINES (${A})
 | 
						|
>A           DEFINES >${A}
 | 
						|
byte-array>A DEFINES byte-array>${A}
 | 
						|
A{           DEFINES ${A}{
 | 
						|
 | 
						|
NTH          [ T dup c-type-getter-boxer array-accessor ]
 | 
						|
SET-NTH      [ T dup c-setter array-accessor ]
 | 
						|
 | 
						|
WHERE
 | 
						|
 | 
						|
TUPLE: A
 | 
						|
{ length array-capacity read-only }
 | 
						|
{ underlying byte-array read-only } ;
 | 
						|
 | 
						|
: <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
 | 
						|
 | 
						|
: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline
 | 
						|
 | 
						|
: byte-array>A ( byte-array -- specialized-array )
 | 
						|
    dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
 | 
						|
    swap A boa ; inline
 | 
						|
 | 
						|
M: A clone [ length>> ] [ underlying>> clone ] bi A boa ;
 | 
						|
 | 
						|
M: A length length>> ;
 | 
						|
 | 
						|
M: A nth-unsafe underlying>> NTH call ;
 | 
						|
 | 
						|
M: A set-nth-unsafe underlying>> SET-NTH call ;
 | 
						|
 | 
						|
: >A ( seq -- specialized-array ) A new clone-like ; inline
 | 
						|
 | 
						|
M: A like drop dup A instance? [ >A ] unless ;
 | 
						|
 | 
						|
M: A new-sequence drop (A) ;
 | 
						|
 | 
						|
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
 | 
						|
 | 
						|
M: A resize
 | 
						|
    [ drop ] [
 | 
						|
        [ T heap-size * ] [ underlying>> ] bi*
 | 
						|
        resize-byte-array
 | 
						|
    ] 2bi
 | 
						|
    A boa ;
 | 
						|
 | 
						|
M: A byte-length underlying>> length ;
 | 
						|
 | 
						|
M: A pprint-delims drop \ A{ \ } ;
 | 
						|
 | 
						|
M: A >pprint-sequence ;
 | 
						|
 | 
						|
M: A pprint* pprint-object ;
 | 
						|
 | 
						|
SYNTAX: A{ \ } [ >A ] parse-literal ;
 | 
						|
 | 
						|
INSTANCE: A sequence
 | 
						|
 | 
						|
;FUNCTOR
 |