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