From b45af1dcd6a205b79816b35fc09e8ba748d51330 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 2 Dec 2017 12:01:02 -0600 Subject: [PATCH] functors: Fix up look sharp --- .../specialized-arrays.factor | 10 +-- .../specialized-vectors-docs.factor | 2 +- .../specialized-vectors-tests.factor | 4 +- .../specialized-vectors.factor | 89 ++++++++----------- basis/vectors/functor/functor.factor | 35 ++++---- 5 files changed, 61 insertions(+), 79 deletions(-) diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index 881d468841..6a66ab717e 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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 math.parser arrays functors2 ; +arrays byte-arrays classes combinators fry functors2 +kernel lexer locals make math math.parser math.vectors parser +prettyprint.custom sequences sequences.private vocabs.generated +vocabs.loader vocabs.parser words ; IN: specialized-arrays MIXIN: specialized-array-mixin @@ -176,4 +176,4 @@ SYNTAX: \SPECIALIZED-ARRAYS: ! { "specialized-arrays" "mirrors" } "specialized-arrays.mirrors" require-when -! uchar define-specialized-array +uchar define-specialized-array diff --git a/basis/specialized-vectors/specialized-vectors-docs.factor b/basis/specialized-vectors/specialized-vectors-docs.factor index 2fa66162d3..ba0088db76 100644 --- a/basis/specialized-vectors/specialized-vectors-docs.factor +++ b/basis/specialized-vectors/specialized-vectors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax byte-vectors alien byte-arrays classes.struct ; +USING: alien byte-arrays classes.struct help.markup help.syntax ; IN: specialized-vectors HELP: \SPECIALIZED-VECTOR: diff --git a/basis/specialized-vectors/specialized-vectors-tests.factor b/basis/specialized-vectors/specialized-vectors-tests.factor index e3b4d59420..187f909871 100644 --- a/basis/specialized-vectors/specialized-vectors-tests.factor +++ b/basis/specialized-vectors/specialized-vectors-tests.factor @@ -1,8 +1,10 @@ IN: specialized-vectors.tests USING: specialized-arrays specialized-vectors -tools.test kernel sequences alien.c-types ; +tools.test kernel sequences alien.c-types vectors.functor ; SPECIALIZED-ARRAY: float SPECIALIZED-VECTORS: float double ; +SPECIAL-VECTOR: double +SPECIAL-VECTOR: float { 3 } [ double-vector{ 1 2 } 3 suffix! length ] unit-test diff --git a/basis/specialized-vectors/specialized-vectors.factor b/basis/specialized-vectors/specialized-vectors.factor index e6e83e24c0..16b905ce75 100644 --- a/basis/specialized-vectors/specialized-vectors.factor +++ b/basis/specialized-vectors/specialized-vectors.factor @@ -1,69 +1,64 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.c-types alien.data alien.parser -classes fry functors growable kernel lexer make math parser -prettyprint.custom sequences specialized-arrays vocabs.generated -vocabs.loader vocabs.parser ; +USING: alien.parser arrays functors2 growable kernel lexer make +math.parser sequences vocabs.loader ; FROM: sequences.private => nth-unsafe ; -FROM: specialized-arrays.private => nth-c-ptr direct-like ; QUALIFIED: vectors.functor IN: specialized-vectors MIXIN: specialized-vector - nth-c-ptr direct-like ; -V DEFINES-CLASS ${T}-vector +SPECIALIZED-ARRAY: ${T} -A IS ${T}-array - IS <${A}> - IS +SPECIAL-VECTOR: ${T} ->V DEFERS >${V} -V{ DEFINES ${V}{ +SYNTAX: ${T}-vector{ \ } [ >${T}-vector ] parse-literal ; -WHERE +INSTANCE: ${T}-vector specialized-vector +INSTANCE: ${T}-vector growable -V A vectors.functor:define-vector +M: ${T}-vector contract 2drop ; inline -M: V contract 2drop ; inline +M: ${T}-vector element-size drop \ ${T} heap-size ; inline -M: V element-size drop \ T heap-size ; inline +M: ${T}-vector pprint-delims drop \ ${T}-vector{ \ } ; -M: V pprint-delims drop \ V{ \ } ; +M: ${T}-vector >pprint-sequence ; -M: V >pprint-sequence ; +M: ${T}-vector pprint* pprint-object ; -M: V pprint* pprint-object ; +M: ${T}-vector >c-ptr underlying>> underlying>> ; inline +M: ${T}-vector byte-length [ length ] [ element-size ] bi * ; inline -M: V >c-ptr underlying>> underlying>> ; inline -M: V byte-length [ length ] [ element-size ] bi * ; inline +M: ${T}-vector direct-like drop ; inline +M: ${T}-vector nth-c-ptr underlying>> nth-c-ptr ; inline -M: V direct-like drop ; inline -M: V nth-c-ptr underlying>> nth-c-ptr ; inline - -M: A like - drop dup A instance? [ - dup V instance? [ - [ >c-ptr ] [ length>> ] bi - ] [ \ T >c-array ] if +M: ${T}-array like + drop dup ${T}-array instance? [ + dup ${T}-vector instance? [ + [ >c-ptr ] [ length>> ] bi + ] [ \ ${T} >c-array ] if ] unless ; inline -SYNTAX: V{ \ } [ >V ] parse-literal ; +]] -INSTANCE: V specialized-vector -INSTANCE: V growable - -;FUNCTOR> +> % "." % ] - [ name>> % ] - bi + "specialized-vectors:functors:specialized-vector:" % + ! [ vocabulary>> % "." % ] + ! [ name>> % ":" % ] + [ drop ] + [ 1array hashcode number>string % ] bi ] "" make ; PRIVATE> @@ -71,21 +66,7 @@ PRIVATE> : push-new ( vector -- new ) [ length ] keep ensure nth-unsafe ; inline -: define-vector-vocab ( type -- vocab ) - underlying-type - [ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi - generate-vocab ; - SYNTAX: \SPECIALIZED-VECTORS: - ";" [ - parse-c-type - [ define-specialized-array use-vocab ] - [ define-vector-vocab use-vocab ] bi - ] each-token ; - -SYNTAX: \SPECIALIZED-VECTOR: - scan-c-type - [ define-specialized-array use-vocab ] - [ define-vector-vocab use-vocab ] bi ; + ";" [ parse-c-type define-specialized-vector ] each-token ; { "specialized-vectors" "mirrors" } "specialized-vectors.mirrors" require-when diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor index d47a80025f..1ac423b764 100644 --- a/basis/vectors/functor/functor.factor +++ b/basis/vectors/functor/functor.factor @@ -1,35 +1,34 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes functors growable kernel math sequences -sequences.private ; +sequences.private functors2 ; IN: vectors.functor - -- ) +FUNCTOR: special-vector ( T: existing-word -- ) [[ +USING: classes growable kernel math sequences sequences.private +specialized-arrays ; - DEFINES <${V}> ->V DEFINES >${V} +SPECIALIZED-ARRAY: ${T} -WHERE +TUPLE: ${T}-vector { underlying ${T}-array } { length array-capacity } ; -TUPLE: V { underlying A } { length array-capacity } ; +: >${T}-vector ( seq -- vector ) ${T}-vector new clone-like ; inline -: ( capacity -- vector ) 0 V boa ; inline +: <${T}-vector> ( capacity -- vector ) <${T}-array> 0 ${T}-vector boa ; inline -M: V like - drop dup V instance? [ - dup A instance? [ dup length V boa ] [ >V ] if +M: ${T}-vector like + drop dup ${T}-vector instance? [ + dup ${T}-array instance? [ dup length ${T}-vector boa ] [ >${T}-vector ] if ] unless ; inline -M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; inline +M: ${T}-vector new-sequence drop [ <${T}-array> ] [ >fixnum ] bi ${T}-vector boa ; inline -M: A new-resizable drop ; inline +M: ${T}-array new-resizable drop <${T}-vector> ; inline -M: V new-resizable drop ; inline +M: ${T}-vector new-resizable drop <${T}-vector> ; inline -M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ; +M: ${T}-vector equal? over ${T}-vector instance? [ sequence= ] [ 2drop f ] if ; -: >V ( seq -- vector ) V new clone-like ; inline +INSTANCE: ${T}-vector growable -INSTANCE: V growable - -;FUNCTOR> +]]