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