From: Phil Burk <philburk@mobileer.com>
Date: Mon, 5 Dec 2022 15:58:51 +0000 (-0800)
Subject: Add ANS structure support (#128)
X-Git-Url: https://git.gag.com/?a=commitdiff_plain;h=516c3194c86ca4c14bb9ccc37efb5176f6a8a20c;p=debian%2Fpforth

Add ANS structure support (#128)

BEGIN-STRUCTURE and END-STRUCTURE
+FIELD FIELD: and CFIELD:
FFIELD: for float members
---

diff --git a/fth/floats.fth b/fth/floats.fth
index 8a73f7c..d80738e 100644
--- a/fth/floats.fth
+++ b/fth/floats.fth
@@ -64,7 +64,12 @@ fp-create-size swap - constant CREATE_SIZE
     fdepth 0 max  0 ?DO fdrop LOOP
 ;
 
-\ Convert between single precision and floating point
+\ Floating point structure member.
+: FFIELD:   ( n1 "name" -- n2 ; addr1 -- addr2 )
+    FALIGNED 1 FLOATS +FIELD
+;
+
+\ Convert between single precision integer and floating point
 : S>F ( s -- ) ( F: -- r )
     s>d d>f
 ;
diff --git a/fth/loadp4th.fth b/fth/loadp4th.fth
index 8afa2d9..79550b4 100644
--- a/fth/loadp4th.fth
+++ b/fth/loadp4th.fth
@@ -20,6 +20,7 @@ include? forget  forget.fth
 include? >number numberio.fth
 include? task-misc1.fth   misc1.fth
 include? case    case.fth
+include? +field  structure.fth
 include? $=      strings.fth
 include? privatize   private.fth
 include? (local) ansilocs.fth
diff --git a/fth/structure.fth b/fth/structure.fth
new file mode 100644
index 0000000..0acce21
--- /dev/null
+++ b/fth/structure.fth
@@ -0,0 +1,40 @@
+\ Structures and fields.
+\
+\ The code is based on the implementation from the ANS standard.
+\
+\ Permission to use, copy, modify, and/or distribute this
+\ software for any purpose with or without fee is hereby granted.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
+\ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
+\ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
+\ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
+\ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
+\ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
+\ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+\ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+
+anew task-structure.fth
+
+: BEGIN-STRUCTURE ( "<spaces>name" -- struct-sys 0 , start the definition of a structure )
+    CREATE
+        HERE 0 0 ,      \ mark stack, lay dummy
+    DOES> @             \ -- structure-size
+;
+
+: END-STRUCTURE ( addr n -- , terminate a structure definition )
+    SWAP !
+;
+
+: +FIELD  ( n <"name"> -- ; Exec: addr -- 'addr )
+    CREATE OVER , +
+    DOES> @ +
+;
+
+: FIELD:    ( n1 "name" -- n2 ; addr1 -- addr2 )
+    ALIGNED 1 CELLS +FIELD
+;
+
+: CFIELD:   ( n1 "name" -- n2 ; addr1 -- addr2 )
+    1 CHARS   +FIELD
+;
diff --git a/fth/t_corex.fth b/fth/t_corex.fth
index c37252a..a45114f 100644
--- a/fth/t_corex.fth
+++ b/fth/t_corex.fth
@@ -344,5 +344,29 @@ T{ [undefined] if }T{ false }T  \ high level
 T{ [undefined] dup }T{ false }T \ in kernel
 T{ [undefined] k23jh42 }T{ true }T
 
+\  ----------------------------------------------------- Structures
+
+BEGIN-STRUCTURE XYZS
+    cfield: xyz.c1
+    field:  xyz.w1
+    cfield: xyz.c2
+END-STRUCTURE
+
+T{ xyzs }T{ 2 cells 1+ }T
+T{ 0 xyz.c1 }T{ 0 }T
+T{ 0 xyz.w1 }T{ cell }T
+T{ 0 xyz.c2 }T{ 2 cells }T
+
+CREATE MY-XYZS XYZS ALLOT
+\ test forward order
+77 my-xyzs xyz.c1 c!
+1234567 my-xyzs xyz.w1 !
+99 my-xyzs xyz.c2 c!
+
+T{  my-xyzs xyz.c1 c@ }T{ 77 }T
+T{  my-xyzs xyz.w1 @ }T{ 1234567 }T
+T{  my-xyzs xyz.c2 c@ }T{ 99 }T
+
+
 }TEST
 
diff --git a/fth/t_floats.fth b/fth/t_floats.fth
index 05612be..b0fe98b 100644
--- a/fth/t_floats.fth
+++ b/fth/t_floats.fth
@@ -129,6 +129,33 @@ T{  PI 2.0 F*  FSIN   0.0   0.00001 F~    }T{  true  }T
 T{  PI 0.5 F*  FSIN   1.0   0.00001 F~    }T{  true  }T
 T{  PI 6.0 F/  FSIN   0.5   0.00001 F~    }T{  true  }T
 
+\  ----------------------------------------------------- FROUND
+T{  0.1 FROUND   0.0  0.0 F~ }T{ true }T
+T{  6.6 FROUND   7.0  0.0 F~ }T{ true }T
+T{ -3.2 FROUND  -3.0  0.0 F~ }T{ true }T
+T{ -8.8 FROUND  -9.0  0.0 F~ }T{ true }T
+
+\  ----------------------------------------------------- FFIELD:
+BEGIN-STRUCTURE ABCS
+    field:  abc.w1
+    ffield: abc.f1
+    field:  abc.w2
+END-STRUCTURE
+
+T{ 0 abc.w1 }T{ 0 }T
+T{ 0 abc.f1 }T{ 1 floats }T  \ aligns to next float boundary
+T{ 0 abc.w2 }T{ 2 cells }T
+T{ abcs }T{ cell  1 floats +  cell + }T
+
+CREATE MY-ABCS ABCS ALLOT
+6543 my-abcs abc.w1 !
+23.45 my-abcs abc.f1 f!
+98765 my-abcs abc.w2 !
+
+T{  my-abcs abc.w1  @ }T{ 6543 }T
+T{  my-abcs abc.f1 f@ 23.45 0.0 F~ }T{ true }T
+T{  my-abcs abc.w2  @ }T{ 98765 }T
+
 \  ----------------------------------------------------- \
 }TEST