(    Title:  Tests for plainstruct.fs
      File:  plainstruct-test.fs
    Author:  David N. Williams
   Version:  1.0.5
   Revised:  August 24, 2021
   License:  Public Domain
  Log file:  plainstruct.log
)
decimal

\ Forth host detection, VERBOSE initialization, comment support.
INCLUDE tester-display.fs
true VERBOSE !
REDEFINED-WARNING-OFF

?.FIRST-CR  \ before the first displayed line
?." Host: " host-s ?type ?.cr
[DEFINED] -VERBOSEINCLUDE [IF] -VERBOSEINCLUDE [THEN]  \ vfx

\ *** DEBUGGING

[UNDEFINED] \\ [IF]
: \\  ( -- )  -1 parse 2drop BEGIN refill 0= UNTIL ; [THEN]
[UNDEFINED] .# [IF]
: .#  ( n -- )  cr ." #" . cr ; [THEN]

\ *** INCLUDES

INCLUDE plainstruct.fs
INCLUDE ttester-xf.fs
INCLUDE xtester-errors.fs
INCLUDE ftester-errors.fs  \ Assumes host loads floating point.

: ?.errors  ( -- )
  ?.xt-errors ?.cr [ HAS-FLOATING ] [IF] ?.ft-errors ?.cr [THEN] ;

\ ** TESTS

TESTING  STRUCT /STRUCT: +FIELD MAKE-STRUCT: MAKE-IMM-STRUCT: ]&

t{ 0 0 +FIELD d0
     1 +FIELD d1
     2 +FIELD d2
     3 +FIELD d3 -> 6 }T

t{ 0 d0 -> 0 }t
t{ 0 d1 -> 0 }t
t{ 0 d2 -> 1 }t
t{ 0 d3 -> 3 }t

\ structure definition
t{ STRUCT ( point)
     1 cells +FIELD >x
     1 cells +FIELD >y
     1 chars +FIELD >plotchar
   /STRUCT: /point
   /point -> 2 cells 1 chars + }t

\ structure instance
t{ /point make-struct: mypoint
     15 mypoint >x !
     22 mypoint >y !
     char o mypoint >plotchar c! -> }t

\ immediate structure instance
t{ /point make-imm-struct: my-imm-point
     16 my-imm-point >x !
     23 my-imm-point >y !
     char p my-imm-point >plotchar c! -> }t

\ interpreted structure access
t{ mypoint >x @ mypoint >y @ mypoint >plotchar c@ -> 15 22 char o }t

t{ my-imm-point >x @ my-imm-point >y @ my-imm-point >plotchar c@
     -> 16 23 char p }t

: mypoint@  ( -- x y plotchar /point )
  mypoint >r
  r@ >x @
  r@ >y @
  r> >plotchar c@  
  /point ;

: my-imm-point@  ( -- &my-imm-point x y plotchar )
  my-imm-point [ ]&
  my-imm-point [ >x ]& @
  my-imm-point [ >y ]& @
  my-imm-point [ >plotchar ]& c@ ;

\ compiled structure access
t{ mypoint@      -> 15 22 char o /point }t
t{ my-imm-point@ -> my-imm-point 16 23 char p }t

TESTING  FIELD: CFIELD: FIELD: 2FIELD: SFIELD: STRUCTFIELD:

\ For nesting into astruct below.
STRUCT
  CFIELD: >char6
  CFIELD: >char7
  CFIELD: >char8
 /STRUCT: /cstruct
create cstruct /cstruct allot

\ Example of one-off structure instance syntax without /STRUCT:.
0
CFIELD: >char1
 FIELD: >cell
CFIELD: >char2
2FIELD: >2cells
CFIELD: >char3
SFIELD: >str
CFIELD: >char4
/cstruct STRUCTFIELD: >cstruct
CFIELD: >char5
create astruct allot

: "hello"  s" hello" ;
: s!  2! ;
: s@  2@ ;

char a  astruct >char1  c!
1       astruct >cell   !
char b  astruct >char2  c!
3 2     astruct >2cells 2!
char c  astruct >char3  c!
"hello" astruct >str    s!
char d  astruct >char4  c!
char f  astruct >cstruct >char6 c!
char g  astruct >cstruct >char7 c!
char h  astruct >cstruct >char8 c!
char e  astruct >char5  c!

: astruct@  ( -- struct.data )
  astruct >r
  r@ >char1 c@
  r@ >cell @
  r@ >char2 c@
  r@ >2cells 2@
  r@ >char3 c@
  r@ >str s@
  r@ >char4 c@
  r@ >cstruct >char6 c@
  r@ >cstruct >char7 c@
  r@ >cstruct >char8 c@
  r> >char5 c@ ;

: bstruct ( -- struct )  astruct ; immediate

: bstruct@  ( -- struct struct.data )
  bstruct [ ]&
  bstruct [ >char1 ]& c@
  bstruct [ >cell ]& @
  bstruct [ >char2 ]& c@
  bstruct [ >2cells ]& 2@
  bstruct [ >char3 ]& c@
  bstruct [ >str ]& s@
  bstruct [ >char4 ]& c@
  bstruct [ >cstruct >char6 ]& c@
  bstruct [ >cstruct >char7 ]& c@
  bstruct [ >cstruct >char8 ]& c@
  bstruct [ >char5 ]& c@ ;

\ interpreted access
t{ astruct >char1 c@  -> char a }t
t{ astruct >cell @    -> 1 }t
t{ astruct >char2 c@  -> char b }t
t{ astruct >2cells 2@ -> 3 2 }t
t{ astruct >char3 c@  -> char c }t
t{ astruct >str s@    -> "hello" }t
t{ astruct >cstruct >char6 c@  -> char f }t
t{ astruct >cstruct >char7 c@  -> char g }t
t{ astruct >cstruct >char8 c@  -> char h }t
t{ astruct >char4 c@  -> char d }t
t{ astruct >char5 c@  -> char e }t

\ compiled access
t{ astruct@ -> char a 1 char b 3 2 char c "hello" char d
               char f char g char h
               char e }t

t{ bstruct@ -> bstruct char a 1 char b 3 2 char c "hello"
               char d char f char g char h
               char e }t

\ interpreted alignment
t{ astruct aligned               -> astruct }t
t{ astruct >char1                -> astruct }t
t{ astruct >char1  char+ aligned -> astruct >cell }t
t{ astruct >cell   cell+         -> astruct >char2 }t
t{ astruct >char2  char+ aligned -> astruct >2cells }t
t{ astruct >2cells 2 cells +     -> astruct >char3 }t
t{ astruct >char3  char+ aligned -> astruct >str }t
t{ astruct >str    2 cells +     -> astruct >char4 }t
t{ astruct >char4  char+ aligned -> astruct >cstruct }t
t{ astruct >cstruct >char6 char+ -> astruct >cstruct >char7 }t
t{ astruct >cstruct >char7 char+ -> astruct >cstruct >char8 }t
t{ astruct >cstruct >char8 char+ -> astruct >char5 }t
t{ astruct >cstruct /cstruct +   -> astruct >char5 }t

[DEFINED] FFIELD: [IF]  \ floating-point fields
TESTING  MAXALIGNED MAXALIGN MAKE-FSTRUCT: MAKE-IMM-FSTRUCT:
TESTING  FFIELD: SFFIELD: DFFIELD: FSTRUCTFIELD:

1 aligned faligned
  [DEFINED] DFALIGNED [IF] dfaligned [THEN]
  [DEFINED] QFALIGNED [IF] qfaligned [THEN]
CONSTANT MAXALIGNMENT

red-text
-1 invert 0 <> [IF]
  cr .( ***ARITHMETIC IS NOT TWO'S COMPLEMENT) [THEN]

: 2^n?  ( u -- flag )  BEGIN dup 1 rshift swap 1 and UNTIL 0= ;

MAXALIGNMENT 2^n? 0= [IF]
 cr .( ***MAXALIGNMENT IS NOT A POWER OF 2) [THEN]
normal-text

t{ 1 maxaligned -> MAXALIGNMENT }t
t{ maxalign here MAXALIGNMENT mod -> 0 }t

\ For nesting into fstruct below.
STRUCT
  FFIELD: >f1
 SFFIELD: >sf1
 /STRUCT: /subfs

STRUCT
       CFIELD: >c1
       FFIELD: >f
       CFIELD: >c2
       /subfs
 FSTRUCTFIELD: >subfs
       CFIELD: >c3
      SFFIELD: >sf
      DFFIELD: >df
       CFIELD: >c4
/STRUCT: /fstruct

/fstruct MAKE-FSTRUCT: myfstruct

: init-myfstruct  ( -- )
  [char] a myfstruct >c1  c! 
        1E myfstruct >f   f!
  [char] b myfstruct >c2  c!
 4E myfstruct >subfs >f1  f!
 5E myfstruct >subfs >sf1 sf! 
  [char] c myfstruct >c3  c!
        2E myfstruct >sf  sf!
        3E myfstruct >df  df! 
  [char] d myfstruct >c4  c! ;

t{ init-myfstruct -> }t

/fstruct MAKE-IMM-FSTRUCT: myifstruct

: init-myifstruct  ( -- )
  [char] a myifstruct [ >c1 ]& c! 
        1E myifstruct [  >f ]& f!
  [char] b myifstruct [ >c2 ]& c!
4E myifstruct [  >subfs >f1 ]& f!
5E myifstruct [ >subfs >sf1 ]& sf! 
  [char] c myifstruct [ >c3 ]& c!
        2E myifstruct [ >sf ]& sf!
        3E myifstruct [ >df ]& df! 
  [char] d myifstruct [ >c4 ]& c! ;

t{ init-myifstruct -> }t

\ The following interpreted access tests with fetches also
\ conclusively test compiled access, through the stores in
\ INIT-MYFSTRUCT and INIT-MYIFSTRUCT.  That is, it's sufficient
\ to test that the interpreted and compiled addresses of
\ structure elements are correct.

\ interpreted access
t{ myfstruct >c1 c@          -> char a }t
t{ myfstruct >f  f@          -> 1E }t
t{ myfstruct >c2 c@          -> char b }t
t{ myfstruct >subfs >f1  f@  -> 4E }t
t{ myfstruct >subfs >sf1 sf@ -> 5E }t
t{ myfstruct >c3 c@          -> char c }t
t{ myfstruct >sf sf@         -> 2E }t
t{ myfstruct >df df@         -> 3E }t
t{ myfstruct >c4 c@          -> char d }t

\ interpreted access, immediate instance
t{ myifstruct >c1 c@          -> char a }t
t{ myifstruct >f  f@          -> 1E }t
t{ myifstruct >c2 c@          -> char b }t
t{ myifstruct >subfs >f1  f@  -> 4E }t
t{ myifstruct >subfs >sf1 sf@ -> 5E }t
t{ myifstruct >c3 c@          -> char c }t
t{ myifstruct >sf sf@         -> 2E }t
t{ myifstruct >df df@         -> 3E }t
t{ myifstruct >c4 c@          -> char d }t

\ interpreted alignment
t{ myfstruct maxaligned            -> myfstruct }t
t{ myfstruct >c1                   -> myfstruct }t
t{ myfstruct >c1 char+ faligned    -> myfstruct >f }t
t{ myfstruct >f  float+ faligned   -> myfstruct >c2 }t
t{ myfstruct >c2 char+ maxaligned  -> myfstruct >subfs }t
t{ myfstruct >subfs                -> myfstruct >subfs >f1 }t
t{ myfstruct >subfs >f1 float+     -> myfstruct >subfs >sf1 }t
t{ myfstruct >subfs >sf1 sfloat+   -> myfstruct >c3 }t
t{ myfstruct >c3 char+ sfaligned   -> myfstruct >sf }t
t{ myfstruct >sf sfloat+ dfaligned -> myfstruct >df }t
t{ myfstruct >df dfloat+           -> myfstruct >c4 }t

[THEN]  \ floating-point fields

?." This SEE output should display early-bound addresses:"
VERBOSE @ [IF]
see my-imm-point@
[THEN]

GFORTH-HOST [IF] ?.cr [THEN] ?.errors