/omf.pas
unit OMF;
interface

type
OmfFile = record
    f: file;
end;
OmfRecordHeader = record
    rectype: Byte;
    length: Word;
end;
OmfRecord = record
    head: OmfRecordHeader;
    data: array [0..1023] of Byte;
    data_len: Integer;
end;
SegmentAlignment = (AlignAbsolute, AlignByte, AlignWord, AlignParagraph,
                    AlignPage, AlignDoubleWord);
SegmentCombination = (CombinePrivate, __reserved1, CombinePublic);

const THEADR: Byte = $80;
const COMENT: Byte = $88;
const MODEND: Byte = $8A;
const LNAMES: Byte = $96;
const SEGDEF: Byte = $98;
const GRPDEF: Byte = $9A;
const PUBDEF: Byte = $90;
const LINNUM: Byte = $94;
const LEDATA: Byte = $A0;

procedure OpenOmf(const name: string; var omf: OmfFile);
procedure CloseOmf(var omf: OmfFile);

procedure NewRecord(var rec: OmfRecord; const rectype: Byte);

procedure RecAddByte(var rec: OmfRecord; const b: Byte);
procedure RecAddWord(var rec: OmfRecord; const w: Word);
procedure RecAddIndex(var rec: OmfRecord; const i: Word);
procedure RecAddData(var rec: OmfRecord; const data: array of Byte; const len: Word);

procedure RecAddName(var rec: OmfRecord; const name: string);
procedure RecAddCommentStr(var rec: OmfRecord; const ctype: Byte;
                           const cclass: Byte; const comment: string);
procedure RecAddRelocatableSegment(var rec: OmfRecord; const alignment: SegmentAlignment;
                                   const combination: SegmentCombination;
                                   const len: Word; const name: Word; const class: Word;
                                   const overlay: Word);
procedure RecAddGroupDef(var rec: OmfRecord; const groupname: Word; const segment: Word);
procedure RecAddPubDef(var rec: OmfRecord; const group: Word; const segment: Word);
procedure RecAddPubDefName(var rec: OmfRecord; const name: string; const offset: Word;
                           const typeidx: Byte);
procedure RecAddEnumeratedData(var rec: OmfRecord; const segment: Word;
                               const offset: Word; const data: array of Byte;
                               const len: Word);
procedure WriteRecord(var omf: OmfFile; var rec: OmfRecord);

implementation

procedure NewRecord(var rec: OmfRecord; const rectype: byte);
begin
    rec.head.rectype := rectype;
    rec.head.length := 0;
    rec.data_len := 0;
end;

procedure RecAddByte(var rec: OmfRecord; const b: Byte);
begin
    if rec.head.length + 1 >= 1024 then begin
        Writeln('adding byte exceeds record size');
        Halt(1);
    end;

    rec.data[rec.head.length] := b;
    Inc(rec.head.length);
end;

procedure RecAddWord(var rec: OmfRecord; const w: Word);
begin
    if rec.head.length + 2 >= 1024 then begin
        Writeln('adding word exceeds record size');
        Halt(1);
    end;

    rec.data[rec.head.length] := Lo(w);
    Inc(rec.head.length);
    rec.data[rec.head.length] := Hi(w);
    Inc(rec.head.length);
end;

procedure RecAddIndex(var rec: OmfRecord; const i: Word);
begin
    if i > $7FFF then begin
        Writeln('cannot encode index: ', i);
        Halt(1);
    end;

    if i > $7F then begin
        if rec.head.length + 2 >= 1024 then begin
            Writeln('Not enough space in record to encode index: ', i);
            Halt(1);
        end;
        rec.data[rec.head.length] := $80 OR Byte(i shr 8);
        Inc(rec.head.length);
        rec.data[rec.head.length] := Byte(i);
        Inc(rec.head.length);
    end
    else
    begin
        if rec.head.length + 1 >= 1024 then begin
            Writeln('Not enough space in record to encode index: ', i);
            Halt(1);
        end;
        rec.data[rec.head.length] := i;
        Inc(rec.head.length);
    end;
end;

procedure RecAddData(var rec: OmfRecord; const data: array of Byte; const len: Word);
var i: Integer;
begin
    if len + rec.head.length > 1024 then begin
        Writeln('adding data exceeds record size');
        Halt(1);
    end;
    for i := 0 to len - 1 do begin
        rec.data[rec.head.length] := data[i];
        Inc(rec.head.length);
    end;
end;

procedure RecAddName(var rec: Omfrecord; const name: string);
var name_len: Integer;
    i: Integer;
begin
    name_len := Length(name);
    if name_len > 255 then begin
        Writeln('Name must be less than 255 characters');
        Halt(1);
    end;
    if rec.head.length + name_len >= 1024 then begin
        Writeln('adding name exceeds record size');
        Halt(1);
    end;
    { We already have a Pascal string, so just write it }
    for i := 0 to name_len do begin
        rec.data[rec.head.length] := Byte(name[i]);
        Inc(rec.head.length);
    end;
end;

procedure RecAddCommentStr(var rec: OmfRecord; const ctype: Byte;
                           const cclass: Byte; const comment: string);
var comment_len: Integer;
    i: Integer;
begin
    comment_len := Length(comment);
    if rec.head.length + 2 + comment_len + 1 >= 1024 then begin
        Writeln('Not enough space in record to add comment');
        Halt(1);
    end;

    rec.data[rec.head.length] := ctype;
    Inc(rec.head.length);
    rec.data[rec.head.length] := cclass;
    Inc(rec.head.length);
    for i := 1 to comment_len do begin
        rec.data[rec.head.length] := Byte(comment[i]);
        Inc(rec.head.length);
    end;
end;

procedure RecAddRelocatableSegment(var rec: OmfRecord; const alignment: SegmentAlignment;
                                   const combination: SegmentCombination;
                                   const len: Word; const name: Word; const class: Word;
                                   const overlay: Word);
var attributes: Byte;
begin
    attributes := (Byte(alignment) SHL 5) OR (Byte(combination) SHL 2);
    rec.data[rec.head.length] := attributes;
    Inc(rec.head.length);

    RecAddWord(rec, len);
    RecAddIndex(rec, name);
    RecAddIndex(rec, class);
    RecAddIndex(rec, overlay);
end;

procedure RecAddGroupDef(var rec: OmfRecord; const groupname: Word; const segment: Word);
begin
    RecAddIndex(rec, groupname);
    RecAddByte(rec, $FF);
    RecAddIndex(rec, segment);
end;

procedure RecAddPubDef(var rec: OmfRecord; const group: Word; const segment: Word);
begin
    RecAddIndex(rec, group);
    RecAddIndex(rec, segment);
end;

procedure RecAddPubDefName(var rec: OmfRecord; const name: string; const offset: Word;
                           const typeidx: Byte);
begin
    RecAddName(rec, name);
    RecAddWord(rec, offset);
    RecAddByte(rec, typeidx);
end;

procedure RecAddEnumeratedData(var rec: OmfRecord; const segment: Word;
                               const offset: Word; const data: array of Byte;
                               const len: Word);
begin
    RecAddIndex(rec, segment);
    RecAddWord(rec, offset);
    RecAddData(rec, data, len);
end;

procedure WriteRecord(var omf: OmfFile; var rec: OmfRecord);
var checksum: Byte;
    ptr: ^Byte;
    i: Integer;
begin
    { Look, the checksum is unnecessary, but I went through all this trouble
      because I thought LINK.EXE needed it, so it's staying. }
    checksum := rec.head.rectype + Hi(rec.head.length) + Lo(rec.head.length);
    for i := 0 to rec.head.length - 1 do
        checksum := Byte(Word(checksum) + rec.data[i]);
    checksum := 255 - checksum;
    { Length includes the checksum byte }
    rec.data[rec.head.length] := checksum;
    Inc(rec.head.length);

    { for some reason BlockWrite cannot access record fields directly in TP }
    ptr := @rec.head.rectype;
    BlockWrite(omf.f, ptr^, 1);
    ptr := @rec.head.length;
    BlockWrite(omf.f, ptr^, 2);
    ptr := @rec.data;
    BlockWrite(omf.f, ptr^, rec.head.length);
end;

procedure OpenOmf(const name: String; var omf: OmfFile);
begin
    Assign(omf.f, name);
    Rewrite(omf.f, 1);
end;

procedure CloseOmf(var omf: OmfFile);
begin
    Close(omf.f);
end;

end.