(**************************************************************************

    :Program.    ObjFileCreator.mod
    :Contents.   procedures to create standard AmigaDOS object files
    :Remark.     does only support data hunks
    :Author.     Peter Groth
    :Address.    Grünaustraße 8, D-8390 Passau
    :Copyright.  Freeware  -  © 1991 Peter Groth
    :Language.   Modula-2
    :Translator. M2Amiga 4.0d
    :History.    v0.1  22-Jul-91  created
    :History.    v1.0  01-Nov-91  does no longer write empty hunks

**************************************************************************)

IMPLEMENTATION MODULE ObjFileCreator;
(*$ LargeVars:=FALSE  Volatile:=FALSE *)


FROM Arts IMPORT
  Assert;

FROM DosHunks IMPORT
  extAbs,extDef,hunkData,hunkEnd,hunkExt,hunkName,hunkReloc32,hunkUnit;

FROM ExecL IMPORT
  CopyMem;

FROM FileSystem IMPORT
  Close,File,Lookup,WriteByteBlock,WriteBytes,Response;

FROM Heap IMPORT
  Allocate,Deallocate;

FROM String IMPORT
  Copy,Length;

FROM SYSTEM IMPORT
  ADDRESS,ADR,BYTE;


CONST
  MaxHunk=16;         (* maximal number of hunks *)
  DataBlockLen=4096;


TYPE
  CharPtr=POINTER TO CHAR;
  HunkNum=[0..MaxHunk];
  DataPtr=POINTER TO DataBlock;
  DataBlock=RECORD
              next: DataPtr;
              len : [0..DataBlockLen];
              data: ARRAY [0..DataBlockLen] OF BYTE;
            END;
  RelocPtr=POINTER TO Reloc;
  Reloc=RECORD
          next: RelocPtr;
          hunk: HunkNum;
          pos : LONGCARD;
        END;
  ExtPtr=POINTER TO Ext;
  Ext=RECORD
        next: ExtPtr;
        name: ADDRESS;
        type: [extDef..extAbs];
        val : LONGCARD;
      END;
  Hunk=RECORD
         chip     : BOOLEAN;
         name     : ADDRESS;
         dataPtr  : DataPtr;
         dataLen  : LONGCARD;
         relocPtr : RelocPtr;
         extPtr   : ExtPtr;
       END;


VAR
  numHunks: HunkNum;                (* number of hunks in memory *)
  memHunk : ARRAY HunkNum OF Hunk;
  file    : File;


PROCEDURE StrCopy(strAdr:ADDRESS): ADDRESS;
(*:Input.    strAdr: address of the string to be copied
  :Result.   address of the copied string
  :Function. allocates memory and copies a string to it *)

VAR
  chrPtr: CharPtr;
  newStr: CharPtr;

BEGIN
  IF strAdr#NIL THEN
    chrPtr:=strAdr;
    WHILE chrPtr^#0C DO
      INC(chrPtr);
    END;
    IF chrPtr#strAdr THEN
      Allocate(newStr,LONGINT(chrPtr)-LONGINT(strAdr)+1);
      Assert(newStr#NIL,ADR("Not enough memory"));
      chrPtr:=strAdr;
      strAdr:=newStr;
      REPEAT
        newStr^:=chrPtr^;
        INC(newStr);
        INC(chrPtr);
      UNTIL chrPtr^=0C;
      RETURN(strAdr);
    ELSE
      RETURN(NIL);
    END;
  ELSE
    RETURN(NIL);
  END;
END StrCopy;


PROCEDURE CreateDataHunk(hunkName:ARRAY OF CHAR; chipMem:BOOLEAN): CARDINAL;

BEGIN
  Assert(numHunks<=MaxHunk,ADR("Too many hunks"));
  WITH memHunk[numHunks] DO
    chip:=chipMem;
    name:=StrCopy(ADR(hunkName));
    Allocate(dataPtr,SIZE(DataBlock));
    Assert(dataPtr#NIL,ADR("Can't allocate DataBlock"));
    dataLen:=0;
    relocPtr:=NIL;
    extPtr:=NIL;
  END;
  INC(numHunks);
  RETURN numHunks-1;
END CreateDataHunk;


PROCEDURE AddData(hunkNum:CARDINAL; data:ADDRESS; length: LONGCARD);

VAR
  dataBlock: DataPtr;
  avail    : LONGCARD;

BEGIN
  Assert(hunkNum<numHunks,ADR("Hunk doesn't exist"));
  dataBlock:=memHunk[hunkNum].dataPtr;
  WHILE dataBlock^.next#NIL DO
    dataBlock:=dataBlock^.next;
  END;
  INC(memHunk[hunkNum].dataLen,length);
  WHILE length>0 DO
    avail:=DataBlockLen-dataBlock^.len;
    IF avail<length THEN
      CopyMem(data,ADR(dataBlock^.data)+ADDRESS(dataBlock^.len),avail);
      dataBlock^.len:=DataBlockLen;
      DEC(length,avail);
      data:=data+ADDRESS(avail);
      Allocate(dataBlock^.next,SIZE(DataBlock));
      dataBlock:=dataBlock^.next;
      Assert(dataBlock#NIL,ADR("Can't allocate DataBlock"));
    ELSE
      CopyMem(data,ADR(dataBlock^.data)+ADDRESS(dataBlock^.len),length);
      INC(dataBlock^.len,length);
      length:=0;
    END;
  END;
END AddData;


PROCEDURE AddDataBlock(hunkNum:CARDINAL; block:ARRAY OF BYTE);
(*$ CopyDyn:=FALSE *)

BEGIN
  AddData(hunkNum,ADR(block),SIZE(block));
END AddDataBlock;


PROCEDURE HunkPos(hunkNum:CARDINAL): LONGCARD;

BEGIN
  RETURN memHunk[hunkNum].dataLen;
END HunkPos;


PROCEDURE DefReloc(hunkNum:CARDINAL; pos:LONGCARD; hunk:CARDINAL);

VAR
  newReloc,reloc: RelocPtr;

BEGIN
  Assert(pos MOD 2=0,ADR("RelocPos must be even"));
  Allocate(newReloc,SIZE(Reloc));
  Assert(newReloc#NIL,ADR("Can't allocate RelocBlock"));
  newReloc^.hunk:=hunk;
  newReloc^.pos:=pos;
  IF memHunk[hunkNum].relocPtr=NIL THEN
    newReloc^.next:=NIL;
    memHunk[hunkNum].relocPtr:=newReloc;
  ELSE
    reloc:=memHunk[hunkNum].relocPtr;
    WHILE (reloc^.next#NIL) AND (reloc^.next^.hunk<=hunk) DO
      reloc:=reloc^.next;
    END;
    newReloc^.next:=reloc^.next;
    reloc^.next:=newReloc;
  END;
END DefReloc;


PROCEDURE AddReloc(hunkNum,hunk:CARDINAL; pos:LONGCARD);

BEGIN
  IF memHunk[hunkNum].dataLen MOD 2 # 0 THEN
    AddData(hunkNum,ADDRESS(0),1);
  END;
  DefReloc(hunkNum,memHunk[hunkNum].dataLen,hunk);
  AddData(hunkNum,ADR(pos),4);
END AddReloc;


PROCEDURE DefLabel(hunkNum:CARDINAL; name:ARRAY OF CHAR; pos:LONGCARD);

VAR
  newExt,ext: ExtPtr;

BEGIN
  Allocate(newExt,SIZE(Ext));
  Assert(newExt#NIL,ADR("Can't allocate ExtBlock"));
  newExt^.name:=StrCopy(ADR(name));
  newExt^.type:=extDef;
  newExt^.val:=pos;
  newExt^.next:=NIL;
  IF memHunk[hunkNum].extPtr=NIL THEN
    memHunk[hunkNum].extPtr:=newExt;
  ELSE
    ext:=memHunk[hunkNum].extPtr;
    WHILE ext^.next#NIL DO
      ext:=ext^.next;
    END;
    ext^.next:=newExt;
  END;
END DefLabel;


PROCEDURE AddLabel(hunkNum:CARDINAL; name:ARRAY OF CHAR);
(*$ CopyDyn:=FALSE *)

BEGIN
  DefLabel(hunkNum,name,memHunk[hunkNum].dataLen);
END AddLabel;


PROCEDURE EquLabel(hunkNum:CARDINAL; name:ARRAY OF CHAR; val: LONGCARD);

VAR
  newExt,ext: ExtPtr;

BEGIN
  Allocate(newExt,SIZE(Ext));
  Assert(newExt#NIL,ADR("Can't allocate ExtBlock"));
  newExt^.name:=StrCopy(ADR(name));
  newExt^.type:=extAbs;
  newExt^.val:=val;
  newExt^.next:=NIL;
  IF memHunk[hunkNum].extPtr=NIL THEN
    memHunk[hunkNum].extPtr:=newExt;
  ELSE
    ext:=memHunk[hunkNum].extPtr;
    WHILE ext^.next#NIL DO
      ext:=ext^.next;
    END;
    ext^.next:=newExt;
  END;
END EquLabel;


PROCEDURE WriteObjFile(fileName:ARRAY OF CHAR; unitName:ARRAY OF CHAR);

VAR
  act            : LONGINT;
  memNib         : [0..15];
  hunkNum,relHunk: HunkNum;
  dataBlock      : DataPtr;
  reloc,rel      : RelocPtr;
  ext            : ExtPtr;
  numRelocs,i    : LONGCARD;

  PROCEDURE StrLen(strPtr:ADDRESS): LONGCARD;
  (*:Input.    strPtr: pointer to any string
    :Result.   length of the string (number of LONGCARDs used)
    :Function. returns the length of the string in LONGCARDs *)
  VAR
    chrPtr: CharPtr;
  BEGIN
    IF strPtr#NIL THEN
      chrPtr:=strPtr;
      WHILE chrPtr^#0C DO
        INC(chrPtr);
      END;
      RETURN((LONGCARD(chrPtr)-LONGCARD(strPtr)+3) DIV 4);
    ELSE
      RETURN(0);
    END;
  END StrLen;

  PROCEDURE WriteLong(val:LONGCARD);
  (*:Input.    val: value to be written
    :Function. writes a LONGCARD value to the file *)
  BEGIN
    WriteByteBlock(file,val);
  END WriteLong;

BEGIN
  Lookup(file,fileName,1024,TRUE);
  Assert(file.res=done,ADR("Can't create object file"));
  IF Length(unitName)>0 THEN
    WriteLong(hunkUnit);
    WriteLong(StrLen(ADR(unitName)));
    WriteBytes(file,ADR(unitName),StrLen(ADR(unitName))*4,act);
  END;
  FOR hunkNum:=0 TO numHunks-1 DO
    WITH memHunk[hunkNum] DO
      IF name#NIL THEN
        WriteLong(hunkName);
        WriteLong(StrLen(name));
        WriteBytes(file,name,StrLen(name)*4,act);
      END;
      IF chip THEN
        memNib:=4;
      ELSE
        memNib:=0;
      END;
      WriteLong(hunkData+10000000H*memNib);
      WriteLong((dataLen+3) DIV 4);
      dataBlock:=dataPtr;
      REPEAT
        WriteBytes(file,ADR(dataBlock^.data),dataBlock^.len,act);
        dataBlock:=dataBlock^.next;
      UNTIL dataBlock=NIL;
      IF dataLen MOD 4 # 0 THEN
        WriteBytes(file,ADDRESS(0),4-(dataLen MOD 4),act);
      END;
      IF relocPtr#NIL THEN
        WriteLong(hunkReloc32);
        reloc:=relocPtr;
        FOR relHunk:=0 TO numHunks-1 DO
          numRelocs:=0;
          rel:=reloc;
          WHILE (rel#NIL) AND (rel^.hunk=relHunk) DO
            INC(numRelocs);
            rel:=rel^.next;
          END;
          IF numRelocs>0 THEN
            WriteLong(numRelocs);
            WriteLong(relHunk);
            FOR i:=1 TO numRelocs DO
              WriteLong(reloc^.pos);
              reloc:=reloc^.next;
            END;
          END;
        END;
        WriteLong(0);
      END;
      IF extPtr#NIL THEN
        WriteLong(hunkExt);
        ext:=extPtr;
        WHILE ext#NIL DO
          WriteLong(StrLen(ext^.name)+1000000H*ext^.type);
          WriteBytes(file,ext^.name,StrLen(ext^.name)*4,act);
          WriteLong(ext^.val);
          ext:=ext^.next
        END;
        WriteLong(0);
      END;
    END;
    WriteLong(hunkEnd);
  END;
  Close(file);
END WriteObjFile;


BEGIN
  numHunks:=0;
CLOSE
  Close(file);
END ObjFileCreator.