git.gag.com Git - debian/pforth/blob - fth/utils/dump_struct.fth

   1 \ @(#) dump_struct.fth 97/12/10 1.1
   2 \ Dump contents of structure showing values and member names.
   3 \
   4 \ Author: Phil Burk
   5 \ Copyright 1987 Phil Burk
   6 \ All Rights Reserved.
   7 \
   8 \ MOD: PLB 9/4/88 Print size too.
   9 \ MOD: PLB 9/9/88 Print U/S , add ADST
  10 \ MOD: PLB 12/6/90 Modified to work with H4th
  11 \ 941109 PLB Converted to pforth.  Added RP detection.
  12 \ 090609 PLB Convert >rel to use->rel and ..! to s!
  13
  14 include? task-member.fth member.fth
  15 include? task-c_struct c_struct.fth
  16
  17 ANEW TASK-DUMP_STRUCT
  18
  19 : EMIT-TO-COLUMN ( char col -- )
  20     out @ - 0 max 80 min 0
  21     DO  dup emit
  22     LOOP drop
  23 ;
  24
  25 VARIABLE SN-FENCE
  26 : STACK.NFAS  ( fencenfa topnfa -- 0 nfa0 nfa1 ... )
  27 \ Fill stack with nfas of words until fence hit.
  28     >r sn-fence !
  29     0 r>  ( set terminator )
  30     BEGIN ( -- 0 n0 n1 ... top )
  31       dup sn-fence @ >
  32     WHILE
  33 \      dup n>link @   \ JForth
  34        dup prevname   \ HForth
  35     REPEAT
  36     drop
  37 ;
  38
  39 : DST.DUMP.TYPE  ( +-size -- , dump data type, 941109)
  40     dup abs 4 =
  41     IF
  42         0<
  43         IF ." RP"
  44         ELSE ." U4"
  45         THEN
  46     ELSE
  47         dup 0<
  48             IF ascii U
  49             ELSE ascii S
  50             THEN emit abs 1 .r
  51     THEN
  52 ;
  53
  54 : DUMP.MEMBER ( addr member-pfa -- , dump member of structure)
  55     ob.stats  ( -- addr offset size )
  56     >r + r> ( -- addr' size )
  57     dup ABS 4 >  ( -- addr' size flag )
  58     IF   cr 2dup swap . . ABS dump
  59     ELSE tuck @bytes 10 .r ( -- size )
  60         3 spaces dst.dump.type
  61     THEN
  62 ;
  63
  64 VARIABLE DS-ADDR
  65 : DUMP.STRUCT ( addr-data addr-structure -- )
  66     >newline swap >r  ( -- as , save addr-data for dumping )
  67 \    dup cell+ @ over +  \ JForth
  68     dup code> >name swap cell+ @ over +   \ HForth
  69     stack.nfas   ( fill stack with nfas of members )
  70     BEGIN
  71         dup
  72     WHILE   ( continue until non-zero )
  73         dup name> >body r@ swap dump.member
  74         bl 18 emit-to-column id. cr
  75         ?pause
  76     REPEAT drop rdrop
  77 ;
  78
  79 : DST ( addr <name> -- , dump contents of structure )
  80     ob.findit
  81     state @
  82     IF [compile] literal compile dump.struct
  83     ELSE dump.struct
  84     THEN
  85 ; immediate
  86
  87 : ADST ( absolute_address -- , dump structure )
  88     use->rel [compile] dst     \ mod 090609
  89 ; immediate
  90
  91 \ For Testing Purposes
  92 false [IF]
  93 :STRUCT GOO
  94     LONG DATAPTR
  95     SHORT GOO_WIDTH
  96     USHORT GOO_HEIGHT
  97 ;STRUCT
  98
  99 :STRUCT FOO
 100     LONG ALONG1
 101     STRUCT GOO AGOO
 102     SHORT ASHORT1
 103     BYTE ABYTE
 104     BYTE ABYTE2
 105 ;STRUCT
 106
 107 FOO AFOO
 108 : AFOO.INIT
 109     $ 12345678 afoo s! along1
 110     $ -665 afoo s! ashort1
 111     $ 21 afoo s! abyte
 112     $ 43 afoo s! abyte2
 113     -234 afoo .. agoo s! goo_height
 114 ;
 115 afoo.init
 116
 117 : TDS ( afoo -- )
 118     dst foo
 119 ;
 120
 121 [THEN]
 122