factor: FUNCTOR: to FUNCTOR<

locals-and-roots
Doug Coleman 2016-06-20 12:59:00 -07:00
parent 6308848d19
commit 7a317a3bb8
22 changed files with 71 additions and 71 deletions

View File

@ -27,7 +27,7 @@ GENERIC: cord-append ( seq1 seq2 -- cord ) ;
M: object cord-append M: object cord-append
generic-cord boa ; inline generic-cord boa ; inline
FUNCTOR: define-specialized-cord ( T C -- ) FUNCTOR< define-specialized-cord ( T C -- )
T-cord DEFINES-CLASS ${C} T-cord DEFINES-CLASS ${C}
@ -41,7 +41,7 @@ M: T cord-append
2dup [ T instance? ] both? 2dup [ T instance? ] both?
[ T-cord boa ] [ generic-cord boa ] if ; inline [ T-cord boa ] [ generic-cord boa ] if ; inline
FUNCTOR; FUNCTOR>
: cord-map ( cord quot -- cord' ) : cord-map ( cord quot -- cord' )
[ [ head>> ] dip call ] [ [ head>> ] dip call ]

View File

@ -38,7 +38,7 @@ GENERIC: direct-like ( alien len exemplar -- seq ) ;
M: byte-array nth-c-ptr <displaced-alien> ; inline M: byte-array nth-c-ptr <displaced-alien> ; inline
M: byte-array direct-like drop uchar <c-direct-array> ; inline M: byte-array direct-like drop uchar <c-direct-array> ; inline
FUNCTOR: define-array ( T -- ) FUNCTOR< define-array ( T -- )
A DEFINES-CLASS ${T}-array A DEFINES-CLASS ${T}-array
<A> DEFINES <${A}> <A> DEFINES <${A}>
@ -103,7 +103,7 @@ M: A vs* [ * \ T c-type-clamp ] 2map ; inline
M: A v*high [ * \ T heap-size neg shift ] 2map ; inline M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
FUNCTOR; FUNCTOR>
: specialized-array-vocab ( c-type -- vocab ) : specialized-array-vocab ( c-type -- vocab )
[ [

View File

@ -13,7 +13,7 @@ mixin: specialized-vector
PRIVATE< PRIVATE<
FUNCTOR: define-vector ( T -- ) FUNCTOR< define-vector ( T -- )
V DEFINES-CLASS ${T}-vector V DEFINES-CLASS ${T}-vector
@ -56,7 +56,7 @@ SYNTAX: V{ \ } [ >V ] parse-literal ;
INSTANCE: V specialized-vector ; INSTANCE: V specialized-vector ;
INSTANCE: V growable ; INSTANCE: V growable ;
FUNCTOR; FUNCTOR>
: specialized-vector-vocab ( c-type -- vocab ) : specialized-vector-vocab ( c-type -- vocab )
[ [

View File

@ -4,7 +4,7 @@ USING: classes functors growable kernel math sequences
sequences.private ; sequences.private ;
in: vectors.functor in: vectors.functor
FUNCTOR: define-vector ( V A <A> -- ) FUNCTOR< define-vector ( V A <A> -- )
<V> DEFINES <${V}> <V> DEFINES <${V}>
>V DEFINES >${V} >V DEFINES >${V}
@ -32,4 +32,4 @@ M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
INSTANCE: V growable ; INSTANCE: V growable ;
FUNCTOR; FUNCTOR>

View File

@ -180,7 +180,7 @@ computer-name"
} }
{ $slide "Functor for sorting" { $slide "Functor for sorting"
{ $code { $code
"FUNCTOR: define-sorting ( NAME QUOT -- ) "FUNCTOR< define-sorting ( NAME QUOT -- )
NAME<=> DEFINES ${NAME}<=> NAME<=> DEFINES ${NAME}<=>
NAME>=< DEFINES ${NAME}>=< NAME>=< DEFINES ${NAME}>=<
@ -191,7 +191,7 @@ WHERE
: NAME>=< ( obj1 obj2 -- >=< ) : NAME>=< ( obj1 obj2 -- >=< )
NAME<=> invert-comparison ; NAME<=> invert-comparison ;
FUNCTOR;" FUNCTOR>"
} }
} }
{ $slide "Example of sorting functor" { $slide "Example of sorting functor"

View File

@ -60,7 +60,7 @@ M: pixel-format dispose*
PRIVATE< PRIVATE<
FUNCTOR: define-pixel-format-attribute-table ( NAME PERM TABLE -- ) FUNCTOR< define-pixel-format-attribute-table ( NAME PERM TABLE -- )
>PFA DEFINES >${NAME} >PFA DEFINES >${NAME}
>PFA-int-array DEFINES >${NAME}-int-array >PFA-int-array DEFINES >${NAME}-int-array
@ -81,7 +81,7 @@ M: pixel-format-attribute >PFA
: >PFA-int-array ( attribute -- int-array ) : >PFA-int-array ( attribute -- int-array )
[ >PFA ] map concat PERM prepend 0 suffix int >c-array ; [ >PFA ] map concat PERM prepend 0 suffix int >c-array ;
FUNCTOR; FUNCTOR>
SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE: SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE:
scan-token scan-object scan-object ";" expect define-pixel-format-attribute-table ; scan-token scan-object scan-object ";" expect define-pixel-format-attribute-table ;

View File

@ -4,7 +4,7 @@ USING: accessors alien alien.c-types classes.struct functors
kernel math math.functions quotations ; kernel math math.functions quotations ;
in: alien.complex.functor in: alien.complex.functor
FUNCTOR: define-complex-type ( N T -- ) FUNCTOR< define-complex-type ( N T -- )
N-type IS ${N} N-type IS ${N}
@ -29,4 +29,4 @@ T-class lookup-c-type
complex >>boxed-class complex >>boxed-class
drop drop
FUNCTOR; FUNCTOR>

View File

@ -6,7 +6,7 @@ in: alien.destructors
TUPLE: alien-destructor alien ; TUPLE: alien-destructor alien ;
FUNCTOR: define-destructor ( F -- ) FUNCTOR< define-destructor ( F -- )
F-destructor DEFINES-CLASS ${F}-destructor F-destructor DEFINES-CLASS ${F}-destructor
<F-destructor> DEFINES <${F}-destructor> <F-destructor> DEFINES <${F}-destructor>
@ -27,6 +27,6 @@ M: F-destructor dispose alien>> F N ndrop ;
: |F ( alien -- alien ) dup <F-destructor> |dispose drop ; inline : |F ( alien -- alien ) dup <F-destructor> |dispose drop ; inline
FUNCTOR; FUNCTOR>
SYNTAX: destructor: scan-word define-destructor ; SYNTAX: destructor: scan-word define-destructor ;

View File

@ -45,7 +45,7 @@ MACRO: (vectored-element>) ( struct-class -- quot: ( elt -- struct ) )
slot: (n) slot: (n)
slot: (vectored) slot: (vectored)
FUNCTOR: define-vectored-accessors ( S>> S<< T -- ) FUNCTOR< define-vectored-accessors ( S>> S<< T -- )
WHERE WHERE
@ -54,14 +54,14 @@ M: T S>>
M: T S<< M: T S<<
[ (n)>> ] [ (vectored)>> S>> ] bi set-nth-unsafe ; inline [ (n)>> ] [ (vectored)>> S>> ] bi set-nth-unsafe ; inline
FUNCTOR; FUNCTOR>
PRIVATE> PRIVATE>
GENERIC: struct-transpose ( structstruct -- ssttrruucctt ) ; GENERIC: struct-transpose ( structstruct -- ssttrruucctt ) ;
GENERIC: vectored-element> ( elt -- struct ) ; GENERIC: vectored-element> ( elt -- struct ) ;
FUNCTOR: define-vectored-struct ( T -- ) FUNCTOR< define-vectored-struct ( T -- )
T-array [ T array-class-of ] T-array [ T array-class-of ]
@ -111,7 +111,7 @@ M: T-array struct-transpose
dup length [ nip iota ] [ drop ] [ nip (vectored-T) ] 2tri dup length [ nip iota ] [ drop ] [ nip (vectored-T) ] 2tri
[ [ [ nth ] [ set-nth ] bi-curry* bi ] 2curry each ] keep ; inline [ [ [ nth ] [ set-nth ] bi-curry* bi ] 2curry each ] keep ; inline
FUNCTOR; FUNCTOR>
SYNTAX: \ vectored-struct: SYNTAX: \ vectored-struct:
scan-word define-vectored-struct ; scan-word define-vectored-struct ;

View File

@ -57,7 +57,7 @@ mixin: dataflow-analysis
M: dataflow-analysis join-sets 2drop assoc-refine ; M: dataflow-analysis join-sets 2drop assoc-refine ;
M: dataflow-analysis ignore-block? drop kill-block?>> ; M: dataflow-analysis ignore-block? drop kill-block?>> ;
FUNCTOR: define-analysis ( name -- ) FUNCTOR< define-analysis ( name -- )
name DEFINES-CLASS ${name} name DEFINES-CLASS ${name}
name-ins DEFINES ${name}-ins name-ins DEFINES ${name}-ins
@ -77,7 +77,7 @@ symbol: name-outs
: name-out ( bb -- set ) name-outs get at ; : name-out ( bb -- set ) name-outs get at ;
FUNCTOR; FUNCTOR>
! ! ! Forward dataflow analysis ! ! ! Forward dataflow analysis
@ -88,7 +88,7 @@ M: forward-analysis block-order drop reverse-post-order ;
M: forward-analysis successors drop successors>> ; M: forward-analysis successors drop successors>> ;
M: forward-analysis predecessors drop predecessors>> ; M: forward-analysis predecessors drop predecessors>> ;
FUNCTOR: define-forward-analysis ( name -- ) FUNCTOR< define-forward-analysis ( name -- )
name IS ${name} name IS ${name}
name-ins IS ${name}-ins name-ins IS ${name}-ins
@ -103,7 +103,7 @@ INSTANCE: name forward-analysis ;
name run-dataflow-analysis name run-dataflow-analysis
[ name-ins set ] [ name-outs set ] bi* ; [ name-ins set ] [ name-outs set ] bi* ;
FUNCTOR; FUNCTOR>
! ! ! Backward dataflow analysis ! ! ! Backward dataflow analysis
@ -114,7 +114,7 @@ M: backward-analysis block-order drop post-order ;
M: backward-analysis successors drop predecessors>> ; M: backward-analysis successors drop predecessors>> ;
M: backward-analysis predecessors drop successors>> ; M: backward-analysis predecessors drop successors>> ;
FUNCTOR: define-backward-analysis ( name -- ) FUNCTOR< define-backward-analysis ( name -- )
name IS ${name} name IS ${name}
name-ins IS ${name}-ins name-ins IS ${name}-ins
@ -129,7 +129,7 @@ INSTANCE: name backward-analysis ;
\ name run-dataflow-analysis \ name run-dataflow-analysis
[ name-outs set ] [ name-ins set ] bi* ; [ name-outs set ] [ name-ins set ] bi* ;
FUNCTOR; FUNCTOR>
PRIVATE> PRIVATE>

View File

@ -12,7 +12,7 @@ in: compiler.cfg.renaming.functor
'[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join '[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join
[ drop ] append ; [ drop ] append ;
FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- ) FUNCTOR< define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- )
rename-insn-defs DEFINES ${NAME}-insn-defs rename-insn-defs DEFINES ${NAME}-insn-defs
rename-insn-uses DEFINES ${NAME}-insn-uses rename-insn-uses DEFINES ${NAME}-insn-uses
@ -83,6 +83,6 @@ insn-classes get [ insn-temp-slots empty? ] reject [
define define
] each ] each
FUNCTOR; FUNCTOR>
SYNTAX: \ RENAMING: scan-token scan-object scan-object scan-object ";" expect define-renaming ; SYNTAX: \ RENAMING: scan-token scan-object scan-object scan-object ";" expect define-renaming ;

View File

@ -5,7 +5,7 @@ in: functors.tests
COMPILE< COMPILE<
FUNCTOR: define-box ( T -- ) FUNCTOR< define-box ( T -- )
B DEFINES-CLASS ${T}-box B DEFINES-CLASS ${T}-box
<B> DEFINES <${B}> <B> DEFINES <${B}>
@ -16,7 +16,7 @@ TUPLE: B { value T } ;
C: <B> B ( T -- B ) ; C: <B> B ( T -- B ) ;
FUNCTOR; FUNCTOR>
\ float define-box \ float define-box
@ -30,7 +30,7 @@ COMPILE>
[ execute ] [ execute ] bi ; inline [ execute ] [ execute ] bi ; inline
COMPILE< COMPILE<
FUNCTOR: wrapper-test ( W -- ) FUNCTOR< wrapper-test ( W -- )
WW DEFINES ${W}${W} WW DEFINES ${W}${W}
@ -38,7 +38,7 @@ WHERE
: WW ( a -- b ) \ W twice ; : WW ( a -- b ) \ W twice ;
FUNCTOR; FUNCTOR>
\ sq wrapper-test \ sq wrapper-test
@ -48,7 +48,7 @@ COMPILE>
COMPILE< COMPILE<
FUNCTOR: wrapper-test-2 ( W -- ) FUNCTOR< wrapper-test-2 ( W -- )
W DEFINES ${W} W DEFINES ${W}
@ -56,7 +56,7 @@ WHERE
: W ( a b -- c ) \ + execute ; : W ( a b -- c ) \ + execute ;
FUNCTOR; FUNCTOR>
"blah" wrapper-test-2 "blah" wrapper-test-2
@ -66,7 +66,7 @@ COMPILE>
COMPILE< COMPILE<
FUNCTOR: symbol-test ( W -- ) FUNCTOR< symbol-test ( W -- )
W DEFINES ${W} W DEFINES ${W}
@ -74,7 +74,7 @@ WHERE
symbol: W symbol: W
FUNCTOR; FUNCTOR>
"blorgh" symbol-test "blorgh" symbol-test
@ -84,7 +84,7 @@ COMPILE>
COMPILE< COMPILE<
FUNCTOR: generic-test ( W -- ) FUNCTOR< generic-test ( W -- )
W DEFINES ${W} W DEFINES ${W}
@ -94,7 +94,7 @@ GENERIC: W ( a -- b ) ;
M: object W ; M: object W ;
M: integer W 1 + ; M: integer W 1 + ;
FUNCTOR; FUNCTOR>
"snurv" generic-test "snurv" generic-test
@ -126,7 +126,7 @@ COMPILE>
test-redefinition test-redefinition
FUNCTOR: redefine-test ( W -- ) FUNCTOR< redefine-test ( W -- )
W-word DEFINES ${W}-word W-word DEFINES ${W}-word
W-tuple DEFINES-CLASS ${W}-tuple W-tuple DEFINES-CLASS ${W}-tuple
@ -141,7 +141,7 @@ GENERIC: W-generic ( a -- b ) ;
M: W-tuple W-generic ; M: W-tuple W-generic ;
symbol: W-symbol symbol: W-symbol
FUNCTOR; FUNCTOR>
[ [ ] ] [ [ [ ] ] [
"in: functors.tests "in: functors.tests
@ -152,7 +152,7 @@ test-redefinition
COMPILE< COMPILE<
FUNCTOR: define-a-struct ( T NAME TYPE N -- ) FUNCTOR< define-a-struct ( T NAME TYPE N -- )
T-class DEFINES-CLASS ${T} T-class DEFINES-CLASS ${T}
@ -165,7 +165,7 @@ STRUCT: T-class
{ z TYPE initial: 5 } { z TYPE initial: 5 }
{ float { c:float 2 } } ; { float { c:float 2 } } ;
FUNCTOR; FUNCTOR>
"a-struct" "nemo" c:char 2 define-a-struct "a-struct" "nemo" c:char 2 define-a-struct
@ -213,7 +213,7 @@ COMPILE>
COMPILE< COMPILE<
FUNCTOR: define-an-inline-word ( W -- ) FUNCTOR< define-an-inline-word ( W -- )
W DEFINES ${W} W DEFINES ${W}
W-W DEFINES ${W}-${W} W-W DEFINES ${W}-${W}
@ -223,7 +223,7 @@ WHERE
: W ( -- ) ; inline : W ( -- ) ; inline
: W-W ( -- ) W W ; : W-W ( -- ) W W ;
FUNCTOR; FUNCTOR>
"an-inline-word" define-an-inline-word "an-inline-word" define-an-inline-word
@ -234,7 +234,7 @@ COMPILE>
COMPILE< COMPILE<
FUNCTOR: define-a-final-class ( T W -- ) FUNCTOR< define-a-final-class ( T W -- )
T DEFINES-CLASS ${T} T DEFINES-CLASS ${T}
W DEFINES ${W} W DEFINES ${W}
@ -245,7 +245,7 @@ TUPLE: T ; final
: W ( -- ) ; : W ( -- ) ;
FUNCTOR; FUNCTOR>
"a-final-tuple" "a-word" define-a-final-class "a-final-tuple" "a-word" define-a-final-class

View File

@ -176,13 +176,13 @@ PRIVATE<
functor-words [ functor-words [
"WHERE" parse-bindings drop "WHERE" parse-bindings drop
[ swap <def> suffix ] { } assoc>map concat [ swap <def> suffix ] { } assoc>map concat
\ FUNCTOR; parse-until [ ] append-as \ FUNCTOR> parse-until [ ] append-as
qualified-vocabs pop* ! unuse the bindings qualified-vocabs pop* ! unuse the bindings
] with-lambda-scope ; ] with-lambda-scope ;
: (FUNCTOR:) ( -- word def effect ) : (FUNCTOR<) ( -- word def effect )
scan-new-word [ parse-functor-body ] parse-locals-definition ; scan-new-word [ parse-functor-body ] parse-locals-definition ;
PRIVATE> PRIVATE>
SYNTAX: \ FUNCTOR< (FUNCTOR:) define-declared ; SYNTAX: \ FUNCTOR< (FUNCTOR<) define-declared ;

View File

@ -14,7 +14,7 @@ COMPILE<
[ { [ word? ] [ vocabulary>> "annotations" = ] } 1&& not ] [ { [ word? ] [ vocabulary>> "annotations" = ] } 1&& not ]
filter ; filter ;
FUNCTOR: define-annotation ( NAME -- ) FUNCTOR< define-annotation ( NAME -- )
(NAME) DEFINES (${NAME}) (NAME) DEFINES (${NAME})
!NAME DEFINES !${NAME} !NAME DEFINES !${NAME}
@ -31,7 +31,7 @@ SYNTAX: \ !NAME (parse-annotation) \ (NAME) suffix! ;
: NAMEs. ( -- ) : NAMEs. ( -- )
NAMEs sorted-definitions. ; NAMEs sorted-definitions. ;
FUNCTOR; FUNCTOR>
CONSTANT: annotation-tags { CONSTANT: annotation-tags {
"XXX" "TODO" "FIXME" "BUG" "REVIEW" "LICENSE" "XXX" "TODO" "FIXME" "BUG" "REVIEW" "LICENSE"

View File

@ -247,7 +247,7 @@ M: blas-matrix-base equal?
COMPILE< COMPILE<
FUNCTOR: (define-blas-matrix) ( TYPE T U C -- ) FUNCTOR< (define-blas-matrix) ( TYPE T U C -- )
VECTOR IS ${TYPE}-blas-vector VECTOR IS ${TYPE}-blas-vector
<VECTOR> IS <${TYPE}-blas-vector> <VECTOR> IS <${TYPE}-blas-vector>
@ -296,7 +296,7 @@ SYNTAX: \ XMATRIX{ \ } [ >MATRIX ] parse-literal ;
M: MATRIX pprint-delims M: MATRIX pprint-delims
drop \ XMATRIX{ \ } ; drop \ XMATRIX{ \ } ;
FUNCTOR; FUNCTOR>
: define-real-blas-matrix ( TYPE T -- ) : define-real-blas-matrix ( TYPE T -- )

View File

@ -129,7 +129,7 @@ M: blas-vector-base virtual@
COMPILE< COMPILE<
FUNCTOR: (define-blas-vector) ( TYPE T -- ) FUNCTOR< (define-blas-vector) ( TYPE T -- )
<DIRECT-ARRAY> IS <direct-${TYPE}-array> <DIRECT-ARRAY> IS <direct-${TYPE}-array>
XCOPY IS ${T}COPY XCOPY IS ${T}COPY
@ -184,10 +184,10 @@ SYNTAX: \ XVECTOR{ \ } [ >VECTOR ] parse-literal ;
M: VECTOR pprint-delims M: VECTOR pprint-delims
drop \ XVECTOR{ \ } ; drop \ XVECTOR{ \ } ;
FUNCTOR; FUNCTOR>
FUNCTOR: (define-real-blas-vector) ( TYPE T -- ) FUNCTOR< (define-real-blas-vector) ( TYPE T -- )
VECTOR IS ${TYPE}-blas-vector VECTOR IS ${TYPE}-blas-vector
XDOT IS ${T}DOT XDOT IS ${T}DOT
@ -205,10 +205,10 @@ M: VECTOR Vnorm
M: VECTOR Vasum M: VECTOR Vasum
(prepare-nrm2) XASUM ; (prepare-nrm2) XASUM ;
FUNCTOR; FUNCTOR>
FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- ) FUNCTOR< (define-complex-blas-vector) ( TYPE C S -- )
VECTOR IS ${TYPE}-blas-vector VECTOR IS ${TYPE}-blas-vector
XDOTU IS ${C}DOTU XDOTU IS ${C}DOTU
@ -227,7 +227,7 @@ M: VECTOR Vnorm
M: VECTOR Vasum M: VECTOR Vasum
(prepare-nrm2) XXASUM ; (prepare-nrm2) XXASUM ;
FUNCTOR; FUNCTOR>
: define-real-blas-vector ( TYPE T -- ) : define-real-blas-vector ( TYPE T -- )

View File

@ -8,7 +8,7 @@ in: math.vectors.simd.cords
COMPILE< COMPILE<
PRIVATE< PRIVATE<
FUNCTOR: (define-simd-128-cord) ( A/2 A -- ) FUNCTOR< (define-simd-128-cord) ( A/2 A -- )
A-rep IS ${A/2}-rep A-rep IS ${A/2}-rep
>A/2 IS >${A/2} >A/2 IS >${A/2}
@ -72,7 +72,7 @@ SYNTAX: \ A{ \ } [ >A ] parse-literal ;
A-rep >>rep A-rep >>rep
\ A typedef \ A typedef
FUNCTOR; FUNCTOR>
: define-simd-128-cord ( A/2 T -- ) : define-simd-128-cord ( A/2 T -- )
[ define-specialized-cord ] [ define-specialized-cord ]

View File

@ -263,7 +263,7 @@ PRIVATE<
! SIMD concrete type functor ! SIMD concrete type functor
FUNCTOR: define-simd-128 ( T -- ) FUNCTOR< define-simd-128 ( T -- )
A DEFINES-CLASS ${T} A DEFINES-CLASS ${T}
A-rep IS ${T}-rep A-rep IS ${T}-rep
@ -329,7 +329,7 @@ c:<c-type>
A-rep >>rep A-rep >>rep
\ A c:typedef \ A c:typedef
FUNCTOR; FUNCTOR>
SYNTAX: SIMD-128: SYNTAX: SIMD-128:
scan-token define-simd-128 ; scan-token define-simd-128 ;

View File

@ -3,7 +3,7 @@
USING: functors kernel math.order sequences sorting ; USING: functors kernel math.order sequences sorting ;
in: sorting.functor in: sorting.functor
FUNCTOR: define-sorting ( NAME QUOT -- ) FUNCTOR< define-sorting ( NAME QUOT -- )
NAME<=> DEFINES ${NAME}<=> NAME<=> DEFINES ${NAME}<=>
NAME>=< DEFINES ${NAME}>=< NAME>=< DEFINES ${NAME}>=<
@ -13,4 +13,4 @@ WHERE
: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ; : NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ;
: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ; : NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
FUNCTOR; FUNCTOR>

View File

@ -5,7 +5,7 @@ destructors fry functors kernel locals sequences serialize
tokyo.alien.tcutil tokyo.utils vectors ; tokyo.alien.tcutil tokyo.utils vectors ;
in: tokyo.assoc-functor in: tokyo.assoc-functor
FUNCTOR: define-tokyo-assoc-api ( T N -- ) FUNCTOR< define-tokyo-assoc-api ( T N -- )
DBGET IS ${T}get DBGET IS ${T}get
DBPUT IS ${T}put DBPUT IS ${T}put
@ -57,4 +57,4 @@ M: TYPE equal? assoc= ;
M: TYPE hashcode* assoc-hashcode ; M: TYPE hashcode* assoc-hashcode ;
FUNCTOR; FUNCTOR>

View File

@ -23,7 +23,7 @@ MACRO: marshall-x* ( num-quot seq-quot -- alien )
: malloc-underlying ( obj -- alien ) : malloc-underlying ( obj -- alien )
underlying>> malloc-byte-array ; underlying>> malloc-byte-array ;
FUNCTOR: define-primitive-marshallers ( TYPE -- ) FUNCTOR< define-primitive-marshallers ( TYPE -- )
<TYPE> IS <${TYPE}> <TYPE> IS <${TYPE}>
*TYPE IS *${TYPE} *TYPE IS *${TYPE}
>TYPE-array IS >${TYPE}-array >TYPE-array IS >${TYPE}-array
@ -55,7 +55,7 @@ PRIVATE>
*TYPE ; inline *TYPE ; inline
: unmarshall-TYPE*-free ( alien -- n ) : unmarshall-TYPE*-free ( alien -- n )
[ unmarshall-TYPE* ] keep add-malloc free ; [ unmarshall-TYPE* ] keep add-malloc free ;
FUNCTOR; FUNCTOR>
SYNTAX: PRIMITIVE-MARSHALLERS: SYNTAX: PRIMITIVE-MARSHALLERS:
";" parse-tokens [ define-primitive-marshallers ] each ; ";" parse-tokens [ define-primitive-marshallers ] each ;

View File

@ -1,7 +1,7 @@
USING: kernel sequences functors fry macros generalizations ; USING: kernel sequences functors fry macros generalizations ;
in: models.combinators.templates in: models.combinators.templates
FROM: models.combinators => <collection> #1 ; FROM: models.combinators => <collection> #1 ;
FUNCTOR: fmaps ( W -- ) FUNCTOR< fmaps ( W -- )
W IS ${W} W IS ${W}
w-n DEFINES ${W}-n w-n DEFINES ${W}-n
w-2 DEFINES 2${W} w-2 DEFINES 2${W}
@ -20,4 +20,4 @@ MACRO: w-n* ( int -- quot ) dup '[ [ _ narray <collection> #1 ] dip [ _ firstn ]
: w-2* ( a b quot -- mapped ) 2 w-n* ; inline : w-2* ( a b quot -- mapped ) 2 w-n* ; inline
: w-3* ( a b c quot -- mapped ) 3 w-n* ; inline : w-3* ( a b c quot -- mapped ) 3 w-n* ; inline
: w-4* ( a b c d quot -- mapped ) 4 w-n* ; inline : w-4* ( a b c d quot -- mapped ) 4 w-n* ; inline
FUNCTOR; FUNCTOR>