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