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

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