Functor-generated words can now have stack effect declarations; define byte-array>*-array words

basis/functors/functors.factor

@@ -1,15 +1,17 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel locals.private quotations classes.tuple
-classes.tuple.parser make lexer combinators generic words
-interpolate namespaces sequences io.streams.string fry
-classes.mixin ;
+USING: kernel locals.private quotations classes.tuple make
+combinators generic words interpolate namespaces sequences
+io.streams.string fry classes.mixin effects lexer parser
+classes.tuple.parser effects.parser ;
 IN: functors
 
 : scan-param ( -- obj )
     scan-object dup special? [ literalize ] unless ;
 
-: define* ( word def -- ) over set-word define ;
+: define* ( word def effect -- ) pick set-word define-declared ;
+
+: DEFINE* ( -- ) effect get parsed \ define* parsed ;
 
 : `TUPLE:
     scan-param parsed
@@ -25,21 +27,25 @@ IN: functors
     \ define-tuple-class parsed ; parsing
 
 : `M:
+    effect off
     scan-param parsed
     scan-param parsed
     \ create-method parsed
     parse-definition parsed
-    \ define* parsed ; parsing
+    DEFINE* ; parsing
 
 : `C:
+    effect off
     scan-param parsed
     scan-param parsed
-    [ [ boa ] curry define* ] over push-all ; parsing
+    [ [ boa ] curry ] over push-all
+    DEFINE* ; parsing
 
 : `:
+    effect off
     scan-param parsed
     parse-definition parsed
-    \ define* parsed ; parsing
+    DEFINE* ; parsing
 
 : `INSTANCE:
     scan-param parsed
@@ -50,6 +56,9 @@ IN: functors
 
 : `parsing \ parsing parsed ; parsing
 
+: `(
+    ")" parse-effect effect set ; parsing
+
 : (INTERPOLATE) ( accum quot -- accum )
     [ scan interpolate-locals ] dip
     '[ _ with-string-writer @ ] parsed ;
@@ -69,6 +78,7 @@ DEFER: ;FUNCTOR delimiter
         { "INSTANCE:" POSTPONE: `INSTANCE: }
         { "inline" POSTPONE: `inline }
         { "parsing" POSTPONE: `parsing }
+        { "(" POSTPONE: `( }
     } ;
 
 : push-functor-words ( -- )

basis/specialized-arrays/direct/functor/functor.factor

@@ -23,7 +23,7 @@ TUPLE: A
 { underlying alien read-only }
 { length fixnum read-only } ;
 
-: <A> A boa ; inline
+: <A> ( alien len -- direct-array ) A boa ; inline
 M: A length length>> ;
 M: A nth-unsafe underlying>> NTH call ;
 M: A set-nth-unsafe underlying>> SET-NTH call ;

basis/specialized-arrays/functor/functor.factor

@@ -1,19 +1,25 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: functors sequences sequences.private
-prettyprint.backend kernel words classes math parser
-alien.c-types byte-arrays accessors ;
+USING: functors sequences sequences.private prettyprint.backend
+kernel words classes math parser alien.c-types byte-arrays
+accessors summary ;
 IN: specialized-arrays.functor
 
+ERROR: bad-byte-array-length byte-array type ;
+
+M: bad-byte-array-length summary
+    drop "Byte array length doesn't divide type width" ;
+
 FUNCTOR: define-array ( T -- )
 
-A       DEFINES ${T}-array
-<A>     DEFINES <${A}>
->A      DEFINES >${A}
-A{      DEFINES ${A}{
+A            DEFINES ${T}-array
+<A>          DEFINES <${A}>
+>A           DEFINES >${A}
+byte-array>A DEFINES byte-array>${A}
+A{           DEFINES ${A}{
 
-NTH     [ T dup c-getter array-accessor ]
-SET-NTH [ T dup c-setter array-accessor ]
+NTH          [ T dup c-getter array-accessor ]
+SET-NTH      [ T dup c-setter array-accessor ]
 
 WHERE
 
@@ -21,7 +27,11 @@ TUPLE: A
 { length array-capacity read-only }
 { underlying byte-array read-only } ;
 
-: <A> dup T <c-array> A boa ; inline
+: <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
+
+: byte-array>A ( byte-array -- specialized-array )
+    dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
+    swap A boa ; inline
 
 M: A clone [ length>> ] [ underlying>> clone ] bi A boa ;
 
@@ -31,7 +41,7 @@ M: A nth-unsafe underlying>> NTH call ;
 
 M: A set-nth-unsafe underlying>> SET-NTH call ;
 
-: >A A new clone-like ; inline
+: >A ( seq -- specialized-array ) A new clone-like ; inline
 
 M: A like drop dup A instance? [ >A execute ] unless ;
 

basis/specialized-arrays/specialized-arrays-tests.factor

@@ -1,6 +1,7 @@
 IN: specialized-arrays.tests
 USING: tools.test specialized-arrays sequences
-specialized-arrays.int speicalized-arrays.bool ;
+specialized-arrays.int specialized-arrays.bool
+specialized-arrays.ushort alien.c-types accessors kernel ;
 
 [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
 
@@ -9,3 +10,9 @@ specialized-arrays.int speicalized-arrays.bool ;
 [ 2 ] [ int-array{ 1 2 3 } second ] unit-test
 
 [ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test
+
+[ ushort-array{ 1234 } ] [
+    little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array
+] unit-test
+
+[ B{ 210 4 1 } byte-array>ushort-array ] must-fail