Pascal Compiler [4R0.20-4] 3/01/12 12:03 Page 1 1 0 0:d 1 { This item is the property of SofTech Microsystems, Inc., } 2 0 0:d 1 { and it may be used, copied or distributed only as permitted } 3 0 0:d 1 { in a written license form that company. } 4 0 0:d 1 5 0 0:d 1 { This is an umplubished work copyright (c) 1981, 1982, 1983 } 6 0 0:d 1 { by SofTech Microsystems, Inc. } 7 0 0:d 1 8 0 0:d 1 {$C Copyright (c) 1981,82,83 by SofTech Microsystems, Inc. } 9 0 0:d 1 10 0 0:d 1 { Written by G. Hutchins } 11 0 0:d 1 12 0 0:d 1 { This unit is a template for all symbolic debug segments. It 13 0 0:d 1 contains procedures that manipulate the constant pool which 14 0 0:d 1 is a linked list of procedures of the following structure: 15 0 0:d 1 16 0 0:d 1 procnode = record 17 {commented ';'} name:myalpha; -- procedure name 18 {commented ';'} num :integer; -- corresponding procedure number 19 {commented ';'} firstline:integer; -- first line # of procedure 20 {commented ';'} lastline :integer; -- last line # of procedure 21 {commented ';'} procptr :^procnode; -- ptr to next procedure 22 {commented ';'} varptr :^varnode; -- ptr to procedure's variables 23 {commented ';'} lineoffsets : -- mapping of line # to p-code offset 24 {commented ';'} array [1..lastline - firstline + 1] of integer; 25 {commented ';'} end; 26 {commented ';'} 27 {commented ';'} varnode = record 28 {commented ';'} name:myalpha; -- symbol name 29 {commented ';'} offset:integer; -- corresponding symbol offset 30 {commented ';'} tipe:integer; -- symbol type 31 {commented ';'} size:integer; -- symbol size 32 {commented ';'} llink:^varnode; -- ptr to left link of binary tree 33 {commented ';'} rlink:^varnode; -- ptr to right link of binary tree 34 {commented ';'} end; 35 0 0:d 1 } 36 0 0:d 1 37 0 0:d 1 {$d debug+} 38 2 1:d 1 unit debug_info_seed; 39 2 1:d 1 interface 40 2 1:d 1 type myalpha=packed array [1..8] of char; 41 2 1:d 1 procrec=record 42 2 1:d 1 procnum:integer; 43 2 1:d 1 first:integer; 44 2 1:d 1 last:integer; 45 2 1:d 1 end; 46 2 1:d 1 47 2 1:d 1 symrec=packed record 48 2 1:d 1 offset:integer; 49 2 1:d 1 symtype:integer; 50 2 1:d 1 size:integer; 51 2 1:d 1 end; 52 2 1:d 1 53 2 1:d 1 function gotprocnum(var info:procrec;var infosize:integer; 54 2 1:d 3 var prochead:integer;var procname:myalpha ) : boolean; 55 2 1:d 1 56 2 1:d 1 function gotsymoffset(var info:symrec;var infosize,symptr:integer; 57 2 1:d 4 var symname:myalpha ) : boolean; 58 2 1:d 1 59 2 1:d 1 function gotlineoffset(var offset,linenum,first,prochead:integer ) : boolean; 60 2 1:d 1 61 2 1:d 1 function gotcurrentproc(var procnum,nameaddr:integer; 62 2 1:d 3 var procname:myalpha ) : boolean; 63 2 1:d 1 64 2 1:d 1 implementation 65 2 1:d 1 const 66 2 1:d 1 sym_ref_dict=2; 67 2 1:d 1 sto=196; 68 2 1:d 1 lco=130; 69 2 1:d 1 inc=231; 70 2 1:d 1 mov=197; 71 2 1:d 1 eqbyte=185; 72 2 1:d 1 ltbyte=186; 73 2 1:d 1 cxg=148; 74 2 1:d 1 lpr=157; 75 2 1:d 1 sind0=120; 76 2 1:d 1 sind1=121; 77 2 1:d 1 sind2=122; 78 2 1:d 1 dup1=226; 79 2 1:d 1 swap=189; 80 2 1:d 1 adi=162; 81 2 1:d 1 82 2 1:d 1 var wrongsex:boolean; 83 2 1:d 2 84 2 1:d 2 function flip_word(source:integer) : integer; 85 2 6:d 1 type byte=0..255; 86 2 6:d 1 var trix:packed record 87 2 6:d 1 case boolean of 88 2 6:d 1 true : (i:integer); 89 2 6:d 1 false: (b2,b1:byte); 90 2 6:d 1 end; 91 2 6:0 0 begin 92 2 6:1 0 trix.i:=source; 93 2 6:1 2 with trix do if wrongsex then flipword:=b1*256 + b2 else flipword:=i; 94 2 1:0 0 end; 95 2 1:0 0 96 2 1:d 1 procedure flip3words(var first,second,third:integer); 97 2 7:0 0 begin 98 2 7:1 0 first:=flipword(first); 99 2 7:1 7 second:=flipword(second); 100 2 7:1 14 third:=flipword(third); 101 2 1:0 0 end; 102 2 1:0 0 103 2 1:0 0 {get the next byte ptr out of the constant pool and flip it if 104 2 1:0 0 necessary} 105 2 1:d 1 function getnext(addr:integer; delta:integer) : integer; 106 2 8:d 1 var result:integer; 107 2 8:0 0 begin 108 2 8:0 0 {getpoolbytes(dest,pooldes,byteoffset,nbytes)} 109 2 8:1 0 pmachine(^result,(8),lpr,sind2,dup1,sind0,swap,sind1, 110 2 8:1 8 (addr+delta),adi,(2),cxg,1,24); 111 2 8:1 16 getnext:=flipword(result); 112 2 1:0 0 end; 113 2 1:0 0 114 2 1:0 0 {get sym info from addr, the current constant pool byte address} 115 2 1:d 1 procedure getsyminfo(var info:symrec; addr,nbytes:integer); 116 2 9:0 0 begin 117 2 9:0 0 {getpoolbytes(dest,pooldes,byteoffset,nbytes)} 118 2 9:1 0 pmachine(^info,(8),lpr,sind2,dup1,sind0,swap,sind1, 119 2 9:1 8 (addr),adi,(nbytes),cxg,1,24); 120 2 9:1 14 with info do 121 2 9:2 16 flip3words(offset,symtype,size); 122 2 1:0 0 end; 123 2 1:0 0 124 2 1:0 0 {get procinfo from addr, the current constant pool byte address} 125 2 1:d 1 procedure getprocinfo(var info:procrec; addr,nbytes:integer); 126 2 10:0 0 begin 127 2 10:0 0 {getpoolbytes(dest,pooldes,byteoffset,nbytes)} 128 2 10:1 0 pmachine(^info,(8),lpr,sind2,dup1,sind0,swap,sind1, 129 2 10:1 8 (addr),adi,(nbytes),cxg,1,24); 130 2 10:1 14 with info do 131 2 10:2 16 flip3words(procnum,first,last); 132 2 1:0 0 end; 133 2 1:0 0 134 2 1:0 0 {get the 8 character byte array from addr, the constant pool byte address} 135 2 1:d 1 procedure getname(var name:myalpha; addr:integer); 136 2 11:d 1 var localname:myalpha; 137 2 11:0 0 begin 138 2 11:0 0 {getpoolbytes(dest,pooldes,byteoffset,nbytes)} 139 2 11:1 0 pmachine(^localname,(8),lpr,sind2,dup1,sind0,swap,sind1, 140 2 11:1 8 (addr),adi,(8),cxg,1,24); 141 2 11:1 14 name:=localname; 142 2 1:0 0 end; 143 2 1:0 0 144 2 1:0 0 {set prochead to the address of the constant pool and 145 2 1:0 0 wronsex to true if the sex of this segment is different than 146 2 1:0 0 the host} 147 2 1:d 1 procedure sex(var prochead:integer); 148 2 12:d 1 var procnum:integer; 149 2 12:0 0 begin 150 2 12:1 0 pmachine(^prochead,lco,sym_ref_dict,sto); {get address of constatn pool } 151 2 12:1 4 {getpoolbytes(dest,pooldes,byteoffset,nbytes)} 152 2 12:1 4 pmachine(^procnum,(8),lpr,sind2,dup1,sind0,swap,sind1, 153 2 12:1 12 (prochead+8),adi,(2),cxg,1,24); 154 2 12:1 21 wrongsex:=procnum>255; {use as a sex indicator} 155 2 1:0 0 end; 156 2 1:0 0 157 2 1:0 0 {Search through the binary tree TREEPTR for NAME, if found set INFO to the 158 2 1:0 0 node's info} 159 2 1:d 1 function search(var treeptr:integer;var name:myalpha;var info:symrec ) : boolean; 160 2 13:d 1 var foundname,branchright:boolean; 161 2 13:d 3 tempname:myalpha; 162 2 13:0 0 begin 163 2 13:1 0 repeat 164 2 13:2 0 if treeptr<>0 then 165 2 13:3 5 begin 166 2 13:4 5 pmachine(^foundname,(treeptr), 167 2 13:4 8 ^name,eqbyte,0,1,8,sto); {foundname:=treeptr^.name=name} 168 2 13:4 14 if not(foundname) then 169 2 13:5 17 begin 170 2 13:6 17 pmachine(^branchright,(treeptr), 171 2 13:6 20 ^name,ltbyte,0,1,8,sto);{branchright:=treeptr^.name>name} 172 2 13:6 26 if branchright then {branch to left or right subtree} 173 2 13:7 29 treeptr:=getnext(treeptr,16) {treeptr:=treeptr^.rlink} 174 2 13:6 34 else 175 2 13:7 39 treeptr:=getnext(treeptr,14); {treeptr:=treeptr^.llink} 176 2 13:5 47 end else 177 2 13:5 49 getsyminfo(info,treeptr+8,6); {found node, get info} 178 2 13:3 57 end; 179 2 13:1 57 until foundname or (treeptr=0); 180 2 13:1 65 search:=foundname; 181 2 1:0 0 end; 182 2 1:0 0 183 2 1:0 0 {Get PROCNAME's INFO and set PROCHEAD to point to the procedure} 184 {commented ';'} function gotprocnum{(var info:procrec;infosize:integer;var prochead:integer; 185 2 1:d 1 var procname:myalpha ) : boolean}; 186 2 2:d 1 var foundname:boolean; 187 2 2:0 0 begin 188 2 2:1 0 sex(prochead); {get seg rel address of const pool, and byte sex} 189 2 2:1 3 repeat 190 2 2:2 3 pmachine(^foundname,(prochead), 191 2 2:2 6 ^procname,eqbyte,0,1,8,sto); {foundname:=prochead^.name=proccname} 192 2 2:2 12 if not foundname then 193 2 2:3 15 prochead:=getnext(prochead,14) {prochead:=prochead^.procptr} 194 2 2:2 20 else 195 2 2:3 25 getprocinfo(info,prochead+8,6) {info:=prochead^.info} 196 2 2:1 31 until foundname or (prochead=0); 197 2 2:1 41 gotprocnum:=foundname; 198 2 1:0 0 end; 199 2 1:0 0 200 2 1:0 0 {Given a procedure ptr search its binary tree of variables for SYMNAME 201 2 1:0 0 and return SYMNAME's INFO} 202 {commented ';'} function gotsymoffset{(var info:symrec;var infosize, 203 2 1:d 1 symptr:integer;var symname:myalpha ) : boolean}; 204 2 3:0 0 begin 205 2 3:1 0 symptr:=getnext(symptr,16); {get head of symtree} 206 2 3:1 8 gotsymoffset:=search(symptr,symname,info); {find symbol and return info} 207 2 1:0 0 end; 208 2 1:0 0 209 2 1:0 0 {Given a line number return its corresponding pcode offset} 210 2 1:d 1 function gotlineoffset{(var offset,linenum,first,prochead:integer) : boolean}; 211 2 4:0 0 begin 212 2 4:0 0 {offset:=prochead^.lineoffset[linenum-first+1]} 213 2 4:1 0 offset:=getnext(prochead,18+(linenum-first)*2); 214 2 4:1 16 gotlineoffset:=offset>=0; 215 2 1:0 0 end; 216 2 1:0 0 217 2 1:0 0 {Given a proc # return the PROCNAME and proc ptr (NAMEADDR)} 218 {commented ';'} function gotcurrentproc{(var procnum,nameaddr:integer; 219 2 1:d 1 var procname:myalpha ) : boolean}; 220 2 5:d 1 var foundnum:boolean; 221 2 5:0 0 begin 222 2 5:1 0 gotcurrentproc:=false; 223 2 5:1 2 sex(nameaddr); 224 2 5:1 5 repeat 225 2 5:2 5 foundnum := procnum = getnext(nameaddr,8); 226 2 5:2 15 if foundnum then 227 2 5:3 18 getname(procname,nameaddr) {found, procname:=prochead^.name} 228 2 5:2 21 else 229 2 5:3 25 nameaddr:=getnext(nameaddr,14); 230 2 5:1 33 until foundnum or (nameaddr=0); 231 2 5:1 41 gotcurrentproc:=foundnum; 232 2 1:0 0 end; 233 2 1:0 0 234 2 :0 0 end. End of Compilation.