(       Title:  Quick and Dirty Named Structures
         File:  qdnamstruct.fs
      Version:  1.0.6
       Author:  David N. Williams
      License:  LGPL
Last Revision:  August 26, 2002
)
\ Copyright (C) 1999, 2001, 2002 by David N. Williams
(
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or at your option any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free
Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
MA 02111-1307 USA.

Please see the file POLITENESS included with this distribution.

This code implements named structures, with reusable member
names.  It builds on qdstruct.fs, which implements unnamed
structures.

ANS Forth compatible except for case sensitivity, REQUIRED, and
[UNDEFINED].

All "/" sizes are in bytes, and "struc" is the address of a
structure instance.
)

decimal
s" qdstruct.fs" required

[UNDEFINED] to-order [IF]
  : to-order  ( wid -- )  >r get-order r> swap 1+ set-order ;
[THEN]


\ *** WORDS
(
  STRUCT:  ;STRUCT  STRUCT-MEMBERS  }

visible in structure word lists:
  /STRUCT
)


\ *** NAMED STRUCTURES
(
Member access defining words like @MEMBER: from qdstruct.fs do
not work with named structures, and we haven't designed a
replacement yet.  For now, we just use explicit fetches and
stores on the member addresses of named structure instances.
)

: struct:  ( "name" -- )
  wordlist create immediate dup ,
  0 to /members ( wid) to-order definitions
DOES>  ( -- )  @ ( wid) to-order ;

: }  ( -- )  previous ; immediate

: ;struct  ( -- )
  s" /members aligned constant /struct" evaluate
  previous definitions ;

: struct-members  ( -- )
  align-members 
  s" /struct" evaluate aligned to /member
;


\ *** EXAMPLES
(
These examples all use &MEMBER: definitions. As stated above,
@MEMBER:, !MEMBER:, etc., do not work with named structures.
)

0 [IF]
struct: person{
  2cell-members
    &member:  name
  char-members
    &member:  gender
  align-members cell-members
    &member:  age
;struct

struct: girl{
  person{ struct-members }
    &member:  self
    &member:  friend1
  cell-members
    &member:  friend2  \ a friend with a reference
  2cell-members
    &member:  favdrink
;struct

create george person{ /struct } allot
create marie girl{ /struct } allot

: name1  ( -- s )  s" Marie" ;
: name2  ( -- s )  s" Bill" ;
: name3  ( -- s )  s" George" ;
: drink1  ( -- s ) s" cranberry juice" ;

name1  marie girl{ self person{ name } } 2!
char F marie girl{ self person{ gender } } c!
23     marie girl{ self person{ age } } !

name2  marie girl{ friend1 person{ name } } 2!
char M marie girl{ friend1 person{ gender } } c!
25     marie girl{ friend1 person{ age } } !

george marie girl{ friend2 } !

name3  george person{ name } 2!
char M george person{ gender } c!
21     george person{ age } !

drink1 marie girl{ favdrink } 2!

: .gender  ( char -- )
  CASE
    [char] M OF ." male" ENDOF
    [char] F OF ." female" ENDOF
    ." UNKNOWN"
  ENDCASE ;

: ..  ( -- )  ." ." ;

: show-girl  ( instance.girl -- )
cr ." Her name is " 
    dup girl{ self person{ name } } 2@ type ..
cr ." Her gender is "
    dup girl{ self person{ gender } } c@ .gender ..
cr ." Her age is "
    dup girl{ self person{ age } } @ 2 .r ..
cr ." Her favorite drink is "
    dup girl{ favdrink } 2@ type ..
cr ." Friend #1's name is " 
    dup girl{ friend1 person{ name } } 2@ type ..
cr ." Friend #1's gender is "
    dup girl{ friend1 person{ gender } } c@ .gender ..
cr ." Friend #1's age is "
    dup girl{ friend1 person{ age } } @ 2 .r ..
cr ." Friend #2's name is " 
    dup girl{ friend2 } @ person{ name } 2@ type ..
cr ." Friend #2's gender is "
    dup girl{ friend2 } @ person{ gender } c@ .gender ..
cr ." Friend #2's age is "
        girl{ friend2 } @ person{ age } @ 2 .r .. bl emit
;

cr .( Hee...ere's marieee!)
marie show-girl

cr .( To see the structure member names, execute:)
cr .(   "person{ words }" and "girl{ words }".)
cr
[THEN]