diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 35e57bb4ae..4f83641ac8 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -144,7 +144,7 @@ M: struct-class initial-value* 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 diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index bd1f8ed148..edd18a5d33 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -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* ; ; inline M: byte-array direct-like drop uchar ; inline - -A DEFINES-CLASS ${T}-array - DEFINES <${A}> -(A) DEFINES (${A}) - DEFINES -A{ DEFINES ${A}{ +VARIABLES-FUNCTOR: specialized-array ( T -- ) { + { "A" "${T}-array" } + { "" "<${A}>" } + { "(A)" "(${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 -: ( alien len -- specialized-array ) A boa ; inline +INSTANCE: ${A} specialized-array2 -M: A direct-like drop ; inline +: ${} ( alien len -- specialized-array ) ${A} boa ; inline -: ( n -- specialized-array ) - [ \ T ] keep ; inline +: ${} ( n -- specialized-array ) + [ \ ${T} ] keep ${} ; inline -: (A) ( n -- specialized-array ) - [ \ T (underlying) ] keep ; inline +: ${(A)} ( n -- specialized-array ) + [ \ ${T} (underlying) ] keep ${} ; inline +>> -M: A clone [ underlying>> clone ] [ length>> ] bi ; inline +SYNTAX: ${A}{ \ } [ \ ${T} >c-array ] parse-literal ; -M: A length length>> ; inline +M: ${A} direct-like drop ${} ; inline -M: A nth-unsafe underlying>> \ T alien-element ; inline +M: ${A} clone [ underlying>> clone ] [ length>> ] bi ${} ; inline -M: A nth-c-ptr underlying>> \ T array-accessor drop swap ; 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 ; 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 - ; inline + ${} ; 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 +]] +> % "." % ] - [ 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 diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor index 04684cce18..e6e83e24c0 100644 --- a/basis/specialized-vectors/specialized-vectors.factor +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -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 diff --git a/basis/tools/deploy/shaker/strip-specialized-arrays.factor b/basis/tools/deploy/shaker/strip-specialized-arrays.factor index 195a3db976..b4ffaaee0b 100644 --- a/basis/tools/deploy/shaker/strip-specialized-arrays.factor +++ b/basis/tools/deploy/shaker/strip-specialized-arrays.factor @@ -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 ; diff --git a/core/functors2/functors2.factor b/core/functors2/functors2.factor index a86489bdea..7f7d10e5bb 100644 --- a/core/functors2/functors2.factor +++ b/core/functors2/functors2.factor @@ -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 '[ _ _ parse-stream drop ] generate-vocab drop ] + '[ @ over '[ _ _ 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 -- ) [ diff --git a/extra/classes/struct/vectored/vectored.factor b/extra/classes/struct/vectored/vectored.factor index c347be75e8..ef5382e965 100644 --- a/extra/classes/struct/vectored/vectored.factor +++ b/extra/classes/struct/vectored/vectored.factor @@ -8,11 +8,11 @@ IN: classes.struct.vectored > "-array" append swap lookup-word ] bi ; + [ underlying-type define-specialized-array ] [ name>> "-array" append swap lookup-word ] bi ; : -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 ) {