program SortLab(input,output);

{ Sort file of type

               lab1     equ       0123h

  by first or last elements value

  Call it : SORTLAB [-Option] file1 [file2]

  If two files are defined, both are mixed together into 'file1'

  Option may be L for label to be sorted -- default
             or V for value to be sorted

  Version of 17.12.1993 - Werner Cirsovius

}

{$V-}

const
  NUL          = 0;
  Fil          = 1;
  First        = 1;
  Second       = 2;
  Third        = 3;
  One          = 1;
  Two          = 2;
  Three        = 3;
  NO           = FALSE;
  OFF          = FALSE;
  ON           = TRUE;
  cr           = ^M;
type
  sstring      = string;
  Position     = (L,V);
  File_Type    = (R,W);
  Line         = string[16];
  LabPtr       = ^Labels;
  Labels       = record
                   Lab_Def  : Line;
                   Lab_Val  : Line;
                   Lab_Cont : Line;
                   Link     : LabPtr;
                 end;
var
  Sort         : Position;
  Lines        : integer;
  CurLine      : integer;
  Runs         : integer;
  i            : integer;
  F            : text;
  Option       : Line;
  Base         : LabPtr;
  Cur          : LabPtr;
  LegalChar    : Set of Char;
  SrcFile      : array[One..Two] of string;

procedure UPPER(var S:sstring);
{ Convert string to UPPER case }
var
  i            : integer;
Begin
  for i:=First to length(S) do S[i]:=UpCase(S[i]);
End;

procedure PrgERR(S:sstring);
{ Give error message and exit }
Begin
  writeln;
  writeln('FATAL : ',S);
  Halt;
End;

function OptionFound:boolean;
{ Test option prefix found }
Begin
  OptionFound:=(Option[First]='-');
End;

function SelectOption:Position;
{ Get valid option }
var
  ch           : char;
  S            : Position;

  procedure OptErr;
  { Process option error }
  begin
    PrgERR('Invalid option');
  end;

Begin { SelectOption }
  If NOT OptionFound then OptErr;
  ch:=UpCase(Option[Second]);
  case ch of
    'L' : S:=L;
    'V' : S:=V;
    else OptErr;
  end;
  SelectOption:=S;
End;

procedure Open(var N:sstring;Mode:File_Type);
{ Open file for read or write }
Begin
  assign(F,N);
  case Mode of
    R : begin
          {$I-}reset(F);{$I+}
          if NOT (IOResult=NUL) then PrgERR('Cannot find file : '+N);
        end;
    W : rewrite(F);
  end;
End;

function Nice(var L:Line; Disp:boolean):boolean;
{ Read line and test if it is a 'nice' one }
Begin
  readln(F,L);
  if (Disp=ON) then write('Line ',CurLine,cr);
  inc(CurLine);
  if NOT (length(L)=NUL) then Nice:=(NOT (L[First]=';'))         AND
                                    (     L[First] in LegalChar)
                         else Nice:=NO;
End;

function Get_Lines:integer;
{ Calculate number of 'nice' lines in file }
var
  i            : integer;
  Dummy        : line;
Begin
  i:=NUL;
  while NOT EOF(F) do if Nice(Dummy,OFF) then inc(i);
  Get_Lines:=i;
End;

function Found(var P:LabPtr):boolean;
{ Test label already in list }
var
  Pc           : LabPtr;
  Hit          : boolean;
Begin
  Hit:=NO;
  Pc:=Base;
  if NOT (Pc=NIL) then
  repeat
    Hit:=(Pc^.Lab_Def =P^.Lab_Def)    AND
         (Pc^.Lab_Cont=Pc^.Lab_Cont);
    if NOT Hit then Pc:=Pc^.Link;
  until (Pc=NIL) or Hit;
  Found:=Hit;
End;

procedure Put(var P:LabPtr);
{ Put label to list }
var
  Found        : boolean;
  Tmp          : LabPtr;
  Prev         : LabPtr;
Begin
  if Base=NIL then
  begin
    Base:=P;
    Cur:=P;
  end else
  begin
    Found:=FALSE;
    Tmp:=Base;
    Prev:=NIL;
    repeat
      case Sort of
        V : Found:=Tmp^.Lab_Cont>P^.Lab_Cont;
        L : Found:=Tmp^.Lab_Def >P^.Lab_Def;
      end;
      if NOT Found then
      begin
        Prev:=Tmp;
        Tmp:=Tmp^.Link;
      end;
    until (Tmp=NIL) OR Found;
    if Found then
    begin
      if Prev=NIL then
      begin
        Base:=P;
        P^.Link:=Tmp;
      end else
      begin
        P^.Link:=Prev^.Link;
        Prev^.Link:=P;
      end;
    end else
    begin
      Cur^.Link:=P;
      Cur:=P;
    end;
  end;
End;

procedure Read_All;
{ Read complete file and process label list }
var
  i            : integer;
  p            : integer;
  Ptr          : LabPtr;
  LabLine      : sstring;

  procedure GetItem(var Ps:integer; var Src,Dst:Line);
  { Extract item from line }
  begin
    Dst:='';
    while (Src[Ps] in LegalChar) AND NOT (Ps>length(Src)) do
    begin
      Dst:=Dst+Src[Ps];
      inc(Ps);
    end;
  end;

  procedure FixItem(var Item:Line);
  { Extract item from line and delete parts of line }
  begin
    P:=First;
    GetItem(P,LabLine,Item);
    delete(LabLine,First,pred(P));
  end;

  procedure Clean(var S:sstring);
  { Delete non-alpha characters }
  begin
    while NOT ((S[First] in LegalChar) OR
               (length(S)=NUL))           do delete(S,1,1);
  end;

Begin { Read_All }
  while NOT EOF(F) do
  begin
    if Nice(LabLine,ON) then
    begin
      new(Ptr);
      with Ptr^ do
      begin
        FixItem(Lab_Def);     { Get 'lxxxx'                }
        Lab_Val:=LabLine;     { Save remainder 'equ xxxxh' }
        Clean(LabLine);
        FixItem(Lab_Cont);    { Dummy read                 }
        Clean(LabLine);
        Lab_Cont:=LabLine;    { Get 'xxxxh'                }
        Link:=NIL;
      end;
      If NOT Found(Ptr) then Put(Ptr);
    end;
  end;
End;

procedure Write_All;
{ Write entire table to file }
Begin
  Cur:=Base;
  while NOT (Cur=NIL) do
  begin
    writeln(F,Cur^.Lab_Def,Cur^.Lab_Val);
    Cur:=Cur^.Link;
  end;
End;

procedure Help;
{ Give help and halt program }
Begin
  writeln('Sort file of type');
  writeln('         lab1     equ    0123h');
  writeln('by first or last elements value');
  writeln;
  writeln('Call it : SORTLAB [-Option] file1 [file2]');
  writeln;
  writeln('If two files are defined, both are mixed together into ''file1''');
  writeln;
  writeln('Option may be L for label to be sorted -- default');
  writeln('           or V for value to be sorted');
  halt;
End;

BEGIN  { M A I N }
  LegalChar:=['!'..'~'];
  Base:=NIL;
  If (ParamCount>NUL) then Option:=ParamStr(First);
  case ParamCount of
    One   : begin
              SrcFile[First]:=ParamStr(First);
              Runs:=One;
              Sort:=L;
            end;
    Two   : if OptionFound then
            begin
              SrcFile[First]:=ParamStr(Second);
              Runs:=One;
              Sort:=SelectOption;
            end else
            begin
              SrcFile[ First]:=ParamStr(First);
              SrcFile[Second]:=ParamStr(Second);
              Runs:=Two;
              Sort:=L;
            end;
    Three : begin
              SrcFile[ First]:=ParamStr(Second);
              SrcFile[Second]:=ParamStr(Third);
              Runs:=Two;
              Sort:=SelectOption;
            end;
    else    Help;
  end;

  for i:=First to Runs do
  begin
    UPPER(SrcFile[i]);
    Open(SrcFile[i],R);
    Lines:=Get_Lines;
    close(F);
    writeln('Found ',Lines:5,' elements in file ',SrcFile[i]);
    if Lines=NUL then PrgERR('No elements in file');
    Open(SrcFile[i],R);
    CurLine:=NUL;
    Read_All;
    close(F);
    writeln;
    writeln('Elements read');
  end;

  Open(SrcFile[First],W);
  Write_All;
  close(F);
  writeln('Done');
END.
eln;
    writeln('Elements read');
  end;

  Open(SrcFile[First],W);
  Write_All;
  close(F);
  writeln('Done'