Merge pull request #6 from nineties/add_array

Add array

bootstrap.fs

@@ -2400,7 +2400,7 @@ BLOCK-SIZE remaining-size  !
 ;
 
 \ Bootstrapping version of free do nothing.
-: (free) ( addr -- ) ;
+: (free) ( addr -- ) drop ;
 
 ( === File I/O === )
 

lib/array.fs

@@ -0,0 +1,137 @@
+\ planckforth -
+\ Copyright (C) 2021 nineties
+
+( === Variable Length Array === )
+
+private{
+
+( === Allocation strategy === )
+defined? array-alloc-strategy [unless]
+
+\ Compute new capacity
+: array-alloc-strategy ( u1 -- u2 )
+    dup 0= if 4 else 2 * then
+;
+
+[then]
+
+struct
+    ptr% field array>buf
+    int% field array>size
+    int% field array>capa
+end-struct array%
+
+s" Index out of range" exception constant OUT-OF-RANGE export
+
+\ Allocate array with capacity
+: allocate-array ( n capa -- arr )
+    array% %allocate throw
+    ( n capa addr )
+    over cells allocate throw over array>buf !
+    swap over array>capa !
+    swap over array>size !
+;
+
+: make-array ( n -- arr )
+    dup 0>= check-argument
+    \ compute capa
+    dup 0= if 10 else dup then
+    allocate-array
+; export
+
+: array-size ( arr -- n ) array>size @ ; export 
+
+: check-index ( i arr -- )
+    over 0< if OUT-OF-RANGE throw then
+    array-size >= if OUT-OF-RANGE throw then
+;
+
+: array@ ( i arr -- w )
+    2dup check-index
+    array>buf @ swap cells + @
+; export
+
+: array! ( v i arr -- )
+    2dup check-index
+    array>buf @ swap cells + !
+; export
+
+: array-reallocate ( capa arr -- )
+    over cells allocate throw
+    \ copy elements to new buffer
+    over array>buf @ over 3 pick array>size @ cells memcpy
+    over array>buf @ free
+    over array>buf !
+    over over array>capa !
+    2drop
+;
+
+: array-resize ( n arr -- )
+    over 0>= check-argument
+    2dup array>capa @ < if
+        \ If n is smaller than the capacity
+        \ just change array>size
+        array>size !
+        exit
+    else
+        2dup array-reallocate
+        array>size !
+    then
+; export
+
+: array-push ( w arr -- )
+    dup array>size @ over array>capa @ >= if
+        dup array>capa @ array-alloc-strategy
+        ( w arr new-capa )
+        over array-reallocate
+    then
+    swap ( arr w ) 
+    over array>buf @ 2 pick array>size @ cells + !
+    array>size 1 swap +!
+; export
+
+: array-pop ( arr -- w )
+    dup array-size 0> unless OUT-OF-RANGE throw then
+    1 over array>size -!
+    dup array-size cells swap array>buf @ + @
+; export
+
+
+}private
+
+T{ -1 ' make-array catch -> -1 INVALID-ARGUMENT }T
+
+T{ 0 make-array constant A -> }T
+T{ A array-size -> 0 }T
+T{ 0 A ' array@ catch -> 0 A OUT-OF-RANGE }T
+T{ 1 0 A ' array! catch -> 1 0 A OUT-OF-RANGE }T
+T{ A ' array-pop catch -> A OUT-OF-RANGE }T
+
+T{ :noname 100 0 do i A array-push loop ; execute -> }T
+
+T{ A array-size -> 100 }T
+T{ 0 A array@ -> 0 }T
+T{ 5 A array@ -> 5 }T
+T{ 10 A array@ -> 10 }T
+T{ 50 A array@ -> 50 }T
+T{ 99 A array@ -> 99 }T
+
+T{ A array-pop -> 99 }T
+T{ A array-size -> 99 }T
+T{ A array-pop -> 98 }T
+T{ A array-size -> 98 }T
+
+T{ -1 A ' array-resize catch -> -1 A INVALID-ARGUMENT }T
+T{ 5 A array-resize -> }T
+T{ A array-size -> 5 }T
+T{ 100 A array-resize -> }T
+T{ A array-size -> 100 }T
+
+T{ 1 -1 A ' array! catch -> 1 -1 A OUT-OF-RANGE }T
+T{ 1 100 A ' array! catch -> 1 100 A OUT-OF-RANGE }T
+T{ -1 A ' array@ catch -> -1 A OUT-OF-RANGE }T
+T{ 100 A ' array@ catch -> 100 A OUT-OF-RANGE }T
+T{ 1 0 A array! -> }T
+T{ 0 A array@ -> 1 }T
+T{ 2 99 A array! -> }T
+T{ 99 A array@ -> 2 }T

lib/core.fs

@@ -19,3 +19,9 @@ defined? roll [unless]
         s" }T" streq if exit then
     again
 ;
+
+s" Invalid argument" exception constant INVALID-ARGUMENT
+
+: check-argument ( f  -- )
+    unless INVALID-ARGUMENT throw then
+;

runtests.fs

@@ -14,6 +14,7 @@ include test/errorreport.fs
 include test/coreexttest.fs
 
 include test/export.fs
+include lib/array.fs
 
 report-errors
 report-and-exit