fth/utils/dump_struct.fth

\ @(#) dump_struct.fth 97/12/10 1.1
\ Dump contents of structure showing values and member names.
\
\ Author: Phil Burk
\ Copyright 1987 Phil Burk
\ All Rights Reserved.
\
\ MOD: PLB 9/4/88 Print size too.
\ MOD: PLB 9/9/88 Print U/S , add ADST
\ MOD: PLB 12/6/90 Modified to work with H4th
\ 941109 PLB Converted to pforth.  Added RP detection.

include? task-member member.fth
include? task-c_struct c_struct.fth

ANEW TASK-DUMP_STRUCT

: EMIT-TO-COLUMN ( char col -- )
        out @ - 0 max 80 min 0
        DO  dup emit
        LOOP drop
;

VARIABLE SN-FENCE
: STACK.NFAS  ( fencenfa topnfa -- 0 nfa0 nfa1 ... )
\ Fill stack with nfas of words until fence hit.
    >r sn-fence !
    0 r>  ( set terminator )
    BEGIN ( -- 0 n0 n1 ... top )
      dup sn-fence @ >
    WHILE
\      dup n>link @   \ JForth
       dup prevname   \ HForth
    REPEAT
    drop
;

: DST.DUMP.TYPE  ( +-size -- , dump data type, 941109)
        dup abs 4 =
        IF
                0<
                IF ." RP"
                ELSE ." U4"
                THEN
        ELSE
                dup 0<
                IF ascii U
                ELSE ascii S
                THEN emit abs 1 .r
        THEN
;

: DUMP.MEMBER ( addr member-pfa -- , dump member of structure)
    ob.stats  ( -- addr offset size )
    >r + r> ( -- addr' size )
    dup ABS 4 >  ( -- addr' size flag )
    IF   cr 2dup swap . . ABS dump
    ELSE tuck @bytes 10 .r ( -- size )
        3 spaces dst.dump.type
    THEN
;

VARIABLE DS-ADDR
: DUMP.STRUCT ( addr-data addr-structure -- )
    >newline swap >r  ( -- as , save addr-data for dumping )
\    dup cell+ @ over +  \ JForth
        dup code> >name swap cell+ @ over +   \ HForth
        stack.nfas   ( fill stack with nfas of members )
    BEGIN
        dup
    WHILE   ( continue until non-zero )
        dup name> >body r@ swap dump.member
        bl 18 emit-to-column id. cr
        ?pause
    REPEAT drop rdrop
;

: DST ( addr <name> -- , dump contents of structure )
    ob.findit
    state @
    IF [compile] literal compile dump.struct
    ELSE dump.struct
    THEN
; immediate

: ADST ( absolute_address -- , dump structure )
    >rel [compile] dst
; immediate

\ For Testing Purposes
false .IF
:STRUCT GOO
    LONG DATAPTR
    SHORT GOO_WIDTH
    USHORT GOO_HEIGHT
;STRUCT

:STRUCT FOO
    LONG ALONG1
    STRUCT GOO AGOO
    SHORT ASHORT1
    BYTE ABYTE
    BYTE ABYTE2
;STRUCT

FOO AFOO
: AFOO.INIT
    $ 12345678 afoo ..! along1
    $ -665 afoo ..! ashort1
    $ 21 afoo ..! abyte
    $ 43 afoo ..! abyte2
    -234 afoo .. agoo ..! goo_height
;
afoo.init

: TDS ( afoo -- )
    dst foo
;

.THEN