relicense to 0BSD

[pforth] / fth / member.fth

\ @(#) member.fth 98/01/26 1.2
\ This files, along with c_struct.fth, supports the definition of
\ structure members similar to those used in 'C'.
\
\ Some of this same code is also used by ODE,
\ the Object Development Environment.
\
\ Author: Phil Burk
\ Copyright 1994 3DO, Phil Burk, Larry Polansky, David Rosenboom
\
\ Permission to use, copy, modify, and/or distribute this
\ software for any purpose with or without fee is hereby granted.
\
\ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
\ WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
\ WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
\ THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
\ CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
\ FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
\ CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
\ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
\
\ MOD: PLB 1/16/87 Use abort" instead of er.report.
\ MOD: PLB 2/19/87 Made OB.MEMBER immediate, use literal.
\ MOD: PLB/MDH 6/7/88 Use 16 bit values in member defs.
\ MOD: PLB 7/31/88 Add USHORT and UBYTE.
\ MOD: PLB 1/20/89 Treat LITERAL as state sensitive.
\ MOD: RDG 9/19/90 Add floating point member support.
\ MOD: PLB 6/10/91 Add RPTR
\ 00001 PLB 8/3/92 Make RPTR a -4 for S@ and S!
\ 941102 RDG port to pforth
\ 941108 PLB more porting to pforth. Use ?LITERAL instead os smart literal.
\ 960710 PLB align long members for SUN

ANEW TASK-MEMBER.FTH
decimal

: FIND.BODY   ( -- , pfa true | $name false , look for word in dict. )
\ Return address of parameter data.
     bl word find
     IF  >body true
     ELSE false
     THEN
;

\ Variables shared with object oriented code.
VARIABLE OB-STATE  ( Compilation state. )
VARIABLE OB-CURRENT-CLASS  ( ABS_CLASS_BASE of current class )
1 constant OB_DEF_CLASS   ( defining a class )
2 constant OB_DEF_STRUCT  ( defining a structure )

\ A member contains:
\   cell size of data in bytes (1, 2, cell)
\   cell offset within structure

cell 1- constant CELL_MASK
cell negate constant -CELL
cell constant OB_OFFSET_SIZE

: OB.OFFSET@ ( member_def -- offset ) @ ;
: OB.OFFSET, ( value -- ) , ;
: OB.SIZE@ ( member_def -- offset )
        ob_offset_size + @ ;
: OB.SIZE, ( value -- ) , ;

( Members are associated with an offset from the base of a structure. )
: OB.MAKE.MEMBER ( +-bytes -- , make room in an object at compile time)
    dup >r  ( -- +-b , save #bytes )
    ABS     ( -- |+-b| )
    ob-current-class @ ( -- b addr-space)
    tuck @          ( as #b c , current space needed )
    over CELL_MASK and 0=        ( multiple of cell? )
    IF
        aligned
    ELSE
        over 1 and 0=   ( multiple of two? )
        IF
            even-up
        THEN
    THEN
    swap over + rot !    ( update space needed )
\ Save data in member definition. %M
    ob.offset,    ( save old offset for ivar )
    r> ob.size,   ( store size in bytes for ..! and ..@ )
;

\ Unions allow one to address the same memory as different members.
\ Unions work by saving the current offset for members on
\ the stack and then reusing it for different members.
: UNION{  ( -- offset , Start union definition. )
    ob-current-class @ @
;

: }UNION{ ( old-offset -- new-offset , Middle of union )
    union{     ( Get current for }UNION to compare )
    swap ob-current-class @ !  ( Set back to old )
;

: }UNION ( offset -- , Terminate union definition, check lengths. )
    union{ = NOT
    abort" }UNION - Two parts of UNION are not the same size!"
;

\ Make members compile their offset, for "disposable includes".
: OB.MEMBER  ( #bytes -- , make room in an object at compile time)
           ( -- offset , run time for structure )
    CREATE ob.make.member immediate
    DOES> ob.offset@  ( get offset ) ?literal
;

: OB.FINDIT  ( <thing> -- pfa , get pfa of thing or error )
    find.body not
    IF cr count type ."    ???"
       true abort" OB.FINDIT - Word not found!"
    THEN
;

: OB.STATS ( member_pfa --  offset #bytes )
    dup ob.offset@ swap
    ob.size@
;

: OB.STATS? ( <member> -- offset #bytes )
    ob.findit ob.stats
;

: SIZEOF() ( <struct>OR<class> -- #bytes , lookup size of object )
    ob.findit @
    ?literal
; immediate

\ Basic word for defining structure members.
: BYTES ( #bytes -- , error check for structure only )
    ob-state @ ob_def_struct = not
    abort" BYTES - Only valid in :STRUCT definitions."
    ob.member
;

\ Declare various types of structure members.
\ Negative size indicates a signed member.
: BYTE ( <name> -- , declare space for a byte )
    -1 bytes ;

: SHORT ( <name> -- , declare space for a 16 bit value )
    -2 bytes ;

: LONG ( <name> -- )
    cell bytes ;

: UBYTE ( <name> -- , declare space for signed  byte )
    1 bytes ;

: USHORT ( <name> -- , declare space for signed 16 bit value )
    2 bytes ;


\ Aliases
: APTR    ( <name> -- ) long ;
: RPTR    ( <name> -- ) -cell bytes ; \ relative relocatable pointer 00001
: ULONG   ( <name> -- ) long ;

: STRUCT ( <struct> <new_ivar> -- , define a structure as an ivar )
    [compile] sizeof() bytes
;