specialized-arrays: Works as a new functor!!
Doug Coleman
parent
f8c54fd2bf
commit
384ffc1025
|
|
@ -144,7 +144,7 @@ M: struct-class initial-value* <struct> t ; inline
|
|||
GENERIC: struct-slot-values ( struct -- sequence )
|
||||
|
||||
M: struct-class reader-quot
|
||||
dup type>> array? [ dup type>> first define-array-vocab drop ] when
|
||||
dup type>> array? [ dup type>> first underlying-type define-specialized-array ] when
|
||||
nip '[ _ read-struct-slot ] ;
|
||||
|
||||
M: struct-class writer-quot
|
||||
|
|
|
|||
|
|
@ -4,12 +4,14 @@ USING: accessors alien alien.c-types alien.data alien.parser
|
|||
byte-arrays classes combinators fry functors kernel lexer locals
|
||||
make math math.vectors parser prettyprint.custom sequences
|
||||
sequences.private vocabs.generated vocabs.loader vocabs.parser
|
||||
words ;
|
||||
words math.parser arrays ;
|
||||
IN: specialized-arrays
|
||||
|
||||
MIXIN: specialized-array
|
||||
MIXIN: specialized-array2
|
||||
|
||||
INSTANCE: specialized-array sequence
|
||||
INSTANCE: specialized-array2 sequence
|
||||
|
||||
: (underlying) ( n c-type -- array )
|
||||
heap-size * (byte-array) ; inline
|
||||
|
|
@ -27,8 +29,7 @@ M: c-type-word underlying-type
|
|||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: pointer underlying-type
|
||||
drop void* ;
|
||||
M: pointer underlying-type drop void* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -38,84 +39,89 @@ GENERIC: direct-like ( alien len exemplar -- seq )
|
|||
M: byte-array nth-c-ptr <displaced-alien> ; inline
|
||||
M: byte-array direct-like drop uchar <c-direct-array> ; inline
|
||||
|
||||
<FUNCTOR: define-array ( T -- )
|
||||
PRIVATE>
|
||||
|
||||
A DEFINES-CLASS ${T}-array
|
||||
<A> DEFINES <${A}>
|
||||
(A) DEFINES (${A})
|
||||
<direct-A> DEFINES <direct-${A}>
|
||||
A{ DEFINES ${A}{
|
||||
VARIABLES-FUNCTOR: specialized-array ( T -- ) {
|
||||
{ "A" "${T}-array" }
|
||||
{ "<A>" "<${A}>" }
|
||||
{ "(A)" "(${A})" }
|
||||
{ "<direct-A>" "<direct-${A}>" }
|
||||
} [[
|
||||
USING: accessors alien alien.c-types alien.data byte-arrays
|
||||
classes kernel math math.vectors parser prettyprint.custom
|
||||
sequences sequences.private specialized-arrays
|
||||
specialized-arrays.private ;
|
||||
|
||||
WHERE
|
||||
|
||||
TUPLE: A
|
||||
<<
|
||||
TUPLE: ${A}
|
||||
{ underlying c-ptr read-only }
|
||||
{ length array-capacity read-only } ; final
|
||||
|
||||
: <direct-A> ( alien len -- specialized-array ) A boa ; inline
|
||||
INSTANCE: ${A} specialized-array2
|
||||
|
||||
M: A direct-like drop <direct-A> ; inline
|
||||
: ${<direct-A>} ( alien len -- specialized-array ) ${A} boa ; inline
|
||||
|
||||
: <A> ( n -- specialized-array )
|
||||
[ \ T <underlying> ] keep <direct-A> ; inline
|
||||
: ${<A>} ( n -- specialized-array )
|
||||
[ \ ${T} <underlying> ] keep ${<direct-A>} ; inline
|
||||
|
||||
: (A) ( n -- specialized-array )
|
||||
[ \ T (underlying) ] keep <direct-A> ; inline
|
||||
: ${(A)} ( n -- specialized-array )
|
||||
[ \ ${T} (underlying) ] keep ${<direct-A>} ; inline
|
||||
>>
|
||||
|
||||
M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
|
||||
SYNTAX: ${A}{ \ } [ \ ${T} >c-array ] parse-literal ;
|
||||
|
||||
M: A length length>> ; inline
|
||||
M: ${A} direct-like drop ${<direct-A>} ; inline
|
||||
|
||||
M: A nth-unsafe underlying>> \ T alien-element ; inline
|
||||
M: ${A} clone [ underlying>> clone ] [ length>> ] bi ${<direct-A>} ; inline
|
||||
|
||||
M: A nth-c-ptr underlying>> \ T array-accessor drop swap <displaced-alien> ; inline
|
||||
M: ${A} length length>> ; inline
|
||||
|
||||
M: A set-nth-unsafe underlying>> \ T set-alien-element ; inline
|
||||
M: ${A} nth-unsafe underlying>> \ ${T} alien-element ; inline
|
||||
|
||||
M: A like drop dup A instance? [ \ T >c-array ] unless ; inline
|
||||
M: ${A} nth-c-ptr underlying>> \ ${T} array-accessor drop swap <displaced-alien> ; inline
|
||||
|
||||
M: A new-sequence drop (A) ; inline
|
||||
M: ${A} set-nth-unsafe underlying>> \ ${T} set-alien-element ; inline
|
||||
|
||||
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
|
||||
M: ${A} like drop dup ${A} instance? [ \ ${T} >c-array ] unless ; inline
|
||||
|
||||
M: A resize
|
||||
M: ${A} new-sequence drop ${(A)} ; inline
|
||||
|
||||
M: ${A} equal? over ${A} instance? [ sequence= ] [ 2drop f ] if ;
|
||||
|
||||
M: ${A} resize
|
||||
[
|
||||
[ \ T heap-size * ] [ underlying>> ] bi*
|
||||
[ \ ${T} heap-size * ] [ underlying>> ] bi*
|
||||
resize-byte-array
|
||||
] [ drop ] 2bi
|
||||
<direct-A> ; inline
|
||||
${<direct-A>} ; inline
|
||||
|
||||
M: A element-size drop \ T heap-size ; inline
|
||||
M: ${A} element-size drop \ ${T} heap-size ; inline
|
||||
|
||||
M: A underlying-type drop \ T ;
|
||||
M: ${A} underlying-type drop \ ${T} ;
|
||||
|
||||
M: A pprint-delims drop \ A{ \ } ;
|
||||
M: ${A} pprint-delims drop \ ${A}{ \ } ;
|
||||
|
||||
M: A >pprint-sequence ;
|
||||
M: ${A} >pprint-sequence ;
|
||||
|
||||
SYNTAX: A{ \ } [ \ T >c-array ] parse-literal ;
|
||||
M: ${A} vs+ [ + \ ${T} c-type-clamp ] 2map ; inline
|
||||
M: ${A} vs- [ - \ ${T} c-type-clamp ] 2map ; inline
|
||||
M: ${A} vs* [ * \ ${T} c-type-clamp ] 2map ; inline
|
||||
|
||||
INSTANCE: A specialized-array
|
||||
|
||||
M: A vs+ [ + \ T c-type-clamp ] 2map ; inline
|
||||
M: A vs- [ - \ T c-type-clamp ] 2map ; inline
|
||||
M: A vs* [ * \ T c-type-clamp ] 2map ; inline
|
||||
|
||||
M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
|
||||
|
||||
;FUNCTOR>
|
||||
M: ${A} v*high [ * \ ${T} heap-size neg shift ] 2map ; inline
|
||||
]]
|
||||
|
||||
<PRIVATE
|
||||
: specialized-array-vocab ( c-type -- vocab )
|
||||
[
|
||||
"specialized-arrays.instances." %
|
||||
[ vocabulary>> % "." % ]
|
||||
[ name>> % ]
|
||||
bi
|
||||
"specialized-arrays:functors:specialized-array:" %
|
||||
! [ vocabulary>> % "." % ]
|
||||
! [ name>> % ":" % ]
|
||||
[ drop ]
|
||||
[ 1array hashcode number>string % ] bi
|
||||
] "" make ;
|
||||
|
||||
:: direct-slice-unsafe ( from to seq -- seq' )
|
||||
from seq nth-c-ptr to from - seq direct-like ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: direct-slice ( from to seq -- seq' )
|
||||
|
|
@ -126,11 +132,6 @@ PRIVATE>
|
|||
: direct-head* ( seq n -- seq' ) from-end direct-head ; inline
|
||||
: direct-tail* ( seq n -- seq' ) from-end direct-tail ; inline
|
||||
|
||||
: define-array-vocab ( type -- vocab )
|
||||
underlying-type
|
||||
[ specialized-array-vocab ] [ '[ _ define-array ] ] bi
|
||||
generate-vocab ;
|
||||
|
||||
ERROR: specialized-array-vocab-not-loaded c-type ;
|
||||
|
||||
M: c-type-word c-array-constructor
|
||||
|
|
@ -169,13 +170,10 @@ M: c-type-word c-array-type?
|
|||
M: pointer c-array-type? drop void* c-array-type? ;
|
||||
|
||||
SYNTAX: \SPECIALIZED-ARRAYS:
|
||||
";" [ parse-c-type define-array-vocab use-vocab ] each-token ;
|
||||
";" [ parse-c-type define-specialized-array ] each-token ;
|
||||
|
||||
SYNTAX: \SPECIALIZED-ARRAY:
|
||||
scan-c-type define-array-vocab use-vocab ;
|
||||
! { "specialized-arrays" "prettyprint" } "specialized-arrays.prettyprint" require-when
|
||||
|
||||
{ "specialized-arrays" "prettyprint" } "specialized-arrays.prettyprint" require-when
|
||||
! { "specialized-arrays" "mirrors" } "specialized-arrays.mirrors" require-when
|
||||
|
||||
{ "specialized-arrays" "mirrors" } "specialized-arrays.mirrors" require-when
|
||||
|
||||
uchar define-array-vocab drop
|
||||
! uchar define-specialized-array
|
||||
|
|
|
|||
|
|
@ -79,13 +79,13 @@ PRIVATE>
|
|||
SYNTAX: \SPECIALIZED-VECTORS:
|
||||
";" [
|
||||
parse-c-type
|
||||
[ define-array-vocab use-vocab ]
|
||||
[ define-specialized-array use-vocab ]
|
||||
[ define-vector-vocab use-vocab ] bi
|
||||
] each-token ;
|
||||
|
||||
SYNTAX: \SPECIALIZED-VECTOR:
|
||||
scan-c-type
|
||||
[ define-array-vocab use-vocab ]
|
||||
[ define-specialized-array use-vocab ]
|
||||
[ define-vector-vocab use-vocab ] bi ;
|
||||
|
||||
{ "specialized-vectors" "mirrors" } "specialized-vectors.mirrors" require-when
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@ IN: specialized-arrays
|
|||
|
||||
ERROR: cannot-define-array-in-deployed-app type ;
|
||||
|
||||
: define-array-vocab ( type -- ) cannot-define-array-in-deployed-app ;
|
||||
: define-specialized-array ( type -- ) cannot-define-array-in-deployed-app ;
|
||||
|
|
|
|||
|
|
@ -32,6 +32,9 @@ ERROR: not-all-unique seq ;
|
|||
: functor-syntax-word-name ( word -- string )
|
||||
name>> >upper ":" append ;
|
||||
|
||||
: functor-word-name ( word -- string )
|
||||
name>> "-functor" append ;
|
||||
|
||||
: functor-instantiated-vocab-name ( functor-word parameters -- string )
|
||||
dupd
|
||||
'[
|
||||
|
|
@ -65,7 +68,7 @@ ERROR: not-all-unique seq ;
|
|||
! append the IN: and the FROM: quot generator and the functor code
|
||||
[
|
||||
append
|
||||
'[ @ over '[ _ <string-reader> _ parse-stream drop ] generate-vocab drop ]
|
||||
'[ @ over '[ _ <string-reader> _ parse-stream drop ] generate-vocab use-vocab ]
|
||||
] dip
|
||||
] 3tri ;
|
||||
|
||||
|
|
@ -100,7 +103,9 @@ ERROR: not-all-unique seq ;
|
|||
] 3bi ; inline
|
||||
|
||||
: make-functor-word ( word effect string -- )
|
||||
nip 1quotation ( -- string ) define-declared ;
|
||||
nip
|
||||
! [ functor-word-name ] dip
|
||||
1quotation ( -- string ) define-declared ;
|
||||
|
||||
: make-variable-functor ( word effect bindings string -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -8,11 +8,11 @@ IN: classes.struct.vectored
|
|||
<PRIVATE
|
||||
|
||||
: array-class-of ( type -- array-type )
|
||||
[ define-array-vocab ] [ name>> "-array" append swap lookup-word ] bi ;
|
||||
[ underlying-type define-specialized-array ] [ name>> "-array" append swap lookup-word ] bi ;
|
||||
: <array-class>-of ( type -- array-type )
|
||||
[ define-array-vocab ] [ name>> "<" "-array>" surround swap lookup-word ] bi ;
|
||||
[ underlying-type define-specialized-array ] [ name>> "<" "-array>" surround swap lookup-word ] bi ;
|
||||
: (array-class)-of ( type -- array-type )
|
||||
[ define-array-vocab ] [ name>> "(" "-array)" surround swap lookup-word ] bi ;
|
||||
[ underlying-type define-specialized-array ] [ name>> "(" "-array)" surround swap lookup-word ] bi ;
|
||||
|
||||
: >vectored-slot ( struct-slot offset -- tuple-slot )
|
||||
{
|
||||
|
|
|
|||
Loading…
Reference in New Issue