(*---------------------------------------------------------------------------
    :Program.    Disobject.mod
    :Author.     Bernd Preusing
    :Address.    Gerhardstr. 16  D-2200 Elmshorn
    :Phone.      04121/22486
    :Shortcut.   [bep]
    :Version.    1.1
    :Date.       Oct-88
    :Copyright.  PD
    :Language.   Modula-II
    :Translator. M2Amiga
    :Imports.    Disass, SymTab
    :UpDate.     
    :Contents.   disassemble an M2Amiga Object file
    :Remark.     
---------------------------------------------------------------------------*)
MODULE DisObject;

FROM SYSTEM IMPORT CAST,ADDRESS,ADR,INLINE,BITSET, LONGSET, SHIFT;

FROM Arts IMPORT
  ModType, ModuleId, ModuleInfo, ModuleInfoPtr, Terminate, CurrentLevel;

FROM InOut IMPORT
 WriteString, WriteLn, WriteHex, Write, WriteInt,
 ReadString, ReadLongCard;

FROM Conversions IMPORT
 StrToVal, ValToStr;

IMPORT Strings;

FROM FileSystem IMPORT File, Response, Lookup, Close, Length, ReadBytes;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM Arguments IMPORT NumArgs, GetArg;
FROM DisAss IMPORT Line, Disass;
FROM SymTab IMPORT
  SymName, AdRec, AdRecPtr, SearchAd, InsertAd, FirstAd, NextAd, GenSyms;

TYPE
  CARDPOINTER = POINTER TO CARDINAL;
  LPtr = POINTER TO LONGINT;
  SymPtr = POINTER TO SymName;
  ModuleIdPtr = POINTER TO ARRAY[1..100] OF ModuleId;
  Module = RECORD
    id1: LONGINT;
    mid: ModuleId;
    codeSize,
    varSize,
    constSize,
    jumps,
    modules: LONGINT;
  END;
  (* dann consts, jumps, moduleIds, Prog *)
  (* fertig= consts, jumps, dataPtr, modulePtrs, Prog *)
  ModulePtr = POINTER TO Module;

CONST nullName='';
	TAB = 11C;

VAR
 ObjAnzeigen,alert: BOOLEAN;
 procName: SymName;
 Buff: Line;
 FBuffPtr:ADDRESS; BuffLen:LONGINT;
 adRec, actRec: AdRecPtr;
 mp:ModulePtr;
 Adr,OldAdr,nexta: ADDRESS; lPtr:LPtr;
 i,j,Pos:CARDINAL;
 cmd,fname:ARRAY[0..63] OF CHAR;

PROCEDURE WrS(s:ARRAY OF CHAR);
BEGIN
 WriteString(s); WriteLn
END WrS;

PROCEDURE WrTab(s:ARRAY OF CHAR);
BEGIN
 Write(TAB);
 WriteString(s)
END WrTab;

PROCEDURE WrTabL(s:ARRAY OF CHAR);
BEGIN
 Write(TAB);
 WriteString(s);
 WriteLn
END WrTabL;

PROCEDURE WrL(l:LONGINT);
BEGIN
 WrTab('DC.L'); Write(TAB); WriteInt(l,1); WriteLn
END WrL;

PROCEDURE WrI(l:LONGINT);
BEGIN
 WrTab('DC.W'); Write(TAB); WriteInt(l,1); WriteLn
END WrI;

PROCEDURE JName(nr:INTEGER);
BEGIN
  procName:='Proc000';
  INC(procName[6],nr MOD 10);
  INC(procName[5],(nr DIV 10) MOD 10);
  INC(procName[4],(nr DIV 100) MOD 10);
END JName;

PROCEDURE GetFile(s:ARRAY OF CHAR):BOOLEAN;
VAR f:File; actual:LONGINT;
BEGIN
 Lookup(f,s,0,FALSE);
 IF f.res#done THEN RETURN FALSE END;
 Length(f,BuffLen);
 ALLOCATE(FBuffPtr,BuffLen); (* bricht ab *)
 ReadBytes(f,FBuffPtr,BuffLen,actual);
 IF actual<BuffLen THEN Close(f); RETURN FALSE END;
 Close(f);
 RETURN TRUE
END GetFile;

PROCEDURE OpenFile();
VAR dummy:INTEGER; opt: ARRAY[0..10] OF CHAR;
BEGIN
 IF NumArgs()>0 THEN
   GetArg(1,fname,dummy);
   IF NOT GetFile(fname) THEN
     WriteString('Fehler: obj-File nicht zu laden.');
     WriteLn;
     Terminate(CurrentLevel())
   END;
 ELSE
   REPEAT
     WriteString('obj-File?');
     ReadString(fname);
     WriteLn
   UNTIL GetFile(fname);
 END;
 IF NumArgs()>1 THEN
   GetArg(2,opt,dummy);
   IF opt[0]='-' THEN
     ObjAnzeigen:= (CAP(opt[1])='O');
   END;
 END;
END OpenFile;

PROCEDURE ShowObj():BOOLEAN;
 VAR a,e:ADDRESS; i,offset:LONGINT; NewName: SymName;

 PROCEDURE Sym(ad:LONGINT);
 BEGIN
   IF SearchAd(ad)=NIL THEN
    InsertAd(nullName,ad);
   END;
 END Sym;

 PROCEDURE NamSym(s:SymName;ad:LONGINT);
 VAR a: AdRecPtr;
 BEGIN
    a:= SearchAd(ad);
    IF a=NIL THEN
      InsertAd(s,ad);
    ELSE
      a^.str:=s
    END;
 END NamSym;

 PROCEDURE ModSym(s:ARRAY OF CHAR;ad:LONGINT);
 VAR i:CARDINAL;
 BEGIN
   i:=0;
   WHILE (s[i]#0C) AND (i<5) DO
    NewName[i]:=s[i];
    IF NewName[i]='.' THEN NewName[i]:='_' END;
    INC(i)
   END;
   NewName[i]:='B'; INC(i); NewName[i]:='s'; INC(i);
   WHILE i<7 DO NewName[i]:='_'; INC(i) END; NewName[7]:=0C;
   NamSym(NewName,ad);
 END ModSym;

 PROCEDURE Mids(m:ADDRESS;cnt:INTEGER; write:BOOLEAN);
 VAR mid:ModuleIdPtr; j:INTEGER;
 BEGIN
   mid:=CAST(ModuleIdPtr,m);
   FOR j:=1 TO cnt DO 
    WITH mid^[j] DO
     IF write THEN
       WrTab('DC.W '); WriteInt(type,1);
       WrTab('; ');
       CASE type OF
         0: WrS('none');    |
         1: WrS('mod');     |
         2: WrS('library'); |
         3: WrS('noImp');   |
       ELSE
         WrS(' unbekannt!!')
       END;
       IF name[0]#0C THEN
         WrTab("DC.B '"); WriteString(name); WrS("'");
       END;
       WrTab('DS.B '); WriteInt(32-Strings.Length(name),1);
       WrS(',0');
       IF type=2 THEN
         WrI(keys[0]); WrL(keys[2])
       ELSE
         WrTab('DC.W $'); WriteHex(keys[0],4);
         WriteString(',$'); WriteHex(keys[1],4);
         WriteString(',$'); WriteHex(keys[2],4); WriteLn
       END;
     END; (* if write *)
     IF (cnt>1) AND (type>0) THEN
        ModSym(name,mp^.constSize+mp^.jumps*6+j*4);
	IF write THEN
          WriteString(NewName); WriteString(' EQUR Prog-');
	  WriteInt((cnt-j+1)*4,1); WriteLn;
        END;
     END;
    END;
    IF write THEN WriteLn END;
   END
 END Mids;

 PROCEDURE Replace(VAR d,s:ARRAY OF CHAR);
 VAR i,j:INTEGER;
 BEGIN
  i:=7;
  WHILE (d[i]#'L') AND (i<HIGH(d)) DO INC(i) END;
  IF d[i]='L' THEN
   FOR j:=0 TO 6 DO d[j+i]:=s[j] END
  END;
 END Replace;

 PROCEDURE DumpA(VAR a:ADDRESS; b:ADDRESS);
 TYPE sPtr=POINTER TO ARRAY[0..200] OF CHAR;
 VAR s:sPtr; i:LONGINT; olda,mom:ADDRESS; tempName:SymName;
 BEGIN
 adRec:=FirstAd();
 nexta:=adRec^.ad; mom:=0;
 IF a=b THEN RETURN END;
 olda:=a;
 REPEAT
  IF mom>=nexta THEN
    IF mom=nexta THEN
       tempName:=adRec^.str;
       tempName[0]:='K';
       WriteString(tempName); WrS(':');
       WriteString(adRec^.str); WrTab('EQUR');
       WrTab(tempName); Write('+');
       WriteInt(mp^.modules*SIZE(ModuleId)-(mp^.modules+1)*4,1); WriteLn
    END;
    adRec:=NextAd(); nexta:=adRec^.ad;
  END;
  s:=CAST(sPtr,a);
  IF s^[0]#0C THEN
    WriteString(' DC.B "'); WriteString(s^); WriteString('",0');
    i:=Strings.Length(s^)+1;
    IF ODD(i) THEN WriteString(',0'); INC(i) END;
  ELSE
    WriteString(' DC.B 0,0  ; LeerString');
    i:=2
  END;
  WriteLn;
  INC(a,i); INC(mom,i);
 UNTIL a>=b
 END DumpA;

 PROCEDURE DumpJ(VAR a:ADDRESS; b:ADDRESS);
 VAR i:LONGINT; olda,mom:ADDRESS; tempName:SymName;
 BEGIN
 nexta:=adRec^.ad; mom:=mp^.constSize; i:=1;
 IF a=b THEN RETURN END;
 olda:=a;
 REPEAT
  IF mom>=nexta THEN
    IF mom=nexta THEN
       tempName:=adRec^.str;
       tempName[0]:='K';
       WriteString(tempName); WrS(':');
       WriteString(adRec^.str); WrTab('EQUR');
       WrTab(tempName); Write('+');
       WriteInt(mp^.modules*SIZE(ModuleId)-(mp^.modules+1)*4,1); WriteLn
    END;
    adRec:=NextAd(); nexta:=adRec^.ad;
  END;
  lPtr:=CAST(LPtr,a+2);
  JName(mp^.jumps-i);
  INC(i);
  a:=Disass(ADR(Buff),a,offset);
  IF ObjAnzeigen THEN
    WrS(Buff.s)
  ELSE
    WrTab('DC.W'); Write(TAB); Write('$'); WriteHex(4EF9H,4);
    WriteString(',0,'); WriteString(procName); Write('-');
    WriteInt(SIZE(Module)+mp^.modules*SIZE(ModuleId)-(mp^.modules+1)*4,1);
    WriteLn;
   END;
   INC(mom,6);
  UNTIL a>=b
 END DumpJ;

BEGIN (* ShowObj *)
  mp:=CAST(ModulePtr,FBuffPtr);
  IF mp^.id1#1 THEN RETURN FALSE END;
  WrS('; M2Amiga Object-File Disassembler V 2.0  © Bernd Preusing 1988');
  WriteString('; Disassembly of '); WrS(fname);
  WriteLn;
  WrTabL('CODE');
  WrTabL('DC.L 1  ; Kennung: .obj-File');
  Mids(ADR(mp^.mid),1,TRUE);
  a:=FBuffPtr+SIZE(Module)+mp^.constSize;
  FOR i:=1 TO mp^.jumps DO
    lPtr:=CAST(LPtr,a+2);
    JName(mp^.jumps-i);
    NamSym(procName,lPtr^);
    INC(a,6);
  END;

  WrS('; CodeSize');
  WrTab('DC.L'); WrTabL('ENDE-Prog');
  WrS('; VarSize');
  WrL(mp^.varSize);
  WrS('; ConstSize');
  WrTab('DC.L'); WrTabL('Jumps-Consts');
  WrS('; Jumps');
  WrL(mp^.jumps);
  WrS('; Modules');
  WrL(mp^.modules);
  WriteLn;

  NamSym('dataPtr',mp^.constSize+mp^.jumps*6);
  a:=FBuffPtr+SIZE(Module)+mp^.constSize+mp^.jumps*6;
  Mids(a,mp^.modules,FALSE); (* nur symbole generieren *)
(* Pass 1 == *)
  a:=FBuffPtr+SIZE(Module)+mp^.modules*SIZE(ModuleId)+mp^.constSize+
     mp^.jumps*6;
  e:=FBuffPtr+BuffLen;
  offset:=mp^.constSize+mp^.jumps*6+(mp^.modules+1)*4-a;
  WHILE a<e DO
    a:=Disass(ADR(Buff),a,offset);
    IF (0 IN Buff.flags) OR (1 IN Buff.flags) THEN
       Sym(Buff.adr+offset)
    END;
    IF 2 IN Buff.flags THEN alert:=TRUE END;
  END;
(* == *)
IF alert THEN
  WriteLn;
  WrS('!!!!! Achtung: DC.W im Code, vermutlich INLINE o.ä. !!!!');
  WriteLn;
END;
(* Pass 2 == *)
  GenSyms();
  WrS('Consts:');
  a:=FBuffPtr+SIZE(Module);
  DumpA(a,a+mp^.constSize);
  WriteLn;

  WrS('Jumps:');
  offset:=mp^.constSize-a;
  DumpJ(a,a+mp^.jumps*6);
  WriteLn;

  WrS('ModuleIds:');
  Mids(a,mp^.modules,TRUE);
  WriteLn;

  WriteString('dataPtr EQUR Prog-'); WriteInt((mp^.modules+1)*4,1);
  WriteLn; WriteLn;
  WrS('Prog:');
  a:=FBuffPtr+SIZE(Module)+mp^.modules*SIZE(ModuleId)+mp^.constSize+
     mp^.jumps*6;
  e:=FBuffPtr+BuffLen;
  offset:=mp^.constSize+mp^.jumps*6+(mp^.modules+1)*4-a;
  WHILE nexta<a DO adRec:=NextAd();
    IF adRec#NIL THEN nexta:=adRec^.ad-offset ELSE nexta:=7FFFFFFFH END;  
  END;

  WHILE a<e DO
    IF a>=nexta THEN
       IF a=nexta THEN WriteString(adRec^.str); WrS(':'); END;
       adRec:=NextAd();
       IF adRec#NIL THEN nexta:=adRec^.ad-offset ELSE nexta:=7FFFFFFFH END;
    END;
    a:=Disass(ADR(Buff),a,offset);
    IF (0 IN Buff.flags) OR (1 IN Buff.flags) THEN
       actRec:=SearchAd(Buff.adr+offset);
       IF actRec#NIL THEN
         Replace(Buff.s2,actRec^.str)
       END;
    END;
    IF ObjAnzeigen THEN
      WrS(Buff.s)
    ELSE
      WrTabL(Buff.s2);
    END;
  END;
(* == *)
  WrS('ENDE:');
  WrTabL('END');
  RETURN TRUE
END ShowObj;


BEGIN
 ObjAnzeigen:=FALSE; alert:=FALSE;
 REPEAT
  OpenFile();
 UNTIL ShowObj()=TRUE;
END DisObject.mod