program BldLib(input,output);
(*
Library Module fuer BASELIB erzeugen.

Aufruf mit:

	BLDLIB Assemblerdatei

In den BASELIB-Modulen muss die Kopfzeile folgendes Format haben, z.B.:

	title	Module from library BASE_4 : CREBAK
*)

const
  KOPFZEILE    =^I'title'^I'Module from library ';
  MACtyp       = '.MAC';
  OBJtyp       = '.REL';
  SUBtyp       = '.SUB';
  SUBdef       = 'BL';
type
  DateiName    = string[ 14];
  Zeile        = string[255];
  FehlerTyp    = (KeineDatei,Format,KeinPlatz);
  DateiModus   = (Anhang,Erzeugung);
var
  LIBNAME,
  SUB,
  LIB,
  SRC          : DateiName;
  LibZeile     : Zeile;

procedure Hilfe;
Begin
  writeln('BASELIB Modul erzeugen und an Library anhaengen');
  writeln;
  writeln('Aufruf mit:');
  writeln;
  writeln('        BLDLIB Assemblerdatei');
  writeln;
  writeln('In den BASELIB-Modulen muss die Kopfzeile folgendes Format haben, z.B.:');
  writeln('        title   Module from library BASE_4 : CREBAK');
  halt;
End;

procedure Fehler(Typ:FehlerTyp);
Begin
  case Typ of
    KeineDatei : writeln('Assemblerdatei ',SRC,' nicht gefunden');
    Format     : begin
                   writeln('Ungueltige Kopfzeile gefunden');
                   writeln;
                   writeln('Erwartet: "',KOPFZEILE,'"');
                   writeln('Gefunden: "',LibZeile,'"');
                 end;
    KeinPlatz  : writeln('Keine freie SUBMIT-Datei');
  end;
  writeln('*** ABBRUCH ***');
  halt;
End;

function vorhanden(var F:DateiName):boolean;
(* Test, ob Datei existiert *)
var
  Resultat     : boolean;
  FF           : file;
Begin
  assign(FF,F);
  {$I-}reset(FF){$I+};
  Resultat:=IOresult=0;
  if Resultat then close(FF);
  vorhanden:=Resultat;
End;

procedure QuelleOeffnen;
(* Quelldatei oeffnen *)
Begin
  SRC:=ParamStr(1);
  if pos('.',SRC)=0 then SRC:=SRC+MACtyp;
  if not vorhanden(SRC) then Fehler(KeineDatei);
End;

procedure LibrayNamenholen;
(* Dateinamen der Library aus Quelle ermitteln *)
var
  Zeichen      : char;
  p            : integer;
  FS           : text;
Begin
  assign(FS,SRC);
  reset(FS);
  readln(FS,LibZeile);
  close(FS);
(*
  Pruefen, ob erste Zeile richtig beginnt
*)
  if pos(KOPFZEILE,LibZeile)=0 then Fehler(Format);
(*
  Zeiger auf Anfang des Librarynamens
*)
  p:=succ(length(KOPFZEILE));
  LIBNAME:='';
(*
  Namen zusammenstellen, bis Endzeichen gefunden wurde
*)
  while p<>length(LibZeile) do
  begin
    Zeichen:=LibZeile[p];
    if not (Zeichen in [' ','_']) then LIBNAME:=LIBNAME+Zeichen;
    p:=succ(p);
    if Zeichen=' ' then p:=length(LibZeile);
  end;
  writeln('Modul fuer Library ',LIBNAME,' gefunden');
  LIB:=LIBNAME+OBJtyp;
End;

procedure SubmitDateiAnlegen(Modus:DateiModus);
(* Submitdatei anlegen *)
var
  frei,
  voll         : boolean;
  p            : integer;
  SUBNAME,
  SRCNAME      : DateiName;
  SubDatei,
  DoSubDatei   : text;
  SubNummmer   : string[3];

  procedure NeueSubNummer;
  (* ASCII Zahl erhoehen *)
  begin
    p:=length(SubNummmer);
    repeat
      SubNummmer[p]:=succ(SubNummmer[p]);
      if SubNummmer[p]>'9' then begin
                                  SubNummmer[p]:='0';
                                  p:=pred(p);
                                end
                           else p:=0;
    until p=0;
  end;

Begin (* SubmitDateiAnlegen *)
(*
  Freie Datei suchen im Bereich BL000.SUB bis BL999.SUB
*)
  SubNummmer:='000';
  repeat
    SUBNAME:=SUBdef+SubNummmer+SUBtyp;
    frei:=not vorhanden(SUBNAME);
    voll:=SubNummmer='999';
    if not (frei or voll) then NeueSubNummer;
  until frei or voll;
  if voll then Fehler(KeinPlatz);
(**)
  p:=pos('.',SRC);
  SRCNAME:=copy(SRC,1,pred(p));
  SUB:=SRCNAME+'.SUB';
  assign(SubDatei,SUB);
  rewrite(SubDatei);
(*
  Anweisungen in Datei schreiben:

  M80 =Quelle
  LIB Library=Quelle oder LIB Library=Library,Quelle
  ERASE Quelle
  ERASE SUBMIT-Datei

  Die Datei dann aufrufen mit "SUBMIT SUBMIT-Datei"
*)
  writeln(SubDatei,'M80 =',SRCNAME);
  write(SubDatei,'LIB ',LIBNAME,'=');
  if Modus=Anhang then write (SubDatei,LIBNAME,',');
  writeln(SubDatei,SRCNAME);
  writeln(SubDatei,'ERASE ',SRCNAME,OBJtyp);
  writeln(SubDatei,'ERASE ',SUBNAME);
  close(SubDatei);
(**)
  assign(DoSubDatei,SUBNAME);
  rewrite(DoSubDatei);
  writeln(DoSubDatei,'SUBMIT ',SUB);
  close(DoSubDatei);
(**)
  write('Modul ',SRCNAME,' in ');
  if Modus=Erzeugung then write('neuer ');
  writeln('Library ',LIBNAME,' mit Aufruf "SUBMIT ',SUBNAME,'" speichern');
End;

BEGIN (* MAIN *)
  if Paramcount<>1 then Hilfe;
  QuelleOeffnen;
  LibrayNamenholen;
  if vorhanden(LIB) then SubmitDateiAnlegen(Anhang)
                    else SubmitDateiAnlegen(Erzeugung);
END.