unit gname;
interface
uses sysutils,windows,common,savefile,menus,mainwind;
const
  GNAME_MAXLEN =40;

type
  listitem =pchar;
  plistptr =^tlistptr;
  tlistptr =array[0..100000] of listitem;

  pgnameitem=^tgnameitem;
  tgnameitem=packed record
    addr:lptr;
    nam :pchar;
  end;

  pvfunc=function(l1,l2:listitem):integer;
  pdfunc=procedure(l:listitem);
{
  >* basic list class, use with inheritance.                               *
  >* - maintains a list class of pointers.                                 *
  >* - can add/insert items                                                *
  >* - can use binary search                                               *
  >* - will resize array upwards in 4k chunks.                             *
  >* - downsizing has not been added but will be carried out when a        *
  >* disassembly is saved and reloaded as a database.                      *
  >* this class is central to many other classes.                          *
  >*                                                                       *
  >* Note: there is only one listiter per list. Some functions reset or    *
  >* change listiter, like find, and so any derived classes must be        *
  >* careful not to try and move through a list whilst inadvertently using *
  >* these functions. (It is also why the secondary program thread must be *
  >* often stopped during user searches, and dialogs since otherwise the   *
  >* databases would be constantly changing.                               *
}
  tslist=class
//  private
    listptr:plistptr;
    cfunc  :pvfunc;
    delfunc:pdfunc;
    listsize,maxsize,listiter:integer;
  public
    constructor create;
    destructor destroy;override;
    procedure setcomparefunc(vfunc:pvfunc);
    procedure setdelfunc(dfunc:pdfunc);
    procedure addto(l:listitem);
    procedure delfrom(l:listitem);
    function find(l:listitem):listitem;
    procedure resetiterator;
    function nextiterator:listitem;
    function lastiterator:listitem;
    function processqueue:listitem;
    function peekfirst:listitem;
    function numlistitems:integer;
  end;

// generic name class                                                    *
// the basic gname class consists of a name and a location, and these    *
// are the basic management functions for the class. The class is        *
// inherited by names, exports and imports which are all treated very    *
// slightly differently. These are essentially the common routines       *
// The gname class itself inherits the list class for management of the  *
// array of named locations.                                             *
  tgname=class(tslist)
  public
    repeater:boolean;
  public
    constructor create;
    procedure addname(loc:lptr;nm:pchar);
    function isname(loc:lptr):boolean;
    procedure printname(loc:lptr);
    function savedb(sf:tsavefile):boolean;
    function loaddb(sf:tsavefile):boolean;
    procedure delname(loc:lptr);
  private
    procedure demangle(name_:pchar);
 end;

// the names class is an extension of the generic names class gname.cpp  *
// for general names, as opposed to exports and imports which extend the *
// gname class slightly differently                                      *
  tnames=class(tgname)
  public
    constructor create;
    procedure namesviewer;
    procedure namecurrloc(nameit:pchar);
    procedure nameloc;
  end;

var
  nam:tnames;

implementation
uses datas,disasm,disio,schedule;

// nme is used to hold a name entered in a dialog                        *
var nme:pchar;

constructor tnames.create;
begin
  inherited create;
end;

// gname compare function                                                *
// - the compare function for ordering the list of names                 *
// - the names are kept in location order                                *
function gnamecfunc(i,j:listitem):integer;
begin
  if pgnameitem(i).addr.o=pgnameitem(j).addr.o then begin
    result:=0; exit;
  end;
  if dword(pgnameitem(i).addr.o)>dword(pgnameitem(j).addr.o) then begin
    result:=1; exit;
  end; result:=-1;
end;

// gname delete function                                                 *
// - first we delete any name string, and then the actual name/location  *
//   struct                                                              *
procedure gnamedfunc(i:listitem);
begin
  freemem(pgnameitem(i).nam);
  dispose(pgnameitem(i));
end;

// gname constructor function                                            *
// - here we simply set up the compare and deletion functions for the    *
//   underlying list of names                                            *
constructor tgname.create;
begin
  inherited create;
  setcomparefunc(gnamecfunc);
  setdelfunc(gnamedfunc);
end;
{
  >* addname                                                               *
  >* - this is to add a name to the list of names.                         *
  >* - if the address is not covered in our list of segments then we       *
  >*   ignore the request                                                  *
  >* - we check that it is ok to name the location before naming it. This  *
  >*   basically ensures that names cannot be added in the middle of a     *
  >*   disassembled instruction, etc. It should not affect imports/exports *
  >*   since these will be named prior to disassembly                      *
  >* - the name is copied and a new string created for it, so the calling  *
  >*   function must delete any memory created to hold the name            *
  >* - if the same location is named twice then the first name is deleted  *
  >* - the name is added to the disassembly so that it appears in the      *
  >*   listing.                                                            *
  >* - naming a location with "" results in any name being deleted         *
}
procedure tgname.addname(loc:lptr;nm:pchar);
var newname,checkdup:pgnameitem;
begin
  // check for non-existant address added v2.20
  if dta.findseg(loc)=nil then exit;
  if not dsm.oktoname(loc) then exit; // check not in the middle of an instruction.
  newname:=new(pgnameitem);
  getmem(newname.nam,strlen(nm)+1);
  strcopy(newname.nam,nm);
  demangle(@newname.nam);
  newname.addr:=loc;
  checkdup:=pgnameitem(find(listitem(newname)));
  // just add it once.
  if checkdup<>nil then if checkdup.addr.o=loc.o then begin
    dispose(checkdup.nam);
    checkdup.nam:=newname.nam;
    dispose(newname);
    dsm.delcomment(loc,dsmnameloc);
    if strlen(checkdup.nam)<>0 then dsm.discomment(loc,dsmnameloc,checkdup.nam)
    else delfrom(listitem(checkdup));
    exit;
  end;
  if strlen(newname.nam)=0 then begin
    dispose(newname.nam);
    dispose(newname);
    exit;
  end;
  addto(listitem(newname));
  dsm.discomment(loc,dsmnameloc,newname.nam);
end;

// isname                                                                *
// - returns TRUE if loc has a name                                      *
function tgname.isname(loc:lptr):boolean;
var
  checkit:tgnameitem;
  findit :pgnameitem;
begin
  result:=false;
  checkit.addr:=loc;
  findit:=pgnameitem(find(listitem(@checkit)));
  if findit<>nil then if eq(findit.addr,loc) then result:=true;
end;

// printname                                                             *
// - prints name to last buffer location in mainwindow buffering array   *
// - use with isname, for example:                                       *
//   if(name.isname(loc))name.printname(loc); etc                        *
procedure tgname.printname(loc:lptr);
var
  checkit:tgnameitem;
  findit :pgnameitem;
begin
  checkit.addr:=loc;
  findit:=pgnameitem(find(listitem(@checkit)));
  if findit<>nil then LastPrintBuff('%s',[findit.nam]);
end;

// delname                                                               *
// - used as a simple name deleter for a given location                  *
// - also deletes the name from the disassembly listing                  *
procedure tgname.delname(loc:lptr);
var
  dname   :tgnameitem;
  checkdup:pgnameitem;
begin
  dname.addr:=loc;
  checkdup:=pgnameitem(find(listitem(@dname)));
  if checkdup<>nil then if checkdup.addr.o=loc.o then delfrom(listitem(checkdup));
  dsm.delcomment(loc,dsmnameloc);
end;

// savedb                                                                *
// - saves all the names in the list to the database file being saved.   *
//   this is in a one-pass compatible loading format. ie number of items *
//   followed by each item, and for strings the length of the string     *
//   followed by the string.                                             *
function tgname.savedb(sf:tsavefile):boolean;
var
  nexps,nlen:dword;
  currexp:pgnameitem;
begin
  result:=false;
  nexps:=numlistitems;
  resetiterator;
  writeln(log,'pos=',inttohex(numwriten,8));
  writeln(log,'names/imp/exp=',nexps);
  if not sf.swrite(@nexps,sizeof(dword)) then exit;
  while nexps<>0 do begin
    currexp:=pgnameitem(nextiterator);
    writeln(log,format(' %4.4x:%8.8x %2d %s',[currexp.addr.s,currexp.addr.o,strlen(currexp.nam)+1,currexp.nam]));
    if not sf.swrite(@currexp.addr,sizeof(lptr)) then exit;
    nlen:=strlen(currexp.nam)+1;
    if not sf.swrite(@nlen,sizeof(dword)) then exit;
    if not sf.swrite(currexp.nam,nlen) then exit;
    dec(nexps);
  end;
  result:=true;
end;

// loaddb                                                                *
// - loads the names from the database file and reconstructs the names   *
//   list                                                                *
function tgname.loaddb(sf:tsavefile):boolean;
var
  nexps,num,nlen:integer;
  currexp:pgnameitem;
begin
  result:=false;
  if not sf.sread(@nexps,sizeof(integer),num) then exit;
  while nexps<>0 do begin
    currexp:=new(pgnameitem);
    if not sf.sread(@currexp.addr,sizeof(lptr),num) then exit;
    if not sf.sread(@nlen,sizeof(dword),num) then exit;
    getmem(currexp.nam,nlen);
    if not sf.sread(currexp.nam,nlen,num) then exit;
    addto(listitem(currexp));
    dec(nexps);
  end;
  result:=true;
end;

// demangle                                                              *
// - name demangler has currently been implemented as a generic function *
//   which is null, and is overridden by the import class. this enables  *
//   any name to call name.demangle() although this is currently unused  *
procedure tgname.demangle(name_:pchar);
begin
end;

// getnamebox                                                            *
// - this is a small dialog for the input of name for a location. the    *
//   name is stored (pointer) in the global variable nme for the caller  *
//   to process                                                          *
function getnamebox(hdwnd:HWND; msg,wParam,lParam:dword):dword;stdcall;
const brush:hBRUSH=0;
var drect:trect;
begin
  result:=0;
  case msg of
   WM_COMMAND:
    case wParam of
     IDOK:
      begin
        EndDialog(hdwnd,0);
        getmem(nme,GNAME_MAXLEN+1);
        SendDlgItemMessage(hdwnd,IDC_NAMEEDIT,WM_GETTEXT,GNAME_MAXLEN,dword(@nme^));
        result:=1; exit;
      end;
     IDCANCEL:
      begin
        EndDialog(hdwnd,0);
        nme:=nil;
        result:=1; exit;
      end;
    end;
   WM_INITDIALOG:
    begin
      GetWindowRect(hdwnd,drect);
      MoveWindow(hdwnd,((mainwnd.right+mainwnd.left)-(drect.right-drect.left)) div 2,
       ((mainwnd.bottom+mainwnd.top)-(drect.bottom-drect.top)) div 2,drect.right-drect.left,drect.bottom-drect.top,TRUE);
      brush:=CreateSolidBrush(GetSysColor(COLOR_BTNFACE));
      SetFocus(GetDlgItem(hdwnd,IDC_NAMEEDIT));
      exit;
    end;
   WM_DESTROY:
    begin
      DeleteObject(brush); exit;
    end;
   WM_CTLCOLORSTATIC, WM_CTLCOLORBTN, WM_CTLCOLORDLG, WM_SYSCOLORCHANGE:
    begin
      SetBkColor(HDC(wParam),GetSysColor(COLOR_BTNFACE)); result:=brush;
    end;
  end;
end;

// nameloc                                                               *
// - this calls the user dialog for a name to be entered for the current *
//   location, and then passes this to the scheduler for naming the      *
//   location within the secondary thread. the name is deleted in the    *
//   scheduler since the generic addname creates a new string            *
procedure tnames.nameloc;
begin
  nme:=nil;
  DialogBox(Inst,MAKEINTRESOURCE(Get_Name),mainwindow,@getnamebox);
  if nme<>nil then scheduler.addtask(namecurloc,priority_userrequest,nlptr,0,nme);
end;

// namecurrloc                                                           *
// - this is a secondary thread function which gets the current location *
//   and then adds the name to the list                                  *
procedure tnames.namecurrloc(nameit:pchar);
var loc:lptr;
begin
  dio.findcurrentaddr(loc);
  addname(loc,nameit);
end;

// namesbox                                                              *
// - the dialog box for the names list. deleting and renaming sets the   *
//   repeater variable to TRUE. this should ensure that the request as a *
//   userrequest is performed and the dialog is regenerated again        *
// - the list is a simple location order of names, which is the same as  *
//   the underlying list class ordering                                  *
function namesbox(hdwnd:HWND; msg,wParam,lParam:dword):dword;stdcall;
const
  brush:hBRUSH=0;
  nseg :string='';
  noffs:string='';
  a:array[0..200] of char=#0;
  b:array[0..200] of char=#0;
  t:pgnameitem=nil;
var
  i:dword;
  drect:trect;
begin
  result:=0;
  case msg of
   WM_COMMAND:
    begin
      case wParam of
       IDC_OKBUTTON:
        begin
          EndDialog(hdwnd,0);
          result:=1; exit;
        end;
       IDC_JUMPTOBUTTON:
        begin
          scheduler.addtask(user_jumptoaddr,priority_userrequest,t.addr,0,nil);
          EndDialog(hdwnd,0);
          result:=1;
        end;
       NAMES_DELETE:
        begin
          nam.delname(t.addr);
          EndDialog(hdwnd,0);
          nam.repeater:=TRUE;
        end;
       NAMES_RENAME:
        begin
          nme:=nil;
          DialogBox(Inst,MAKEINTRESOURCE(Get_Name),hdwnd,@getnamebox);
          if nme<>nil
          then scheduler.addtask(namecurloc,priority_userrequest,t.addr,0,nme);
          EndDialog(hdwnd,0);
          nam.repeater:=TRUE;
        end;
      end;
      case HIWORD(wParam) of
       LBN_SELCHANGE:
        begin
          i:=SendDlgItemMessage(hdwnd,IDC_NAMESLISTBOX,LB_GETCURSEL,0,0);
          nam.resetiterator;
          t:=pgnameitem(nam.nextiterator);
          while i<>0 do begin
            t:=pgnameitem(nam.nextiterator); dec(i);
          end;
          fmtstr(nseg,'0x%4.4x',[t.addr.s]);
          fmtstr(noffs,'0x%8.8x',[t.addr.o]);
          strpcopy(a,nseg); strpcopy(b,noffs);
          SendDlgItemMessage(hdwnd,NAMES_TEXTSTART,WM_SETTEXT,0,dword(@b));
          SendDlgItemMessage(hdwnd,NAMES_TEXTEND,WM_SETTEXT,0,dword(@b));
       end;
     end;
   end;
  WM_INITDIALOG:
   begin
     GetWindowRect(hdwnd,drect);
     MoveWindow(hdwnd,((mainwnd.right+mainwnd.left)-(drect.right-drect.left)) div 2,
      ((mainwnd.bottom+mainwnd.top)-(drect.bottom-drect.top)) div 2,drect.right-drect.left,drect.bottom-drect.top,TRUE);
     nam.resetiterator;
     for i:=0 to nam.numlistitems-1 do begin
       t:=pgnameitem(nam.nextiterator);
       SendDlgItemMessage(hdwnd,IDC_NAMESLISTBOX,LB_ADDSTRING,0,dword(t.nam));
     end;
     SendDlgItemMessage(hdwnd,IDC_NAMESLISTBOX,LB_SETCURSEL,0,0);
     nam.resetiterator;
     t:=pgnameitem(nam.nextiterator);
     fmtstr(nseg,'0x%4.4x',[t.addr.s]);
     fmtstr(noffs,'0x%8.8x',[t.addr.o]);
     strpcopy(a,nseg); strpcopy(b,noffs);
     SendDlgItemMessage(hdwnd,NAMES_TEXTSTART,WM_SETTEXT,0,dword(@a));
     SendDlgItemMessage(hdwnd,NAMES_TEXTEND,WM_SETTEXT,0,dword(@b));
     brush:=CreateSolidBrush(GetSysColor(COLOR_BTNFACE));
     SetFocus(GetDlgItem(hdwnd,IDC_OKBUTTON));
     exit;
   end;
  WM_DESTROY:
   begin
     DeleteObject(brush);
     exit;
   end;
  WM_CTLCOLORSTATIC,
  WM_CTLCOLORBTN,
  WM_CTLCOLORDLG,
  WM_SYSCOLORCHANGE:
   begin
     SetBkColor(HDC(wParam),GetSysColor(COLOR_BTNFACE));
     result:=brush;
   end;
 end;
end;

// namesviewer                                                           *
// - this controls the display of the names viewer dialog box. names are *
//   viewed in the dialog box in location order. the function here       *
//   stops the secondary thread in order to freeze the list of names and *
//   then displays them. should a name be deleted or renamed then the    *
//   repeater variable ensures that the dialog box is redisplayed after  *
//   a window update                                                     *
procedure tnames.namesviewer;
begin
  repeater:=true;
  while repeater do begin
    if numlistitems=0 then begin
      MessageBox(mainwindow,'There are no names in the list','Borg Message',MB_OK);
      exit;
    end;
    scheduler.stopthread;
    repeater:=false;
    DialogBox(Inst,MAKEINTRESOURCE(Names_Viewer),mainwindow,@namesbox);
    scheduler.continuethread;
  end;
end;

// constructor function                                                  *
// - resets list, with small size list and no items.                     *
// - sets compare function and deletion function to NULL.                *
constructor tslist.create;
begin
  inherited create;
  getmem(listptr,4*1024);
  listiter:=0;
  listsize:=0;
  maxsize:=1024;
  cfunc:=nil;
  delfunc:=nil;
end;

// destructor function                                                   *
// - calls the deletion function for each item in the list               *
destructor tslist.destroy;
var i:integer;
begin
  for i:=0 to listsize-1 do delfunc(listptr^[i]);
  freemem(listptr);
end;

// sets the compare function                                             *
// - the compare function is used in ordering and searching the list     *
//   but it must be user defined, and so this routine should be called   *
//   as soon as possible to set up the compare function for each list    *
procedure tslist.setcomparefunc(vfunc:pvfunc);
begin
  cfunc:=vfunc;
end;

// sets the delete function                                              *
// - the delete function is called when deleting items from a list and   *
//   must be set by the user as soon as possible                         *
procedure tslist.setdelfunc(dfunc:pdfunc);
begin
  delfunc:=dfunc;
end;

// add an item to the list                                               *
// - this takes care of list size, resizing the list if more space is    *
//   needed. It inserts a new item, using the lists compare function to  *
//   order the list                                                      *
procedure tslist.addto(l:listitem);
var
  i:integer;
  nlist:plistptr;
begin
  if listsize=maxsize then begin
    // resize list
    inc(maxsize,1024);
    getmem(nlist,4*maxsize);
    for i:=0 to listsize-1 do nlist^[i]:=listptr^[i];
    freemem(listptr);
    listptr:=nlist;
  end;
  if find(l)=nil then begin
    // empty list
    listptr^[0]:=l;
    listsize:=1;
    exit;
  end else begin
    // use listiter set by find
    // ensure can add to end
    if cfunc(listptr^[listiter],l)=-1 then inc(listiter);
      // move array up
    for i:=listsize downto listiter+1 do listptr^[i]:=listptr^[i-1];
    listptr^[listiter]:=l;
    inc(listsize);
  end;
end;

// delete an item in the list                                            *
// - this just deletes one item from the list, and closes the gap        *
//   afterwards. It does not perform downsizing of the list              *
procedure tslist.delfrom(l:listitem);
var i:dword;
begin
  if listsize=0 then exit;
  if find(l)=nil then exit;
  if cfunc(listptr^[listiter],l)=0 then begin  // ensure equal
    delfunc(listptr^[listiter]);
    // move the rest down
    for i:=listiter to listsize-2 do listptr^[i]:=listptr^[i+1]; //??
    dec(listsize);
  end;
end;

// find an item in a list                                                *
// - this is used to find items, it performs a binary search using the   *
//   lists compare function. It returns a pointer to the nearest item    *
//   and sets the list iterator to that item.                            *
// The nearest item is:                                                  *
// - NULL if the list is empty                                           *
// - the first item if ptr< first item                                   *
// - the last item if ptr> last item                                     *
// - the first item such that ptr=item                                   *
// - the nth item if nth item<ptr and n+1th item> ptr                    *
function tslist.find(l:listitem):listitem;
var i,j,k:dword;
begin
  result:=nil;
  if listsize=0 then begin listiter:=0; exit end;
  // i moves from the front of the array and j from the back
  // until they are equal which is the returned item
  i:=0;
  j:=listsize-1;
  while i<>j do begin
    // k=middle item for binary search
    k:=(i+j) shr 1;
    case cfunc(listptr^[k],l) of
     -1:
       begin
         // listptr[k]->cmp < ptr->cmp
         if j-i=1 then begin // special case
           if i=k then begin
             if cfunc(listptr^[j],l)<>1 then i:=j else j:=i;
           end else i:=j;
         end else i:=k;   // move lower bound up
       end;
      0:
       begin
         // listptr[k]->cmp==ptr->cmp
         // only gets the first one of this type
         j:=k;
       end;
      1:       // listptr[k]->cmp > ptr->cmp
       begin
         if j-i=1 then begin  // special case
           if i=k then j:=k else j:=i;
         end else j:=k;   // move upper bound down
       end;
    end;
  end;
  listiter:=i;
  result:=listptr^[i];
end;

// reset list iterator to start of list                                  *
procedure tslist.resetiterator;
begin
  listiter:=0;
end;

// return next item in list using list iterator                          *
// - if listiter is beyond list then returns NULL                        *
// - otherwise returns listiter item, and then increases listiter        *
// NB after finding an item the next item returned by this function will *
//    be the same item                                                   *
function tslist.nextiterator:listitem;
begin
  if listiter>=listsize then begin
    listiter:=0;
    result:=nil;
  end else begin
    result:=listptr^[listiter];
    inc(listiter);
  end;
end;

// return previous item in list using list iterator                      *
// - if listiter is at start of list then returns NULL                   *
// - otherwise decreases listiter and then returns the listitem          *
// NB after finding an item the next item returned by this function will *
//    be the previous item                                               *
function tslist.lastiterator:listitem;
begin
  result:=nil;
  if listiter=0 then exit;
  dec(listiter);
  result:=listptr^[listiter];
end;

// process queue function                                                *
// - this was written for the scheduler mainly. It is used to process    *
// the list as a queue. It returns the first item from the list and also *
// removes it from the list                                              *
function tslist.processqueue:listitem;
var
  i:integer;
  t:listitem;
begin
  result:=nil;
  if listsize=0 then exit;
  t:=listptr^[0];
  for i:=0 to listsize-2 do listptr^[i]:=listptr^[i+1]; //???
  dec(listsize);
  result:=t;
end;

// peekfirst                                                             *
// - returns the first item from the list, without removal               *
function tslist.peekfirst:listitem;
begin
  if listsize=0 then result:=nil
  else result:=listptr^[0];
end;

// numlistitems                                                          *
// - simply returns the number of items in the list                      *
function tslist.numlistitems:integer;
begin
  result:=listsize;
end;

initialization
  nam:=tnames.create;
finalization
  nam.free;
end.

