Reduced default heap use, added better compat logic, testing.

ueforth/common/all_tests.fs

@@ -21,4 +21,5 @@ include common/locals_tests.fs
 include common/doloop_tests.fs
 include common/conditionals_tests.fs
 include common/float_tests.fs
+include common/filetools_tests.fs
 run-tests

ueforth/common/base_tests.fs

@@ -13,35 +13,35 @@
 \ limitations under the License.
 
 ( Tests Base Operations )
-: test-empty-stack   depth 0= assert ;
+: test-empty-stack   depth 0 =assert ;
-: test-add   123 111 + 234 = assert ;
+: test-add   123 111 + 234 =assert ;
-: test-dup-depth   123 depth 1 = assert dup depth 2 = assert 2drop ;
+: test-dup-depth   123 depth 1 =assert dup depth 2 =assert 2drop ;
-: test-dup-values   456 dup 456 = assert 456 = assert ;
+: test-dup-values   456 dup 456 =assert 456 =assert ;
-: test-2drop   123 456 2drop depth 0= assert ;
+: test-2drop   123 456 2drop depth 0 =assert ;
-: test-nip   123 456 nip depth 1 = assert 456 = assert ;
+: test-nip   123 456 nip depth 1 =assert 456 =assert ;
 : 8throw   8 throw ;
-: test-catch ['] 8throw catch 8 = assert depth 0= assert ;
+: test-catch ['] 8throw catch 8 =assert depth 0 =assert ;
 : throw-layer 456 >r 123 123 123 8throw 123 123 123 r> ;
-: test-catch2 9 ['] throw-layer catch 8 = assert 9 = assert depth 0= assert ;
+: test-catch2 9 ['] throw-layer catch 8 =assert 9 =assert depth 0 =assert ;
-: test-rdrop   111 >r 222 >r rdrop r> 111 = assert ;
+: test-rdrop   111 >r 222 >r rdrop r> 111 =assert ;
-: test-*/    1000000 22 7 */ 3142857 = assert ;
+: test-*/    1000000 22 7 */ 3142857 =assert ;
-: test-bl   bl 32 = assert ;
+: test-bl   bl 32 =assert ;
-: test-0=   123 0= 0= assert 0 0= assert ;
+: test-0=   123 0= 0 =assert 0 0= assert ;
-: test-cells   123 cells cell+ cell/ 124 = assert ;
+: test-cells   123 cells cell+ cell/ 124 =assert ;
-: test-aligned    127 aligned 128 = assert ;
+: test-aligned    127 aligned 128 =assert ;
-: test-[char]   [char] * 42 = assert ;
+: test-[char]   [char] * 42 =assert ;
 2 3 * 4 * 5 * 6 * 7 * 8 * 9 * 10 * 11 * 12 * constant 2-12*
-: test-fornext    1 10 for r@ 2 + * next 2-12* = assert ;
+: test-fornext    1 10 for r@ 2 + * next 2-12* =assert ;
-: test-foraft    1 11 for aft r@ 2 + * then next 2-12* = assert ;
+: test-foraft    1 11 for aft r@ 2 + * then next 2-12* =assert ;
-: test-doloop     1 13 2 do i * loop 2-12* = assert ;
+: test-doloop     1 13 2 do i * loop 2-12* =assert ;
 : inc-times ( a n -- a+n ) 0 ?do 1+ loop ;
-: test-?do     123 40 inc-times 163 = assert ;
+: test-?do     123 40 inc-times 163 =assert ;
-: test-?do2     123 0 inc-times 123 = assert ;
+: test-?do2     123 0 inc-times 123 =assert ;
 : test-<>   123 456 <> assert ;
-: test-<>2   123 123 <> 0= assert ;
+: test-<>2   123 123 <> 0 =assert ;
 : inc/2-times ( a n -- a+n/2 ) 0 ?do 1+ 2 +loop ;
-: test-+loop   123 0 inc/2-times 123 = assert ;
+: test-+loop   123 0 inc/2-times 123 =assert ;
-: test-+loop2   123 6 inc/2-times 126 = assert ;
+: test-+loop2   123 6 inc/2-times 126 =assert ;
 
 e: test-arithmetic
   3 4 + .
@@ -84,19 +84,19 @@ e: test-value-to
 e: test-comments-interp
   123 ( Interpretered comment ) 456
   789 \ Interpretered comment )
-  789 = assert 456 = assert 123 = assert
+  789 =assert 456 =assert 123 =assert
 ;e
 
 e: test-comments-compiled
   : foo 123 ( Compiled comment ) 456
         789 \ Interpretered comment )
         999 ;
-  foo 999 = assert 789 = assert 456 = assert 123 = assert
+  foo 999 =assert 789 =assert 456 =assert 123 =assert
 ;e
 
 e: test-recurse
   : factorial   dup 0= if drop 1 else dup 1- recurse * then ;
-  5 factorial 120 = assert
+  5 factorial 120 =assert
 ;e
 
 e: test-accept
@@ -109,16 +109,16 @@ e: test-accept
 
 e: test-key
   in: 1
-  key 49 = assert
+  key 49 =assert
-  key nl = assert
+  key nl =assert
 ;e
 
 e: test-compiler-off
   : test [ 123 111 + literal ] ;
-  test 234 = assert
+  test 234 =assert
 ;e
 
 e: test-empty-string
   : test s" " ;
-  test 0 = assert drop
+  test 0 =assert drop
 ;e

ueforth/common/filetools.fs

@@ -20,11 +20,17 @@
 
 internals definitions
 ( Leave some room for growth of starting system. )
-$8000 constant growth-gap
+15000 constant compat-level
-here growth-gap + growth-gap 1- + growth-gap 1- invert and constant saving-base
+0 value saving-base
 : park-heap ( -- a ) saving-base ;
 : park-forth ( -- a ) saving-base cell+ ;
-: 'cold ( -- a ) saving-base 2 cells + ;   0 'cold !
+: 'cold ( -- a ) saving-base 2 cells + ;
+: real-heap-start ( -- a ) sp0 'stack-cells @ cells + ;
+: setup-saving-base
+  here real-heap-start - compat-level cells max
+  real-heap-start + to saving-base
+  saving-base 16 cells + 'heap !
+  0 'cold ! ;
 
 : save-name
   'heap @ park-heap !

ueforth/common/filetools_tests.fs

@@ -0,0 +1,20 @@
+\ Copyright 2021 Bradley D. Nelson
+\
+\ Licensed under the Apache License, Version 2.0 (the "License");
+\ you may not use this file except in compliance with the License.
+\ You may obtain a copy of the License at
+\
+\     http://www.apache.org/licenses/LICENSE-2.0
+\
+\ Unless required by applicable law or agreed to in writing, software
+\ distributed under the License is distributed on an "AS IS" BASIS,
+\ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+\ See the License for the specific language governing permissions and
+\ limitations under the License.
+
+( Test if we've exhaused compat threshold )
+internals
+: test-compat-level-exhausted
+  saving-base real-heap-start - compat-level cells =assert
+;
+forth

ueforth/common/fini.fs

@@ -16,7 +16,7 @@ internals
 ( Bring a forth to the top of the vocabulary. )
 transfer forth
 ( Move heap to save point, with a gap. )
-saving-base 16 cells + 'heap !
+setup-saving-base
 forth
 execute ( assumes an xt for autoboot is on the dstack )
 ok

ueforth/common/locals_tests.fs

@@ -16,7 +16,7 @@
 
 e: test-locals-one
   : test { a } a a * ;
-  4 test 16 = assert
+  4 test 16 =assert
 ;e
 
 e: test-locals-two
@@ -29,17 +29,17 @@ e: test-locals-two
 e: test-alignment
   30 allot
   : color24 { r g b } r 16 lshift g 8 lshift b or or ;
-  1 2 3 color24 66051 = assert
+  1 2 3 color24 66051 =assert
 ;e
 
 e: test-longname
   : setPixelColor { pixelNum } pixelNum ;
-  1 setPixelColor 1 = assert
+  1 setPixelColor 1 =assert
 ;e
 
 e: test-dash
   : test { a b c -- a a b b c c } a a b b c c ;
-  1 2 3 test * + * + * 23 = assert
+  1 2 3 test * + * + * 23 =assert
 ;e
 
 e: test-for-loop

ueforth/common/testing.fs

@@ -44,11 +44,19 @@ variable confirm-old-type
 : expect-finish   expected resulted str= if exit then }confirm
    cr ." Expected:" cr expected type cr ." Resulted:" cr resulted type cr 1 throw ;
 
+( Better error asserts )
+: =assert ( actual expected -- )
+  2dup <> if }confirm ."   FAILURE! EXPECTED: " .
+                      ." ACTUAL: " . space 0 assert then 2drop ;
+: <assert ( actual expected -- )
+  2dup >= if }confirm ."   MUST BE LESS THAN: " .
+                      ." ACTUAL: " . space 0 assert then 2drop ;
+
 ( Input testing )
 create in-buffer 1000 allot
 variable in-head   variable in-tail
 : >in ( c -- ) in-buffer in-head @ + c!  1 in-head +! ;
-: in> ( -- c ) in-tail @ in-head @ < assert
+: in> ( -- c ) in-tail @ in-head @ <assert
                in-buffer in-tail @ + c@  1 in-tail +!
                in-head @ in-tail @ = if 0 in-head ! 0 in-tail ! then ;
 : s>in ( a n -- ) for aft dup c@ >in 1+ then next drop ;

ueforth/common/utils.fs

@@ -24,13 +24,12 @@
 ( Remove from Dictionary )
 : forget ( "name" ) ' dup >link current @ !  >name drop here - allot ;
 
-2 constant SMUDGE
-: :noname ( -- xt ) 0 , current @ @ , SMUDGE , here dup current @ ! ['] = @ , postpone ] ;
-
 internals definitions
+2 constant SMUDGE
 : mem= ( a a n -- f)
    for aft 2dup c@ swap c@ <> if 2drop rdrop 0 exit then 1+ swap 1+ then next 2drop -1 ;
 forth definitions also internals
+: :noname ( -- xt ) 0 , current @ @ , SMUDGE , here dup current @ ! ['] = @ , postpone ] ;
 : str= ( a n a n -- f) >r swap r@ <> if rdrop 2drop 0 exit then r> mem= ;
 : startswith? ( a n a n -- f ) >r swap r@ < if rdrop 2drop 0 exit then r> mem= ;
 : .s   ." <" depth n. ." > " raw.s cr ;

ueforth/common/utils_tests.fs

@@ -36,9 +36,9 @@ e: test-forget
   : bar foo foo ;
   : baz bar bar * * ;
   forget foo
-  here = assert
+  here =assert
-  current @ = assert
+  current @ =assert
-  context @ @ = assert
+  context @ @ =assert
 ;e
 
 e: test-see-number

ueforth/common/vocabulary_tests.fs

@@ -105,13 +105,13 @@ e: test-sealed
 e: test-fixed-does>-normal
   : adder create , does> @ + ;
   3 adder foo
-  4 foo 7 = assert
+  4 foo 7 =assert
-  4 ' foo execute 7 = assert
+  4 ' foo execute 7 =assert
 ;e
 
 (
 e: test-fixed-does>-interp
   create hi 123 , does> @ + ;
-  7 hi 130 = assert
+  7 hi 130 =assert
 ;e
 )

ueforth/posix/web_interface.fs

@@ -110,7 +110,7 @@ window.onload = function() {
 | constant index-html# constant index-html
 
 variable webserver
-20000 constant out-size
+2000 constant out-size
 200 stream input-stream
 out-size stream output-stream
 create out-string out-size 1+ allot align