( Title: Named Structures File: namedstruct.fs Log file: namedstruct.log Version: 0.8.4 Started by: David N. Williams Modified by: Michael Gassanenko License: LGPL Revised: August 28, 2010 ) \ Copyright (C) 2002, 2009, 2010 by David N. Williams, Michael Gassanenko ( 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. Please see the file POLITENESS included with this distribution. This code implements named structures with reusable field and method names, compatible with Forth 200x structure field words. It includes a fix due to Michael Gassanenko for a nonportable use of DEFINITIONS. See the examples at the end for syntax. ANS Forth compatible except for case sensitivity. ) [UNDEFINED] >order [IF] : >order ( wid -- ) >r get-order r> swap 1+ set-order ; [THEN] \ *** WORDS ( +CONTEXT: '}'EVAL STRUCT: ;STRUCT uncommentable: ;STRUCT: in structure word lists: } /STRUCT ) \ *** GENERAL USE : +context: ( "name" wid -- ) \ synonym for _STRUCT:_ ( A synonym for Michael Gassanenko's _STRUCT:_ in clf, used here to hide DOES> from DEFINITIONS. Note: The name was lifted from Jenny Brien. ) create immediate ( wid) , DOES> ( -- ) ( order: -- wid ) @ ( wid) >order ; \ *** NAMED STRUCTURES ( Each named structure has its own word list for fields and methods, plus its own copy of "}" and the size constant "/struct". The field and method names are thus reusable, and an application can define "}" and "/struct" for its own use outside the structure context. We propose a trailing "{" convention for structure names; e.g., "name{", and a leading "/" convention for structure size constants, e.g., "/name". As with plainstruct.fs, structures are nestable; and the procedure for structure instances, whether named or unnamed, is exactly the same as there. See the next section for syntax examples. ) : struct: ( "name" -- wid 0 ) ( order: -- wid ) \ does: ( -- ) ( order: -- wid ) ( Make a new word list for the structure field definitions expected to follow "struct:". Create a name word for the structure in the current search order, which adds the new word list to the top of the search order when executed, so field and method names can be found. Make the name word immediate, so it changes the search order when compiling as well as when interpreting. Leave the current compilation word list identifier on the stack, to be restored by ";struct:". Add the new word list to the top of the current search order, and make it the compilation word list for structure field and method definitions that follow "struct:". Define "}" as an immediate word in the new word list, to be invoked after references started by the structure word to pop the new word list from the search order. Leave zero to initialize the running field offset. Corrected and rearranged by mlg. ) get-current ( wid) 0 wordlist ( struct.wid) dup +context: ( struct.wid) >order definitions ( wid 0) s" : } previous ; immediate " evaluate ; : '}'eval ( -- ) ( For late binding in ;DERIV: in mlg's extended structures. ) s" }" evaluate ; : ;struct ( wid u -- ) ( Terminate a structure definition begun with STRUCT: in the following order: 1. Define "/struct", a copy of the structure size constant for possible use by methods. 2. Restore the search order and compilation word list to that just before the last invocation of "struct:", assumed to use wid for compilation. ) aligned ( u') s" constant /struct" evaluate ( wid) set-current '}'eval ; \ Uncomment if wanted. Superfluous and deprecated. 0 [IF] : ;struct: ( "sizename" wid u -- ) ( In addition to steps 1. and 2. for ;STRUCT, do the step: 3. In the wid wordlist, define an explicitly named, aligned structure size constant for u. ) dup >r ;struct r> aligned constant ; [THEN] \ *** EXAMPLES 0 [IF] decimal \ A variation on the example in plainstruct-200x.fs that shows \ the reuse of field names: [UNDEFINED] +FIELD [IF] : +FIELD ( offset size <"name"> -- offset+size ) \ 200x create over , + DOES> ( struc -- struc+offset ) @ + ; [THEN] struct: 2dpoint{ 1 cells +field x 1 cells +field y ;struct 2dpoint{ create my2dpoint /struct allot 15 my2dpoint x ! 22 my2dpoint y ! } struct: 3dpoint{ 1 cells +field x 1 cells +field y 1 cells +field z ;struct 3dpoint{ create my3dpoint /struct allot 38 my3dpoint x ! 19 my3dpoint y ! 6 my3dpoint z ! } \ A more elaborate example that illustrates nesting: struct: person{ 2 cells +field name 1 chars +field gender aligned 1 cells +field age ;struct struct: girl{ person{ /struct +field self /struct +field friend1 } 1 cells +field friend2 \ a friend by reference (see GEORGE) 2 cells +field 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 -- ) 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 cr .( Hee...ere's marieee!) marie show-girl cr .( To see the structure field names, execute:) cr .( "person{ words }" and "girl{ words }".) cr [THEN]