/fth/utils/dump_struct.fth

https://github.com/philburk/pforth · Forth · 122 lines · 107 code · 15 blank · 0 comment · 0 complexity · 448692ea6aa49e03507ee6bd4a395d1d MD5 · raw file

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