{ This item is the property of SofTech Microsystems, Inc.,    }
{ and it may be used, copied or distributed only as permitted }
{ in a written license form that company.		      }

{ This is an umplubished work copyright (c) 1981, 1982, 1983  }
{ by SofTech Microsystems, Inc.				      }

{$C Copyright (c) 1981,82,83 by SofTech Microsystems, Inc.    }

{ Written by G. Hutchins				      }

{ This unit is a template for all symbolic debug segments.  It
  contains procedures that manipulate the constant pool which 
  is a linked list of procedures of the following structure:
  
    procnode = record
		 name:myalpha;	      -- procedure name
		 num :integer;	      -- corresponding procedure number
		 firstline:integer;   -- first line # of procedure
		 lastline :integer;   -- last line # of procedure
		 procptr  :^procnode; -- ptr to next procedure
		 varptr	  :^varnode;  -- ptr to procedure's variables
		 lineoffsets :	      -- mapping of line # to p-code offset
			       array [1..lastline - firstline + 1] of integer;
	       end;
	       
    varnode = record
		name:myalpha;	      -- symbol name
		offset:integer;	      -- corresponding symbol offset
		tipe:integer;	      -- symbol type
		size:integer;	      -- symbol size
		llink:^varnode;	      -- ptr to left link of binary tree 
		rlink:^varnode;	      -- ptr to right link of binary tree
	      end;
}

{$d debug+}
unit debug_info_seed;
interface
type myalpha=packed array [1..8] of char;
     procrec=record
	       procnum:integer;
	       first:integer;
	       last:integer;
	     end;
	     
     symrec=packed record
	      offset:integer;
	      symtype:integer;
	      size:integer;
	    end;

function gotprocnum(var info:procrec;var infosize:integer;
		    var prochead:integer;var procname:myalpha	    ) : boolean;

function gotsymoffset(var info:symrec;var infosize,symptr:integer;
		      var symname:myalpha			    ) : boolean;
			  
function gotlineoffset(var offset,linenum,first,prochead:integer  ) : boolean;

function gotcurrentproc(var procnum,nameaddr:integer;
			var procname:myalpha			     ) : boolean;

implementation
const
   sym_ref_dict=2;
   sto=196;
   lco=130;
   inc=231;
   mov=197;
   eqbyte=185;
   ltbyte=186;
   cxg=148;
   lpr=157;
   sind0=120;
   sind1=121;
   sind2=122;
   dup1=226;
   swap=189;
   adi=162;
   
var wrongsex:boolean;

  function flip_word(source:integer) : integer;
  type byte=0..255;
  var trix:packed record
	     case boolean of
	       true : (i:integer);
	       false: (b2,b1:byte);
	   end;
  begin
    trix.i:=source;
    with trix do if wrongsex then flipword:=b1*256 + b2 else flipword:=i;
  end;
  
  procedure flip3words(var first,second,third:integer);
  begin
    first:=flipword(first);
    second:=flipword(second);
    third:=flipword(third);
  end;
  
  {get the next byte ptr out of the constant pool and flip it if
   necessary}
  function getnext(addr:integer; delta:integer) : integer;
  var result:integer;
  begin
    {getpoolbytes(dest,pooldes,byteoffset,nbytes)}
    pmachine(^result,(8),lpr,sind2,dup1,sind0,swap,sind1,
	     (addr+delta),adi,(2),cxg,1,24);
    getnext:=flipword(result);
  end;
  
  {get sym info from addr, the current constant pool byte address}
  procedure getsyminfo(var info:symrec; addr,nbytes:integer);
  begin
    {getpoolbytes(dest,pooldes,byteoffset,nbytes)}
    pmachine(^info,(8),lpr,sind2,dup1,sind0,swap,sind1,
	     (addr),adi,(nbytes),cxg,1,24);
    with info do
      flip3words(offset,symtype,size);
  end;
  
  {get procinfo from addr, the current constant pool byte address}
  procedure getprocinfo(var info:procrec; addr,nbytes:integer);
  begin
    {getpoolbytes(dest,pooldes,byteoffset,nbytes)}
    pmachine(^info,(8),lpr,sind2,dup1,sind0,swap,sind1,
	     (addr),adi,(nbytes),cxg,1,24);
    with info do
      flip3words(procnum,first,last);
  end;
  
  {get the 8 character byte array from addr, the constant pool byte address}
  procedure getname(var name:myalpha; addr:integer);
  var localname:myalpha;
  begin
    {getpoolbytes(dest,pooldes,byteoffset,nbytes)}
    pmachine(^localname,(8),lpr,sind2,dup1,sind0,swap,sind1,
	     (addr),adi,(8),cxg,1,24);
    name:=localname;
  end;
    
  {set prochead to the address of the constant pool and 
   wronsex to true if the sex of this segment is different than
   the host}
  procedure sex(var prochead:integer);
  var procnum:integer;
  begin
    pmachine(^prochead,lco,sym_ref_dict,sto);  {get address of constatn pool }
    {getpoolbytes(dest,pooldes,byteoffset,nbytes)}
    pmachine(^procnum,(8),lpr,sind2,dup1,sind0,swap,sind1,
	     (prochead+8),adi,(2),cxg,1,24);
    wrongsex:=procnum>255;		       {use as a sex indicator}
  end;

{Search through the binary tree TREEPTR for NAME, if found set INFO to the
 node's info}
function search(var treeptr:integer;var name:myalpha;var info:symrec ) : boolean;
var foundname,branchright:boolean;
    tempname:myalpha;
begin
  repeat 
    if treeptr<>0 then
    begin
      pmachine(^foundname,(treeptr),
	       ^name,eqbyte,0,1,8,sto); {foundname:=treeptr^.name=name}
      if not(foundname) then
      begin
	pmachine(^branchright,(treeptr),
		 ^name,ltbyte,0,1,8,sto);{branchright:=treeptr^.name>name}
	if branchright then		    {branch to left or right subtree}
	  treeptr:=getnext(treeptr,16)	    {treeptr:=treeptr^.rlink}
	else
	  treeptr:=getnext(treeptr,14);	    {treeptr:=treeptr^.llink}
      end else
	getsyminfo(info,treeptr+8,6);	    {found node, get info}
    end;
  until foundname or (treeptr=0);
  search:=foundname;
end;
   
{Get PROCNAME's INFO and set PROCHEAD to point to the procedure}
function gotprocnum{(var info:procrec;infosize:integer;var prochead:integer;
		     var procname:myalpha			    ) : boolean};
var foundname:boolean;
begin
  sex(prochead);    {get seg rel address of const pool, and byte sex}
  repeat
    pmachine(^foundname,(prochead),
	     ^procname,eqbyte,0,1,8,sto); {foundname:=prochead^.name=proccname}
    if not foundname then		   
      prochead:=getnext(prochead,14)	  {prochead:=prochead^.procptr}
    else
      getprocinfo(info,prochead+8,6)	  {info:=prochead^.info}
  until foundname or (prochead=0);
  gotprocnum:=foundname;
end;

{Given a procedure ptr search its binary tree of variables for SYMNAME
 and return SYMNAME's INFO}
function gotsymoffset{(var info:symrec;var infosize,
			   symptr:integer;var symname:myalpha	  ) : boolean};
begin
  symptr:=getnext(symptr,16);			 {get head of symtree}
  gotsymoffset:=search(symptr,symname,info);	 {find symbol and return info}
end;

{Given a line number return its corresponding pcode offset}
function gotlineoffset{(var offset,linenum,first,prochead:integer) : boolean};
begin
  {offset:=prochead^.lineoffset[linenum-first+1]}
  offset:=getnext(prochead,18+(linenum-first)*2);
  gotlineoffset:=offset>=0;
end;

{Given a proc # return the PROCNAME and proc ptr (NAMEADDR)}
function gotcurrentproc{(var procnum,nameaddr:integer;
			 var procname:myalpha			   ) : boolean};
var foundnum:boolean;
begin
  gotcurrentproc:=false;
  sex(nameaddr);
  repeat
    foundnum := procnum = getnext(nameaddr,8);
    if foundnum then
      getname(procname,nameaddr)    {found, procname:=prochead^.name}
    else
      nameaddr:=getnext(nameaddr,14);
  until foundnum or (nameaddr=0);
  gotcurrentproc:=foundnum;
end;

end.