From a9b9ca01f8627e4c6b8a86b46800176962598cbe Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 25 Aug 2009 17:56:01 -0500 Subject: [PATCH] associate specialized-arrays vocabs with c-types; add words for requiring vocabs and constructing arrays by C type --- basis/alien/c-types/c-types.factor | 96 ++++++++++++++++++- .../direct/functor/functor.factor | 8 +- .../specialized-arrays/functor/functor.factor | 9 +- .../functor/functor.factor | 3 +- 4 files changed, 108 insertions(+), 8 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 2eba6a2b9e..65f663e7b6 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser cpu.architecture alien alien.accessors alien.strings quotations layouts system compiler.units io io.files io.encodings.binary io.streams.memory accessors combinators effects continuations fry -classes ; +classes vocabs vocabs.loader ; IN: alien.c-types DEFER: @@ -27,7 +27,12 @@ TUPLE: c-type < abstract-c-type boxer unboxer { rep initial: int-rep } -stack-align? ; +stack-align? +array-class +array-constructor +direct-array-class +direct-array-constructor +sequence-mixin-class ; : ( -- type ) \ c-type new ; @@ -71,6 +76,48 @@ M: string c-type ( name -- type ) ] ?if ] if ; +: ?require-word ( word/pair -- ) + dup word? [ drop ] [ first require ] ?if ; + +GENERIC: require-c-type-arrays ( c-type -- ) + +M: object require-c-type-arrays + drop ; + +M: c-type require-c-type-arrays + [ array-class>> ?require-word ] + [ sequence-mixin-class>> ?require-word ] + [ direct-array-class>> ?require-word ] tri ; + +M: string require-c-type-arrays + c-type require-c-type-arrays ; + +M: array require-c-type-arrays + first c-type require-c-type-arrays ; + +GENERIC: c-type-array-constructor ( c-type -- word ) foldable + +M: string c-type-array-constructor + c-type c-type-array-constructor ; +M: array c-type-array-constructor + first c-type c-type-array-constructor ; +M: c-type c-type-array-constructor + array-constructor>> ; + +GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable + +M: string c-type-direct-array-constructor + c-type c-type-array-constructor ; +M: array c-type-direct-array-constructor + first c-type c-type-direct-array-constructor ; +M: c-type c-type-direct-array-constructor + direct-array-constructor>> ; + +: ( len c-type -- array ) + c-type-array-constructor execute( len -- array ) ; inline +: ( len c-type -- array ) + c-type-direct-array-constructor execute( len -- array ) ; inline + GENERIC: c-type-class ( name -- class ) M: abstract-c-type c-type-class class>> ; @@ -293,6 +340,36 @@ M: long-long-type box-return ( type -- ) : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline +: ?lookup ( vocab word -- word/pair ) + over vocab [ swap lookup ] [ 2array ] if ; + +: set-array-class* ( c-type vocab-stem type-stem -- c-type ) + { + [ + [ "specialized-arrays." prepend ] + [ "-array" append ] bi* ?lookup >>array-class + ] + [ + [ "specialized-arrays." prepend ] + [ "<" "-array>" surround ] bi* ?lookup >>array-constructor + ] + [ + [ "specialized-arrays." prepend ] + [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class + ] + [ + [ "specialized-arrays.direct." prepend ] + [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class + ] + [ + [ "specialized-arrays.direct." prepend ] + [ "" surround ] bi* ?lookup >>direct-array-constructor + ] + } 2cleave ; + +: set-array-class ( c-type stem -- c-type ) + dup set-array-class* ; + CONSTANT: primitive-types { "char" "uchar" @@ -315,6 +392,7 @@ CONSTANT: primitive-types [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer + "alien" "void*" set-array-class* "void*" define-primitive-type @@ -326,6 +404,7 @@ CONSTANT: primitive-types 8 >>align "box_signed_8" >>boxer "to_signed_8" >>unboxer + "longlong" set-array-class "longlong" define-primitive-type @@ -337,6 +416,7 @@ CONSTANT: primitive-types 8 >>align "box_unsigned_8" >>boxer "to_unsigned_8" >>unboxer + "ulonglong" set-array-class "ulonglong" define-primitive-type @@ -348,6 +428,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_signed_cell" >>boxer "to_fixnum" >>unboxer + "long" set-array-class "long" define-primitive-type @@ -359,6 +440,7 @@ CONSTANT: primitive-types bootstrap-cell >>align "box_unsigned_cell" >>boxer "to_cell" >>unboxer + "ulong" set-array-class "ulong" define-primitive-type @@ -370,6 +452,7 @@ CONSTANT: primitive-types 4 >>align "box_signed_4" >>boxer "to_fixnum" >>unboxer + "int" set-array-class "int" define-primitive-type @@ -381,6 +464,7 @@ CONSTANT: primitive-types 4 >>align "box_unsigned_4" >>boxer "to_cell" >>unboxer + "uint" set-array-class "uint" define-primitive-type @@ -392,6 +476,7 @@ CONSTANT: primitive-types 2 >>align "box_signed_2" >>boxer "to_fixnum" >>unboxer + "short" set-array-class "short" define-primitive-type @@ -403,6 +488,7 @@ CONSTANT: primitive-types 2 >>align "box_unsigned_2" >>boxer "to_cell" >>unboxer + "ushort" set-array-class "ushort" define-primitive-type @@ -414,6 +500,7 @@ CONSTANT: primitive-types 1 >>align "box_signed_1" >>boxer "to_fixnum" >>unboxer + "char" set-array-class "char" define-primitive-type @@ -425,6 +512,7 @@ CONSTANT: primitive-types 1 >>align "box_unsigned_1" >>boxer "to_cell" >>unboxer + "uchar" set-array-class "uchar" define-primitive-type @@ -434,6 +522,7 @@ CONSTANT: primitive-types 1 >>align "box_boolean" >>boxer "to_boolean" >>unboxer + "bool" set-array-class "bool" define-primitive-type @@ -447,6 +536,7 @@ CONSTANT: primitive-types "to_float" >>unboxer single-float-rep >>rep [ >float ] >>unboxer-quot + "float" set-array-class "float" define-primitive-type @@ -460,9 +550,11 @@ CONSTANT: primitive-types "to_double" >>unboxer double-float-rep >>rep [ >float ] >>unboxer-quot + "double" set-array-class "double" define-primitive-type "long" "ptrdiff_t" typedef "long" "intptr_t" typedef "ulong" "size_t" typedef ] with-compilation-unit + diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 89d1b5423d..4b80940153 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -25,8 +25,6 @@ TUPLE: A { underlying c-ptr read-only } { length fixnum read-only } ; -INSTANCE: A S - : ( alien len -- direct-array ) A boa ; inline M: A length length>> ; M: A nth-unsafe underlying>> NTH call ; @@ -41,5 +39,11 @@ M: A >pprint-sequence ; M: A pprint* pprint-object ; INSTANCE: A sequence +INSTANCE: A S + +T c-type + \ A >>direct-array-class + \ >>direct-array-constructor + drop ;FUNCTOR diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index a8d8d677ec..3341a909d2 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -34,8 +34,6 @@ TUPLE: A { length array-capacity read-only } { underlying byte-array read-only } ; -INSTANCE: A S - : ( n -- specialized-array ) dup T A boa ; inline : (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline @@ -78,7 +76,14 @@ M: A pprint* pprint-object ; SYNTAX: A{ \ } [ >A ] parse-literal ; INSTANCE: A sequence +INSTANCE: A S A T c-type-boxed-class specialize-vector-words +T c-type + \ A >>array-class + \ >>array-constructor + \ S >>sequence-mixin-class + drop + ;FUNCTOR diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 48c480b4d1..27bba3f9a6 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -20,8 +20,6 @@ WHERE V A vectors.functor:define-vector -INSTANCE: V S - M: V contract 2drop ; M: V byte-length underlying>> byte-length ; @@ -35,5 +33,6 @@ M: V pprint* pprint-object ; SYNTAX: V{ \ } [ >V ] parse-literal ; INSTANCE: V growable +INSTANCE: V S ;FUNCTOR