From 2ffc6667f9ec40383eae7261396f259f73c7baf9 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 6 Jul 2010 00:38:02 +0100
Subject: [PATCH] forth: Implement some simple structure-defining words and use
 them.

Alleviates the tedium slightly.  Also demonstrates `does>', which is
appropriately scary.
---
 forth-fringe.fth | 68 +++++++++++++++++++++++++++++++++++++-------------------
 1 file changed, 45 insertions(+), 23 deletions(-)

diff --git a/forth-fringe.fth b/forth-fringe.fth
index bab2eda..0f6d748 100644
--- a/forth-fringe.fth
+++ b/forth-fringe.fth
@@ -24,6 +24,23 @@
 
 : quis s" forth-fringe" ;
 
+\ Structures.
+
+: defstruct ( -- struct-sys )
+    \ Commence a new structure.
+    0 ;
+
+: slot ( "name" struct-sys u -- struct-sys' )
+    \ Add a new slot called `name', `u' units in size.  The word `name'
+    \ applies the necessary offset to find the slot given the structure's
+    \ base address.
+    create over , + does> @ + ;
+
+: endstruct ( "name" struct-sys' -- )
+    \ End a structure definition.  The word `name' becomes a constant
+    \ containing the requires size of the structure.
+    create , does> @ ;
+
 \ Error reporting.
 
 : ouch ( a-addr u -- program exits )
@@ -51,10 +68,15 @@
 \ The amount of return-stack storage we allocate to a coroutine.
 256 cells constant cr-space
 
+\ Coroutine descriptors.
+defstruct
+    cell slot cr-sp
+endstruct cr-size
+
 \ The current coroutine.  This initially points to an uninitialized
 \ descriptor which we'll fill in during the first coroutine switch.
 variable current-cr
-here current-cr ! cell allot
+here current-cr ! cr-size allot
 
 \ The coroutine which invoked this one.  This is used by `yield'.
 variable caller-cr
@@ -62,10 +84,10 @@ variable caller-cr
 : switch-cr ( cr -- )
     \ Make `cr' the current coroutine, and tell it that it was called by this
     \ one.
-    rp@ current-cr @ !
+    rp@ current-cr @ cr-sp !
     current-cr @ caller-cr !
     dup current-cr !
-    @ rp!
+    cr-sp @ rp!
 ;
 
 : yield ( -- )
@@ -76,18 +98,18 @@ variable caller-cr
 : start-cr ( cr xt -- )
     \ Switch to the new coroutine `cr', and have it execute the token `xt'.
     swap
-    rp@ current-cr @ !
+    rp@ current-cr @ cr-sp !
     current-cr @ caller-cr !
     dup current-cr !
-    @ rp!
+    cr-sp @ rp!
     execute
 ;
 
 : init-cr ( a-addr -- cr )
     \ Initialize a chunk of memory at `a-addr' and turn it into a pointer to
     \ a coroutine descriptor `cr' ready for use by `start-cr'.
-    [ cr-space cell - ] literal +
-    dup dup !
+    [ cr-space cr-size - ] literal +
+    dup dup cr-sp !
 ;
 
 : [alloc-cr] ( -- cr ; R: -- cr-sys )
@@ -99,10 +121,10 @@ variable caller-cr
     postpone rp! postpone init-cr
 ; immediate
 
-: [drop-cr] ( cr -- ; R: cr-sys -- )
+: [drop-cr] ( R: cr-sys -- )
     \ Compile-time word: adjust the return-stack pointer to reclaim the space
-    \ used for the coroutine `cr' and all those above it on the return stack.
-    postpone cell postpone + postpone rp!
+    \ used by a coroutine.
+    postpone rp@ postpone cr-space postpone + postpone rp!
 ; immediate
 
 \ ---------------------------------------------------------------------------
@@ -135,6 +157,17 @@ variable caller-cr
 \ ---------------------------------------------------------------------------
 \ Binary trees.
 
+\ A leaf is an empty tree.  The address of this variable is important; its
+\ contents are not.
+variable leaf
+
+\ Binary tree structure.
+defstruct
+    cell slot tree-left
+    cell slot tree-datum
+    cell slot tree-right
+endstruct tree-size
+
 : make-tree ( a-addr-left w-datum a-addr-right -- a-addr-tree )
     \ Construct a binary tree from components on the stack, returning the
     \ address of the tree node.
@@ -143,16 +176,6 @@ variable caller-cr
     r>					\ recover pointer
 ;
 
-\ A leaf is an empty tree.  The address of this variable is important; its
-\ contents are not.
-variable leaf
-
-\ Binary tree structure.
-: tree-left ( a-addr -- a-addr' ) ;
-: tree-datum ( a-addr -- a-addr' ) cell+ ;
-: tree-right ( a-addr -- a-addr' ) [ 2 cells ] literal + ;
-3 constant tree-ncells
-
 : parse-subtree ( c-addr-limit c-addr -- c-addr-limit c-addr' tree )
     \ Parse a subtree from the string on the stack (in limit/base form).
     \ Update the string to reflect how much we consumed, and leave the tree
@@ -221,17 +244,16 @@ variable leaf
 	    \ One proper argument: parse a tree and print its fringe.
 	    [alloc-cr]
 	    1 arg parse-tree over ['] tree-fringe start-cr
-	    dup print-iterator cr
+	    print-iterator cr
 	    [drop-cr]
 	endof
 
 	3 of
 	    \ Two arguments: parse two trees and compare them.
 	    [alloc-cr] 1 arg parse-tree over ['] tree-fringe start-cr
-	    dup
 	    [alloc-cr] 2 arg parse-tree over ['] tree-fringe start-cr
 	    same-iterators-p
-	    swap [drop-cr]
+	    [drop-cr] [drop-cr]
 	    if ." match" else ." no match" then cr
 	endof
 
-- 
2.11.0