program DMPCOM(input,output);
(*
  Wandeln von Dump-Dateien im ASCII-Format in eine .COM-Datei

  Format der Dump-Datei, z.B.:

Standard CP/M 3:
0140: 7D E6 40 CD A2 01 7D E6 80 CD A2 01 7D E6 10 CD  }.@...}.....}...
Anderes Format:
0140| 7D E6 40 CD A2 01 7D E6 80 CD A2 01 7D E6 10 CD |}.@...}.....}...
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
AAAAD1BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBDTTTTTTTTTTTTTTTT

Mit:
 A  ( 4): Aktuelle Speicheradresse
          (Die erste Adresse muss immer 0100 sein)
 D1 ( 2): Erster Teiler (mit Leerzeichen)
 B  (48): ASCII Bytefolge (2 Hex-Zeichen, 1 Leerzeichen)
 D  ( 1): Zweiter Teiler
 T  (16): Textdarstellung der Bytes
    (71)

Jede Datei enthaelt ein Ein-/Vielfaches von 8 Zeilen (jeweils 1 Record
von 128 Bytes).

Die Laenge einer Zeile ist immer 71.

  Werner Cirsovius, Dezember 2015
*)

const
  TPA          = $0100;
  DEFLEN       = 71;                             (* Laenge einer Zeile *)
  DELPOS       = 55;                             (* Position des zweiten Teilers *)
  EOFCHR       = $1A;
  HEXLEN       = 4;
  RECLEN       = 128;
  DIVIDER1     = '|';                            (* Standard CP/M ':' *)
  DIVIDER2     = '|';                            (* Standard CP/M ' ' *)
type
  HexString    = string[HEXLEN];
  FSTR         = string[ 20];
  LSTR         = string[255];
  WARNpointer  = ^WARNrecord;
  WARNrecord   = record
                   WARNlen  : integer;
                   WARNline : HexString;
                   WARNlink : WARNpointer;
                 end;
var
  FINAME       : FSTR;
  Fi           : text;
  Fo           : file;
  Optr         : byte;
  Obuff        : array[1..RECLEN] of byte;
  LINE         : LSTR;
  WARN,
  EndAdr,
  EntAdr,
  StrAdr       : integer;
  EndCode      : boolean;
  Root,
  WARNING      : WARNpointer;

procedure WARNMSG(MSG:LSTR;MODE:boolean);
(*
  Ausgabe einer Fehlermeldung
*)
Begin
  writeln(MSG);
  if MODE then
  begin
    writeln;
    writeln('In: >',LINE,'<');
    writeln;
  end;
End;

procedure ABORT(MSG:LSTR;MODE:boolean);
(*
  Ausgabe einer Fehlermeldung und Abbruch
*)
Begin
  WARNMSG(MSG,MODE);
  halt;
End;

procedure GetFileName;
(*
  Eingabe des Namens der Quelldatei
*)
var
  i            : integer;
Begin
  repeat
    write('Name der DUMP-Datei: ');
    readln(FINAME);
  until (length(FINAME)>0);
  for i:=1 to length(FINAME) do FINAME[i]:=upcase(FINAME[i]);
  if pos('.',FINAME)=0 then FINAME:=FINAME+'.DMP';
End;

procedure OpenSource;
(*
  Oeffnen der Quell-Datei
*)
var
  p            : integer;
Begin
  assign(Fi,FINAME);
  {$I-}reset(Fi);{$I+}
  if (IOResult<>0) then ABORT('Kann Datei '+FINAME+' nicht oeffnen',FALSE);
End;

procedure OpenDestination;
(*
  Oeffnen der Ziel-Datei
*)
var
  p            : integer;
Begin
  p:=pos('.',FINAME);
  FINAME:=copy(FINAME,1,p-1)+'.COM';
  assign(Fo,FINAME);
  {$I-}rewrite(Fo);{$I+}
  if (IOResult<>0) then ABORT('Kann Datei '+FINAME+' nicht anlegen',FALSE);
  Optr:=0;
  EndCode:=FALSE;
  StrAdr:=TPA;
  EntAdr:=TPA;
  EndAdr:=TPA;
End;

function GetHex(L:LSTR; dig:integer):integer;
(*
  Wandeln einer Zeichenkette in Hex-Wert
*)
var
  i,x,ch        : integer;
Begin
  x:=0;
  for i:=1 to dig do
  begin
    if (L[i] in ['0'..'9','A'..'F']) then
    begin
      ch:=ord(L[i])-ord('0');
      if (ch>9) then ch:=ch-(ord('A')-ord('0')-10);
      x:=x*16+ch;
    end else ABORT('Ungueltiges Hex-Zeichen: '+L[i],FALSE);
  end;
  GetHex:=x;
End;

procedure DisplayWarnings;
(*
  Ausgabe der Fehlerzeilen
*)
var
  i            : integer;
  p            : WARNpointer;
Begin
  writeln('Zeile - Laenge');
  writeln('====    ==    ');
  p:=Root;
  for i:=1 to WARN do
  begin
    writeln(p^.WARNline,'    ',p^.WARNlen);
    p:=p^.WARNlink;
  end;
End;

procedure PutWARNING;
(*
  Eingabe einer Fehlerzeile
*)
var
  p            : WARNpointer;
Begin
  WARN:=WARN+1;
  new(p);
  if Root=NIL then Root:=p
              else WARNING^.WARNlink:=p;
  WARNING:=p;
  WARNING^.WARNlink:=p;
  p^.WARNlink:=NIL;
  p^.WARNlen:=length(LINE);
  p^.WARNline:=copy(LINE,1,HEXLEN);
End;

procedure LineRead;
(*
  Zeile einlesen und grob testen
*)
Begin
  readln(Fi,LINE);
  EndCode:=EOF(Fi);
  if not EndCode then
  begin
    if length(LINE)<>DEFLEN then
    begin
      PutWARNING;
      if ((length(LINE)<DELPOS) OR
          (LINE[DELPOS]<>DIVIDER2)) then begin
                                           WARNMSG('Ungueltige Zeilenlaenge',TRUE);
                                           if (LINE[DELPOS]<>DIVIDER2) then
                                           begin
                                             DisplayWarnings;
                                             halt;
                                           end;
                                         end;
    end;
  end;
End;

procedure FPUT(b:byte);
(*
  Byte in COM-Datei schreiben
*)
Begin
  EndAdr:=EndAdr+1;
  Optr:=Optr+1;
  Obuff[Optr]:=b;
  if (Optr=RECLEN) then
  begin
    blockwrite(Fo,Obuff,1);
    for Optr:=1 to RECLEN do Obuff[Optr]:=EOFCHR;
    Optr:=0;
  end;
End;

procedure CloseFiles;
(*
  Dateien schliessen
*)
Begin
  if (Optr<>0) then blockwrite(Fo,Obuff,1);
  close(Fo);
  close(Fi);
End;

function Hex(Number: integer):HexString;
(*
  Ganze Zahl nach Hex wandeln
*)
const
  HexDigit:array[0..15]of char='0123456789ABCDEF';
var
  N            : integer;
  IntStr       : HexString;
Begin
  IntStr:='0000';
  for N:=HEXLEN downto 1 do
  begin
    IntStr[N]:=HexDigit[Number and $0F];
    Number:=Number shr 4;
  end;
  Hex:=IntStr;
End;

procedure ProcLine;
(*
  ASCII-Zeile bearbeiten
*)
var
  i,
  LinAdr       : integer;
  AscHex       : LSTR;
  BytHex       : byte;
Begin
  LineRead;
  LinAdr:=GetHex(LINE,HEXLEN);
  if (LinAdr<>EntAdr) then ABORT('Ungueltige Start-Adresse: '+Hex(LinAdr)+'H - erwartet: '+Hex(EntAdr)+'H',TRUE);
  EntAdr:=EntAdr+16;
  if ((LINE[5]<>DIVIDER1) AND
      (LINE[6]<>' '))        then ABORT('Startteiler "'+DIVIDER1+' " fehlt in der Zeile',TRUE);
  i:=1;
  repeat
    AscHex:=copy(LINE,3*i+4,3);
    if AscHex[3]<>' ' then ABORT('Leerzeichen an letzter Stelle erwartet in: '+AscHex,TRUE);
    BytHex:=GetHex(AscHex,2);
    FPUT(BytHex);
    i:=i+1;
  until (i=17);
End;

BEGIN (* M A I N *)
  WARN:=0;
  Root:=NIL;
  GetFileName;
  OpenSource;
  OpenDestination;
  repeat
    ProcLine
  until EndCode;
  CloseFiles;
  writeln('Datei ',FINAME,' beschrieben von ',HEX(StrAdr),'H-',HEX(EndAdr-1),'H');
  writeln('(',(EndAdr-StrAdr) DIV RECLEN,' Records)');
  if ((EndAdr-StrAdr) MOD RECLEN)<>0 then writeln('(!!! KEIN RECORD VIELFACHES !!!)');
  if WARN<>0 then
  begin
    writeln('!!! ',WARN,' ungueltige Zeilenlaenge(n) gefunden !!!');
    DisplayWarnings;
  end;
END.