cords: updated functors syntax. ugly.
Doug Coleman
parent
7ccaf78071
commit
233c3dcebd
|
|
@ -2,86 +2,67 @@ USING: accessors alien.c-types arrays byte-arrays
|
|||
cpu.architecture effects functors generalizations kernel lexer
|
||||
math math.vectors.simd math.vectors.simd.intrinsics parser
|
||||
prettyprint.custom quotations sequences sequences.cords words
|
||||
classes ;
|
||||
classes functors2 literals ;
|
||||
IN: math.vectors.simd.cords
|
||||
|
||||
<<
|
||||
<PRIVATE
|
||||
SAME-FUNCTOR: simd-128-cord ( type/2: existing-word type: name -- ) [[
|
||||
|
||||
<FUNCTOR: (define-simd-128-cord) ( A/2 A -- )
|
||||
DEFER: ${type}
|
||||
<<
|
||||
SPECIALIZED-CORD: ${type/2} ${type}
|
||||
>>
|
||||
|
||||
A-rep IS ${A/2}-rep
|
||||
>A/2 IS >${A/2}
|
||||
A/2-boa IS ${A/2}-boa
|
||||
A/2-with IS ${A/2}-with
|
||||
A/2-cast IS ${A/2}-cast
|
||||
<<
|
||||
<c-type>
|
||||
byte-array >>class
|
||||
${type} >>boxed-class
|
||||
[
|
||||
[ ${type/2}-rep alien-vector ${type/2} boa ]
|
||||
[ 16 + ${type/2}-rep alien-vector ${type/2} boa ] 2bi cord-append
|
||||
] >>getter
|
||||
[
|
||||
[ [ head>> underlying>> ] 2dip ${type/2}-rep set-alien-vector ]
|
||||
[ [ tail>> underlying>> ] 2dip 16 + ${type/2}-rep set-alien-vector ] 3bi
|
||||
] >>setter
|
||||
32 >>size
|
||||
16 >>align
|
||||
${type/2}-rep >>rep
|
||||
\ ${type} typedef
|
||||
>>
|
||||
|
||||
>A DEFINES >${A}
|
||||
A-boa DEFINES ${A}-boa
|
||||
A-with DEFINES ${A}-with
|
||||
A-cast DEFINES ${A}-cast
|
||||
A{ DEFINES ${A}{
|
||||
: >${type} ( seq -- ${type} )
|
||||
[ $[ ${type/2}-rep rep-length ] head-slice >${type/2} ]
|
||||
[ $[ ${type/2}-rep rep-length ] tail-slice >${type/2} ] bi cord-append ;
|
||||
|
||||
N [ A-rep rep-length ]
|
||||
BOA-EFFECT [ N 2 * "n" <array> { "v" } <effect> ]
|
||||
DEFER: ${type}-boa
|
||||
\ ${type}-boa
|
||||
{ $[ ${type/2}-rep rep-length ] ndip ${type/2}-boa cord-append } { ${type/2}-boa } >quotation prefix >quotation
|
||||
$[ $[ ${type/2}-rep rep-length ] 2 * "n" <array> { "v" } <effect> ] define-inline
|
||||
|
||||
WHERE
|
||||
: ${type}-with ( n -- v )
|
||||
[ ${type/2}-with ] [ ${type/2}-with ] bi cord-append ; inline
|
||||
|
||||
: >A ( seq -- A )
|
||||
[ N head-slice >A/2 ]
|
||||
[ N tail-slice >A/2 ] bi cord-append ;
|
||||
: ${type}-cast ( v -- v' )
|
||||
[ ${type/2}-cast ] cord-map ; inline
|
||||
|
||||
\ A-boa
|
||||
{ N ndip A/2-boa cord-append } { A/2-boa } >quotation prefix >quotation
|
||||
BOA-EFFECT define-inline
|
||||
M: ${type} new-sequence
|
||||
2drop
|
||||
$[ ${type/2}-rep rep-length ] ${type/2} new new-sequence
|
||||
$[ ${type/2}-rep rep-length ] ${type/2} new new-sequence
|
||||
\ ${type} boa ;
|
||||
|
||||
: A-with ( n -- v )
|
||||
[ A/2-with ] [ A/2-with ] bi cord-append ; inline
|
||||
M: ${type} like
|
||||
over \ ${type} instance? [ drop ] [ call-next-method ] if ;
|
||||
|
||||
: A-cast ( v -- v' )
|
||||
[ A/2-cast ] cord-map ; inline
|
||||
M: ${type} >pprint-sequence ;
|
||||
M: ${type} pprint* pprint-object ;
|
||||
|
||||
M: A new-sequence
|
||||
2drop
|
||||
N A/2 new new-sequence
|
||||
N A/2 new new-sequence
|
||||
\ A boa ;
|
||||
|
||||
M: A like
|
||||
over \ A instance? [ drop ] [ call-next-method ] if ;
|
||||
|
||||
M: A >pprint-sequence ;
|
||||
M: A pprint* pprint-object ;
|
||||
|
||||
M: A pprint-delims drop \ A{ \ } ;
|
||||
SYNTAX: A{ \ } [ >A ] parse-literal ;
|
||||
|
||||
<c-type>
|
||||
byte-array >>class
|
||||
A >>boxed-class
|
||||
[
|
||||
[ A-rep alien-vector A/2 boa ]
|
||||
[ 16 + A-rep alien-vector A/2 boa ] 2bi cord-append
|
||||
] >>getter
|
||||
[
|
||||
[ [ head>> underlying>> ] 2dip A-rep set-alien-vector ]
|
||||
[ [ tail>> underlying>> ] 2dip 16 + A-rep set-alien-vector ] 3bi
|
||||
] >>setter
|
||||
32 >>size
|
||||
16 >>align
|
||||
A-rep >>rep
|
||||
\ A typedef
|
||||
|
||||
;FUNCTOR>
|
||||
|
||||
: define-simd-128-cord ( A/2 T -- )
|
||||
[ define-specialized-cord ]
|
||||
[ create-word-in (define-simd-128-cord) ] 2bi ;
|
||||
|
||||
SYNTAX: \SIMD-128-CORD:
|
||||
scan-word scan-token define-simd-128-cord ;
|
||||
|
||||
PRIVATE>
|
||||
<<
|
||||
SYNTAX: ${type}{ \ } [ >${type} ] parse-literal ;
|
||||
>>
|
||||
M: ${type} pprint-delims drop \ ${type}{ \ } ;
|
||||
]]
|
||||
>>
|
||||
|
||||
SIMD-128-CORD: char-16 char-32
|
||||
|
|
|
|||
|
|
@ -328,7 +328,6 @@ DEFER: ${type}-boa
|
|||
|
||||
<<
|
||||
\ ${type}-boa
|
||||
! [ $[ ${type}-rep rep-component-type c:c-type-class "coercer" word-prop [ ] or ] $[ ${type}-rep rep-length ] napply ] ${type}-rep rep-length {
|
||||
[ $[ ${type}-coercer ] $[ ${type}-rep rep-length ] napply ] ${type}-rep rep-length {
|
||||
{ 2 [ [ ${type}-rep (simd-gather-2) ${type} boa ] ] }
|
||||
{ 4 [ [ ${type}-rep (simd-gather-4) ${type} boa ] ] }
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs sequences sorting binary-search fry math
|
||||
math.order arrays classes combinators kernel functors locals
|
||||
math.functions math.vectors ;
|
||||
math.functions math.vectors functors2 ;
|
||||
IN: sequences.cords
|
||||
|
||||
MIXIN: cord
|
||||
|
|
@ -27,21 +27,18 @@ GENERIC: cord-append ( seq1 seq2 -- cord )
|
|||
M: object cord-append
|
||||
generic-cord boa ; inline
|
||||
|
||||
<FUNCTOR: define-specialized-cord ( T C -- )
|
||||
SAME-FUNCTOR: specialized-cord ( type: name class: name -- ) [[
|
||||
USING: kernel ;
|
||||
|
||||
T-cord DEFINES-CLASS ${C}
|
||||
TUPLE: ${class}
|
||||
{ head ${type} read-only } { tail ${type} read-only } ; final
|
||||
INSTANCE: ${class} cord
|
||||
|
||||
WHERE
|
||||
M: ${type} cord-append
|
||||
2dup [ ${type} instance? ] both?
|
||||
[ ${class} boa ] [ generic-cord boa ] if ; inline
|
||||
|
||||
TUPLE: T-cord
|
||||
{ head T read-only } { tail T read-only } ; final
|
||||
INSTANCE: T-cord cord
|
||||
|
||||
M: T cord-append
|
||||
2dup [ T instance? ] both?
|
||||
[ T-cord boa ] [ generic-cord boa ] if ; inline
|
||||
|
||||
;FUNCTOR>
|
||||
]]
|
||||
|
||||
: cord-map ( cord quot -- cord' )
|
||||
[ [ head>> ] dip call ]
|
||||
|
|
|
|||
Loading…
Reference in New Issue