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