cords: updated functors syntax. ugly.

basis/math/vectors/simd/cords/cords.factor

@@ -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}
+    <c-type>
-A/2-boa  IS            ${A/2}-boa
-A/2-with IS            ${A/2}-with
-A/2-cast IS            ${A/2}-cast
-
->A     DEFINES       >${A}
-A-boa  DEFINES       ${A}-boa
-A-with DEFINES       ${A}-with
-A-cast DEFINES       ${A}-cast
-A{     DEFINES       ${A}{
-
-N       [ A-rep rep-length ]
-BOA-EFFECT [ N 2 * "n" <array> { "v" } <effect> ]
-
-WHERE
-
-: >A ( seq -- A )
-    [ N head-slice >A/2 ]
-    [ N tail-slice >A/2 ] bi cord-append ;
-
-\ A-boa
-{ N ndip A/2-boa cord-append } { A/2-boa } >quotation prefix >quotation
-BOA-EFFECT define-inline
-
-: A-with ( n -- v )
-    [ A/2-with ] [ A/2-with ] bi cord-append ; inline
-
-: A-cast ( v -- v' )
-    [ A/2-cast ] cord-map ; inline
-
-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
+        ${type} >>boxed-class
         [
-        [      A-rep alien-vector A/2 boa ]
+            [      ${type/2}-rep alien-vector ${type/2} boa ]
-        [ 16 + A-rep alien-vector A/2 boa ] 2bi cord-append
+            [ 16 + ${type/2}-rep alien-vector ${type/2} boa ] 2bi cord-append
         ] >>getter
         [
-        [ [ head>> underlying>> ] 2dip      A-rep set-alien-vector ]
+            [ [ head>> underlying>> ] 2dip      ${type/2}-rep set-alien-vector ]
-        [ [ tail>> underlying>> ] 2dip 16 + A-rep set-alien-vector ] 3bi
+            [ [ tail>> underlying>> ] 2dip 16 + ${type/2}-rep set-alien-vector ] 3bi
         ] >>setter
         32 >>size
         16 >>align
-    A-rep >>rep
+        ${type/2}-rep >>rep
-\ A typedef
+    \ ${type} typedef
+    >>
 
-;FUNCTOR>
+    : >${type} ( seq -- ${type} )
+        [ $[ ${type/2}-rep rep-length ] head-slice >${type/2} ]
+        [ $[ ${type/2}-rep rep-length ] tail-slice >${type/2} ] bi cord-append ;
 
-: define-simd-128-cord ( A/2 T -- )
+    DEFER: ${type}-boa
-    [ define-specialized-cord ]
+    \ ${type}-boa
-    [ create-word-in (define-simd-128-cord) ] 2bi ;
+    { $[ ${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
 
-SYNTAX: \SIMD-128-CORD:
+    : ${type}-with ( n -- v )
-    scan-word scan-token define-simd-128-cord ;
+        [ ${type/2}-with ] [ ${type/2}-with ] bi cord-append ; inline
 
-PRIVATE>
+    : ${type}-cast ( v -- v' )
+        [ ${type/2}-cast ] cord-map ; 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 ;
+
+    M: ${type} like
+        over \ ${type} instance? [ drop ] [ call-next-method ] if ;
+
+    M: ${type} >pprint-sequence ;
+    M: ${type} pprint* pprint-object ;
+
+    <<
+    SYNTAX: ${type}{ \ } [ >${type} ] parse-literal ;
+    >>
+    M: ${type} pprint-delims drop \ ${type}{ \ } ;
+]]
 >>
 
 SIMD-128-CORD: char-16     char-32

basis/math/vectors/simd/simd.factor

@@ -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 ] ] }

basis/sequences/cords/cords.factor

@@ -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 ]