\ Last Revision: Nov 6 2016
\ cleaned up RESTORE

0 [if]

Forth Meets Smalltalk (FMS)

 microFMS version 1.7 
 Douglas B. Hoffman
 =============================
 WHAT IS microFMS?
 =============================
 
Some prefer a minimalist objects extension.  To address
this, presented here is microFMS (micro Forth Meets Smalltalk). 

=================
microFMS Features
=================

- Small memory requirement.  Few lines of code.
- Class based single inheritance model.
- Full encapsulation of data and methods.
- Object references may be passed on the stack independently of a message(s).
- Messages may be used in definitions independently of an object(s).
- Message Name Polymorphism with no restrictions on inheritance order.
- Dynamic (late) binding of all methods.
- Duck typing.
- No juggling of object reference in method definitions.
- Class variables.
- No state smart words.
- No restrictions on message names.
- Compatible with Forth 200x Structures.

[then]

[defined] >M4TH [if]
ONLY FORTH DEFINITIONS
anew --fms--
>M4TH
[then]

decimal

\ the program with some example classes follow
[undefined] cell [if] 1 cells constant cell [then]

get-current value dflt-cur \ save the compilation wordlist for restoration
: def dflt-cur set-current ;

0 value self \ will contain the current object

0 value ^class \ will contain the current class being compiled

0 [if]  Class Structure

note that ^class is the address of cell 0

cell  contents
----  ---------------------------------------------
 0    1st n-way method linked list address
 1    2nd n-way method linked list address
 2    ...
 3
 4
 5
 6
 7    8th n-way method linked list address
 8    dfa  ( addr of total size of instance variables for this class )
 9    sfa  ( addr of superclass )
10    wida ( addr of wordlist for this class )

Note that for class inheritance we need only copy the above to the newly created
subclass and then update the SFA and WIDA fields. The DFA field will be updated
as new instance variables are added to the subclass. Any new methods defined
for the subclass will be appended to the n-way linked lists. The linked lists
will naturally handle method inheritance and over riding.

The structure of all objects is to contain the ^class in its first cell, followed
by the object's instance variables. Offsets to the instance variables can be obtained
by inspecting the definition of the instance variable. See the does> action of (IVAR) below.

[then]

8 1- constant #lists  \ 8 lists are used as the default, a different number may be used  
: dfa ( cls -- a)  #lists 1+  cells + ; \ access the length of the instance variables for the class
: sfa ( cls -- a)  #lists 2 + cells + ; \ access the the class's superclass
: wida ( cls -- a) #lists 3 + cells + ; \ access the the class's complilation wordlist
#lists 4 + cells constant classSize

\ sel is a unique address that identifies the selector, or message.
\ _mfa computes which of the 8 linked lists is used for method lookup.
\ ideally _mfa should provide a uniformly distributed offset to the linked lists
: _mfa ( addr -- offset )  dup >r 2/ 2/ r@ xor \ offset will be 0 thru 7 for 8 lists
  2/ 2/ r> xor #lists and cells ;

\ method field address, mfa, returns the liked list to be used for the method search
: mfa ( sel cls -- sel mfa ) over _mfa + ;

\ fm, or find method, given the sel address as the key and the mfa as the linked list
\ to search, returns the method xt if the key is found or aborts if not found.
: fm ( sel mfa -- xt )
  begin \ standard linked list search, key = sel
    @ dup
  while
    2dup cell+ @ = \ stored keys are 1 cell offset from node
    if [ 2 cells ] literal + nip @ exit then \ payload is xt, 2 cells offset from node
  repeat -1 abort" method not found" ;

\ manually create class object, the root class of all classes
create object classSize dup allot object swap erase
cell object dfa !

\ so sets the search order to start with the class being compiled
\ followed by any number of superclasses
: so ( class -- )
  >r 
  get-order
  begin
   r@ wida @ swap 1+
   r> sfa @ dup >r
   object =
  until r> drop set-order ;

\ <super used to declare the superclass, create the wordlist that is associated
\ with this class and set it as the current compilation wordlist,
\ and finally set the wordlist search order so instance variables
\ and class definitions can be found (including any level of
\ superclass definitions). Save the previous search order on the
\ stack so it can be restored at the end of the class definition.
: <super ( 'name' -- wn..w1 n ) here dup >r to ^class
  classSize allot
  ' >body dup r@ classSize move r@ sfa ! \ copy data from the superclass
  get-order \ wn..w1 n to be left on stack at end of this word
  wordlist dup set-current r@ wida ! \ set the compilation wordlist
  r> so ;

wordlist constant mwid \ make a special wordlist just for message names
get-order mwid swap 1+ set-order \ make it the first wordlist to be searched, always

\ create a new message
: sel ( 'name' -- )
  mwid set-current create
  here _mfa , \ grab a new unique address, compute its associated offset into the n-way lists
              \ and store that offset. The does> action of this definition will
              \ return that unique adress (or sel). The sel address also points
              \ to the n-way linked list offset.
  does> ( obj addr ) \ the action of the message is to fetch the ^class from the first
                     \ cell of the object, add the n-way offset to that,
                     \ and do a linked list search for the method xt.
                     \ Then store the old self and place the object address in self.
                     \ Lastly execute the xt and restore self.
  over @ over @ + fm self >r swap to self execute r> to self ;

\ Get a selector for the message name.
\ If not a message name then make it one.
: gs ( 'name' -- sel )
  >in @ \ save for possible restore
  bl word count mwid search-wordlist \ is name already a message name?
  if
    >body nip \ yes, so return the sel addr
  else
    >in ! sel here cell - \ no, so create a new message
  then ;

\ preserve the current compilation wordlist
\ and make the n-way linked list method xt entry
: :m ( 'name' -- wid a xt )
  get-current gs ^class mfa here over @ , swap ! , here 0 , :noname ;

: ;m ( wid a xt -- )
  postpone ; swap ! set-current ; immediate

: super ( 'name' -- ) ' >body ^class sfa @ mfa fm compile, ; immediate

\ the action of an instance variable is to return its address
\ which is the address of the object, self, plus the offset
: (ivar) ( offset 'name' -- ) create immediate ,
  does> ( -- addr ) @ postpone literal postpone self postpone + ;

: bytes ( n 'name' -- ) ^class dfa dup @ (ivar) +! ;

\ : >dict ( cls -- obj ) dup dfa @ align here swap allot tuck ! ;

: ;class ( wn..w1 n -- ) set-order def ;


\ optional extra defs for heap objects, implicit object initialization
\ and restoring the wordlist search order upon class compilation errors
object to ^class :m init: ;m  :m free: ;m def
: (pre) ( cls -- cls n ) dup dfa @ ;
: (post) ( ...cls a -- obj ) tuck ! dup >r init: r> ;
: >dict ( cls -- obj ) (pre) align here swap allot (post) ;
: >heap ( cls -- heap-obj ) (pre) allocate throw (post) ;
: <free  ( heap-obj --) dup free: free throw ;

\ assure-order assures that message-wid will be the first wordlist searched
: assure-order
  get-order over mwid <>
  if mwid swap 1+ then
  set-order ;

\ a word to restore the search order and current wordlist
[defined] >M4TH [if]
: restore
  >M4TH  \ this will be Forth system specific 
  assure-order ;
[then]
\ cr here swap -  . .( bytes used) 

\ Have restore execute when a method compilation error occurs, such
\ as encountering an undefined word. This will be Forth system specific.
\ The following is what I use with MacForth on VFX:
[defined] >M4TH [if]
' restore is BeforeAlert 
[then]




0 [if] \ optional message-less instance variable access

: iv ( obj 'name' -- addr )
  dup @ so
  ' >body @ +
  get-ord set-order ;

\ x iv data @ . \ => 33  message-less access
\ : foo [ x iv data @ ] literal . ;  \ in a definition

[then]


-1 [if] \ optionally load example class and object code

create var <super object \ var is subclass of object
  cell bytes data
 :m !: ( n -- ) data ! ;m
 :m +: ( n -- ) data +! ;m
 :m @: ( -- n ) data @ ;m
 :m p: ( -- ) self @: . ;m \ print self
 :m init: 0 data ! ;m
;class

var >dict value x
33 x !:
cr .( print var x should be 33 => )
x p: 

\ x iv data @ . \ => 33  message-less access
\ : foo [ x iv data @ ] literal . ;  \ in a definition

create ptr <super var
 cell bytes size \ size, in bytes, of memory allocated
 variable ptr-cnt 0 ptr-cnt ! \ class variable
 :m size: ( -- n )  size @ ;m
 :m ptr: ( -- ptr ) data @ ;m
 :m free:
    data @ ?dup if free throw 0 data !  -1 ptr-cnt +! then
        0 size ! ;m
 :m new:  ( size -- ) 
    self free:
    dup allocate throw  data !   size !
    1 ptr-cnt +! ;m
 :m resize:  ( newsize -- ) 
    data @ over resize throw  data !  size !  ;m
 :m init: super init: 0 size ! ;m
 :m cnt: ( -- n) ptr-cnt @ ;m
;class

create string <super ptr
 :m new: ( addr len -- )
   dup super new: ( addr len ) data @ swap ( addr self len ) move ;m
 :m add: ( addr len -- ) \ add text to end of string
   dup ( addr-src len len )
   size @ dup >r + self resize:  \ addr-src len
   data @ r> + ( addr-src len dest) swap move ;m
 :m @: ( -- addr len ) data @  size @ ;m
 :m !: ( addr len -- ) self free: pad 0 self new: self add: ;m
 :m p: self @: type ;m
 :m +: ( char -- ) \ add char to end of string
     size @ 1+ self resize:   self @: + 1- c! ;m
;class


: lowerCase? ( char -- flag ) \ flag is true if char is lower case
  [CHAR] a [ CHAR z 1+ ] LITERAL WITHIN ;

\ Converts lower-case characters to upper case, modifying the contents
\ starting at addr for cnt chars
: to-upper   ( addr cnt -- )
 OVER \ addr cnt addr
 + SWAP  \ cnt+addr addr
 ?DO I C@ DUP
  lowerCase?
  IF 32 - I C!
  ELSE DROP
  THEN
 LOOP ;

true value case-sensitive? \ used for searches in string+ objects

create string+ <super string
  cell bytes start
  cell bytes end
  1 bytes theChar \ used for char searches
 :m reset: 0 start !  0 end !  ;m
 :m new: ( addr len -- ) super new:  self reset: ;m
 :m !: ( addr len -- ) super !:  self reset: ;m
 :m start: ( -- pos-addr ) start ;m
 :m end: ( -- len-addr ) end ;m
 \ the number of chars remaining after the selection
 :m rem: ( -- remainder ) size @ end @ - ;m
 :m 1st: ( -- char ) \ return first char of substring 
    data @ start @ + ( addr ) c@ ;m
 :m last: ( -- char ) \ return last char of substring 
    data @ end @ + 1- ( addr ) c@ ;m
 :m ?idx: ( idx -- idx )
     dup 0 size @ 
     WITHIN 0= IF TRUE ABORT" string+ index out of range" THEN ;m 

\ at: and to: indexes refer to the entire string
 :m at: ( idx -- char )
     self ?idx:
     data @ + c@ ;m
 :m to: ( char idx -- )
     self ?idx:
     data @ + c! ;m
 :m upper: \ converts entire string to upper case
      self @: to-upper ;m

 :m @sub: ( -- addr len ) \ fetch substring
    data @ start @ + ( addr ) end @ start @ - ;m

 :m selectAll: \ select entire string
    0 start ! size @ end ! ;m

\ compare addr1 len1 to the current *substring*
 :m =sub: ( addr1 len1 -- f ) \ observes case setting; true if equal, false if not
    DUP end @ start @ - <> IF 2drop FALSE EXIT THEN  \ get out early if length mismatch
    0 0  locals| str1 selfStrCopy len1 addr1 |
    case-sensitive?
    IF addr1 len1
       self @sub: COMPARE 0=
    ELSE
    string+ >heap string+ >heap to str1 to selfStrCopy
    self @sub: selfStrCopy new: \ make a temporary duplicate string object in the heap
    addr1 len1 str1 new: \ make a temporary duplicate string object in the heap
    selfStrCopy upper:   str1 upper: \ make both string copies uppercase
    selfStrCopy @:  str1 @: COMPARE 0=
    selfStrCopy <free str1 <free
    THEN
    ;m

 \ compare addr1 len1 to the entire string
 :m =: ( addr1 len1 -- true | false ) \ observes case setting; true if equal, false if not
     self selectAll:
     self =sub:
     ;m

\ case insensitive search
\ Note how this is a normal colon definition but is private to this class and
\ its subclasses and it can access instance variables of this class.

 : CIsearch ( addr1 len1 -- true | false )
    string+ >heap string+ >heap locals| str1 selfStrCopy len1 addr1 |
    self @: selfStrCopy new: \ make a temporary duplicate string object in the heap
    start @ selfStrCopy start: !   end @ selfStrCopy end: !
    addr1 len1 str1 new: \ make a temporary duplicate string object in the heap
    str1 @: TO len1 TO addr1
    selfStrCopy upper:   str1 upper: \ make both string copies uppercase
    
        selfStrCopy ptr: selfStrCopy end: @ + ( start-addr) selfStrCopy rem: ( len )
            addr1 len1 search   
        IF \ found
          ( u3 ) drop
          ( c-addr3 ) selfStrCopy ptr: - dup len1 + end ! start !
          true
        ELSE  2drop false
        THEN
        str1 <free selfStrCopy <free \ dispose the temp strings
   ;

 :m search: ( addr len -- true | false )
     locals| len addr |
     addr len
    \ first do rationality check
    \ return false if len to find is greater than remainder
      dup self rem: > IF 2drop false exit THEN
    case-sensitive?
    IF 2drop \ do case sensitive search
      super ptr: end @ + ( start-addr) self rem: ( len)  addr len search
      IF \ found
        ( u3 ) drop
        ( c-addr3 ) super ptr: - dup len + end ! start !
        true
      ELSE  2drop false
      THEN
    ELSE \ do case insensitive search
       CIsearch
    THEN
    ;m

:m chsearch: ( char -- flag )
   theChar c!  theChar 1 self search: ;m

 :m delete:  \ deletes the substring defined by START and END
             \ leaves START at the same place, END is set to START
     end @  start @ - 1 < IF exit THEN
     super ptr: end @ +   \ src 
     super ptr: start @ + \ src dest
     self rem: \ src dest cnt
     move
    size @  end @ start @ - -  self resize:
    start @ end !
     ;m

\ inserts text starting at END, START and END are moved to end of inserted text
 :m insert: \ { addr len -- }
    locals| len addr |
    size @ len + self resize:
    super ptr: end @ + dup ( src src ) len + ( dest ) self rem: len - ( cnt ) MOVE
    addr ( src ) super ptr: end @ + ( dest ) len  MOVE
    end @ len + dup start ! end ! ;m

\ inserts char at END, START and END are moved to just past inserted char
 :m chinsert: ( c -- )
    theChar c!  theChar 1 self insert: ;m 
 
\ replace selected text, if any, with given text
 :m replace: ( addr len -- )
     self delete: self insert: ;m

\ Search for text1 starting at END.
\ If found replace with text2.
\ Success flag is returned.
 :m sch&repl:  \ { addr1 len1 addr2 len2 -- flag }
    locals| len2 addr2 len1 addr1 |
    addr1 len1 self search: dup
    IF addr2 len2 self replace: THEN ;m

\ Reset self and replaces all occurrences of (addr1 len1) by (addr2 len2)
\ in the WHOLE of self.  Self is lastly reset again.
 :m replall: \ { addr1 len1 addr2 len2 -- }
    locals| len2 addr2 len1 addr1 |
 self reset:
 BEGIN
   addr1 len1 self search:
 WHILE
  addr2 len2 self replace:
 REPEAT
 self reset:
;m
    

 :m d:  \ formatted dump of string for debugging
   cr ."                     1                   2                   3                   4"
   cr ." 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0"
   cr  self size: 38 min 0 ?DO space i self at: emit LOOP
   cr start @ 40 min 2* spaces [char] S emit
   cr end @ 40 min 2* spaces [char] E emit
   cr ." start= " start @  ."  end= " end @  ."  rem= " self rem: . ."  size= " size @
      ."   case-sensitive?= " case-sensitive? .
 ;m

;class


cr .( test heap object and implicit init: )
var >heap value x

x p:
 
x <free

string+ >dict value s

: tsub \ { obj -- }
  locals| obj |
  false to case-sensitive?
  s" %HL%" s" hello" obj replall:
  s" %WLD%" s" world" obj replall:
  s" %%" s" %" obj replall: ;


: unescape \ { obj -- }
  locals| obj |
  s" %" s" %%" obj replall: ;

s" Start: %hl%,%wld%! :End" s !:

cr .( demonstrate replall: method of class string+ ) cr
s p:
\ Start: %hl%,%wld%! :End
cr
s tsub s p:
\ Start: hello,world! :End

s" abba%daabba" s !:

s unescape
cr
s p:
\ abba%%daabba

s" hello" s !:
cr .( print s should be 'hello' => )
s p:
cr .( print s should be 'hello world' => )
s"  world" s add:  s p:
cr .( print s should be 'hello world!' => )
char ! s +: s p:
cr .( inspect class variable should be 1 => )
s cnt: .

string >dict value s2
s" goodbye" s2 new:
cr .( print s2 should be 'goodbye' => )
s2 p:
cr .( inspect class variable should be 2 => )
s2 cnt: .


s free:
s2 free:  
cr .( inspect class variable should be 0 => )
s cnt: .

create testClass <super var
  cell bytes stringIvar \ will contain an object
  cell bytes x
  1 bytes charz
:m init:
   [char] & charz c!
   999 x ! 
   string >dict stringIvar !
   s" a string ivar" stringIvar @ new:
   777 super !:
   ;m
:m p: cr ." print ivar stringIvar, should be 'a string ivar' => "
         stringIvar @ p: \ message send to ivar
      cr ." print x, should be 999 => " x @ .
      cr ." print charz, should be '&' => " charz c@ emit
      cr ." print  super @:, should be 777 => " super @: .
       ;m
;class 


testClass >dict value t1

t1 p:

\ print ivar stringIvar, should be 'a string ivar' => a string ivar
\ print x, should be 999 => 999
\ print charz, should be '&' => &
\ print  super @:, should be 777 => 777


cr .( test find method error condition, object x does not know message add: )
cr
\ x add: \ => will likely crash

: foo'
  string+ >heap locals| s |
  
  s" ABCd" s !: ." the character " 0 s at: emit
  ."  is the first character of " s p:
  
  s" EFG" s add: cr s p: ."  after adding EFG"
  
  false to case-sensitive?
  s" cde" s search: if s delete: then cr s p:
  ."  is what's left after a search and delete for cde "

  s <free
   ;
cr foo'

\ foo' output =>
\ the character A is the first character of ABCd
\ ABCdEFG after adding EFG
\ ABFG is what's left after a search and delete for cde ok
[then]


0 [if]

microFMS makes it very easy to create new methods, so factoring of method
code is thus encouraged.  *All* message sends are dynamic (late bound). 
This allows "Open Recursion" in class definitions.  A special variable
called SELF allows a method to invoke another method of the same object. 
This allows a method defined in a class to invoke another method that is
defined later, either in the same class or some subclass thereof.  Of
course if the method has not been redefined then the last definition, up
the superclass hierarchy chain, will be invoked. 

Forth is not Smalltalk.  Everything is *not* an object.  Normal Forth
code and objects must get along together seamlessly or the advantage of
adding objects to Forth is lost.  For example, one should be able to
write a normal Forth word that can receive and act on *any* object passed
to it via the stack without having to resort to treating the stack item
(object) in a special way.  The Forth word should be able to directly and
simply send any message to any passed-in object.  For example:

 
 : foo ( object -- )
    PRINT   ;  \ print is a message that will be sent to the passed-in object
 
 Foo should work for any class of object that "understands" the PRINT message.
 Foo should work even on object types that have yet to be written.
 The only requirement is that the newly written class/object understand the message PRINT .   
 How each class of object responds to print can of course vary infinitely.
  
 
 =============================
 OPEN, EXTENSIBLE, FLEXIBLE
 =============================
 
The complete source is freely provided for microFMS and that source is
written in ANS standard Forth.  Since Forth itself is open, extensible,
and flexible then microFMS is as well.  One can add or remove as many
behaviors/features as desired. 

 ============================
 THE microFMS CORE USER WORDS
 ============================
 
 The microFMS user words are often the same as in FMS, but there are
differences.  Below is a list of the FMS user words with a brief
description of their purpose.  Stack effects are not shown.  A detailed
usage glossary for these words, with stack effects, follows the list. 
 
  1) CREATE       \ begin a class definition
  2) ;CLASS       \ end a class definition
  3) <SUPER       \ declare the superclass
  4) BYTES        \ instance variable (ivar) declaration
  5) :M           \ begin a method definition
  6) ;M           \ end a method definition
  7) SELF         \ pseudo-ivar for sending message to self
  8) SUPER        \ pseudo-ivar for invoking superclass methods
  9) OBJECT       \ the root class for all classes
 10) >DICT        \ instantiate a nameless object in the dictionary
 11) SEL          \ force a pre-defined word to be redefined as a message
                  \ or create a message outside of a class definition

 ============================
 THE microFMS EXT USER WORDS
 ============================
 
 12) INIT:        \ the message that will always be implicitly sent to newly created objects
 13) >HEAP        \ instantiate a nameless object in the heap, used like >dict
 14) <FREE        \ release the memory of a heap object, see examples
 15) RESTORE      \ Restore the current wordlist and the wordlist search order in the 
                  \ case of a compilation error while compiling a class. Must be manually
                  \ invoked but could be set up by the user to execute automatically
                  \ (implementation dependent).

 ======================
 Use of microFMS Words
 ======================
 
CREATE ( "spaces<name>" -- )
 Begins the definition of a new class.  This is a defining word.  The name of the new class must
 come directly after CREATE.  This is a standard Forth word.

;CLASS
 Ends a class definition.

<SUPER ( "spaces<superclassname>" -- )
 Declares the superclass of the new class being defined.  All classes must have an explicitly
 declared superclass. 
 
BYTES  ( u "spaces<name>" -- )
 The sole primitive for defining new ivars.  Bytes requires the size of the ivar, in addressable
 units and must be followed by the name of the ivar. 
 
:M  ( "spaces<name:>" -- addr methodXT )
 :m <name> ...  :m is analogous to ":" when creating a new colon definition.  For example: locals
 can be used as per normal if desired.  Any word or operation that is legal in a normal Forth colon
 definition is available and legal in a microFMS method definition. 
 :m begins a new method definition.  Can only be used inside a class definition.  Performs three
 functions simultaneously: 1) Defines a new message name only if it has not previously been defined
 in any class (message names have global scope).  2) Defines the method that is to be invoked when
 an object or ivar of that class receives the given message.  3) Implicitly over rides, if
 necessary, an existing method in the superclass chain. 
 
;M  ( addr methodXT -- )
 Ends a method definition and stores the method's XT where it can be subsequently retrieved. 
 Analogous to ";" in a normal colon definition. 
 
SELF ( "spaces<messagename:>"-- addr)
 A pseudo ivar only used in method definitions.  When it is the receiver of a message it will
 compile a late bound message send using the method that has already been defined either in the
 current class or in the superclass chain hierarchy.  When used without a message it will simply
 return the base address of the object. 
 
SUPER ( "spaces<messagename>" --  )
 A pseudo ivar only used in method definitions.  As the receiver of a message it will compile the
 method that has already been defined one level up in the superclass chain hierarchy, skipping over
 the already defined method in the current class definition.  SUPER must be followed by a message
 name.  If the <messagename> method has not been redefined then this use of SUPER will be equivalent
 to the use of SELF.

OBJECT
 The root class of all classes.
 
SEL ( 'name' -- )
 Used to create a new message outside of a class definition.
 
>DICT   ( ^class -- ^obj )
 Instantiates a nameless object in the dictionary.  Must be preceded by the name of a class and
 will return an object pointer.  >DICT can be used at compile time or interpret time. 

>HEAP   ( ^class -- ^obj )
 Instantiates a nameless object in the heap.  Must be preceded by the name of a class and will
 return an object pointer.  >HEAP can be used at compile time or interpret time. An object created
 with >HEAP must ultimately have its allocated memory freed with <FREE.

<FREE  ( ^obj -- )
 Frees the heap memory of an object created using >HEAP.
 
RESTORE
 Restore the current wordlist and the wordlist search order in the 
 case of a compilation error while compiling a class. Must be manually
 invoked but could be set up by the user to execute automatically
 (implementation dependent).

 =======================
 STRUCTURES AND microFMS
 =======================
 microFMS ivars are compatible with Forth 200x structures:
 
 begin-structure point
   1 cells +field p.x
   1 cells +field p.y
 end-structure
 
 begin-structure rect 
   point +field r.tl
   point +field r.br 
 end-structure
 
 create structTest <super object
   rect bytes irect 
 ;class
 
 structTest >dict value t1
 
 t1 . 16873864 

 t1 r.tl p.x . 16873864 
 t1 r.tl p.y . 16873868 
 t1 r.br p.x . 16873872 
 t1 r.br p.y . 16873876

 
 Thanks to Coos Haak for correcting an error in the use of throw in the "find method" word fm.
 Thanks to Josh Grams for pointing out need to make _mfa 64-bit compatible.
 [then]
 
 