forth: Implement some simple structure-defining words and use them.

Alleviates the tedium slightly.  Also demonstrates `does>', which is
appropriately scary.

diff --git a/forth-fringe.fth b/forth-fringe.fth
index bab2eda9b7bc0c06c48cac1cf0b0e829344e8da6..0f6d7487d5c6b11218f8f4928cf8bde2e68653e8 100644 (file)
--- a/forth-fringe.fth
+++ b/forth-fringe.fth
@@ -24,6 +24,23 @@
 
 : quis s" forth-fringe" ;
 
 
 : 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 )
 \ 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
 
 \ 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
 \ 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
 
 \ 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.
 : 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 !
     current-cr @ caller-cr !
     dup current-cr !

-    @ rp!
+    cr-sp @ rp!

 ;
 
 : yield ( -- )
 ;
 
 : 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
 : 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 !
     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'.
     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 )
 ;
 
 : [alloc-cr] ( -- cr ; R: -- cr-sys )


@@ -99,10 +121,10 @@ variable caller-cr
     postpone rp! postpone init-cr
 ; immediate
 
     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
     \ 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
 
 \ ---------------------------------------------------------------------------
 ; immediate
 
 \ ---------------------------------------------------------------------------


@@ -135,6 +157,17 @@ variable caller-cr
 \ ---------------------------------------------------------------------------
 \ Binary trees.
 
 \ ---------------------------------------------------------------------------
 \ 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.
 : 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
 ;
 
     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
 : 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
            \ 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
            [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
            [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
 
            if ." match" else ." no match" then cr
        endof