program FindLab(input,output);
{
  Program scans for Z80 store instructions like ld (label),hl
  Where 'label' is in range 0100 .. upper limit.
  Call it:

           FINDLAB [-limit] infile [[-]outfile]

  Limit defaults to 0FFF. If omitting outfile, labels will
  be printed to CON:
  If 'outfile' does exist, new data will be appended to it
  The '-' sign forces a deletion if file does exist
}
{$U+}
const
  NUL          = 0;
  One          = 1;
  Two          = 2;
  Three        = 3;
  First        = 1;
  Second       = 2;
  Third        = 3;
  Console      = 'CON:';
  Sample       = 'L1234';
  NO           = FALSE;
  DEBUG        = NO;
  cr           = ^M;
  tab          = ^I;
type
  FType        = (r,w);
  Nstring      = string[16];
  LStr         = string[5];
  Lab          = ^LabPtr;
  LabPtr       = record
                   Item : LStr;
                   Link : Lab;
                 end;

var
  ItsCON       : boolean;
  LabFound     : integer;
  TopAdr       : integer;
  len          : integer;
  SrcFile      : Nstring;
  DstFile      : Nstring;
  Option       : string;
  Fi           : text;
  Fo           : text;
  Base         : Lab;
  Cur          : Lab;

function OptionFound:boolean;
Begin
  OptionFound:=(Option[First]='-');
End;

function GetAdr:integer;
var
  Res          : integer;
  Err          : integer;
Begin
  Option[First]:='$';
  val(Option,Res,Err);
  delete(Option,1,1);
  if NOT (Err=NUL) then
  begin
    writeln('%ERROR: Invalid numeric limit >',Option,'<');
    halt;
  end;
  if NOT (Res>$0100) then
  begin
    writeln('%WARNING: Limit >',Option,'< must be > 0100H');
    halt;
  end;
  GetAdr:=Res;
End;

procedure Help;
Begin
  writeln('Program scans for Z80 store instructions like ld (label),hl');
  writeln('Where ''label'' is in range 0100 .. upper limit.');
  writeln('Call it:');
  writeln;
  writeln('         FINDLAB [-limit] infile [[-]outfile]');
  writeln;
  writeln('Limit defaults to 0FFF. If omitting outfile, labels will');
  writeln('be printed to ',Console);
  writeln('If ''outfile'' does exist, new data will be appended to it');
  writeln('The ''-'' sign forces a deletion if file does exist');
  halt;
End;

procedure Open(var f:text; n:Nstring; m:FType);
Begin
  assign(f,n);
  case m of
    r : begin
          if NOT exist(f) then
          begin
            writeln('%ERROR: Cannot find file ',n);
            halt;
          end;
          reset(f);
        end;
    w : begin
          rewrite(f);
        end;
  end;
End;

function Found(var P:Lab):boolean;
var
  Pc           : Lab;
  Hit          : boolean;
Begin
  IF DEBUG THEN WRITE('SEARCHING ',P^.ITEM,'..');
  Hit:=NO;
  Pc:=Base;
  if NOT (Pc=NIL) then
  repeat
    Hit:=(Pc^.Item=P^.Item);
    if NOT Hit then Pc:=Pc^.Link;
  until (Pc=NIL) or Hit;
  IF DEBUG THEN
  BEGIN
    IF HIT THEN WRITELN('FOUND')
           ELSE WRITELN('NEW');
  END;
  Found:=Hit;
End;

procedure Put(var P:Lab);
var
  Found        : boolean;
  Tmp          : Lab;
  Prev         : Lab;
Begin
  if NOT ItsCON then Write('Get ',P^.Item,cr);
  inc(LabFound);
  if Base=NIL then
  begin
    Base:=P;
    Cur:=P;
  end else
  begin
    Found:=FALSE;
    Tmp:=Base;
    Prev:=NIL;
    repeat
      Found:=Tmp^.Item>P^.Item;
      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 ReadLines(var f:text);
var
  p            : integer;
  l            : integer;
  Line         : string[255];
  SAdr         : string;

  function ValidAdr:boolean;
  var
    Valid      : boolean;
    Res        : integer;
    Err        : integer;
    HAdr       : string;
  begin
    SAdr:=copy(Line,succ(p),len);
    HAdr:=SAdr;
    HAdr[1]:='$';
    val(HAdr,Res,Err);
    Valid:=(Res>=$0100) AND (Res<=TopAdr) AND (Err=NUL);
    IF DEBUG THEN WRITELN('CONVERT ',HADR,' TO ',RES,'(',ERR,'):',VALID);
    ValidAdr:=Valid;
  end;

  procedure TryIt;
  var
    i          : integer;
    Ptr        : Lab;
  begin
    Line[succ(p)]:=UpCase(Line[succ(p)]);
    if ValidAdr then
    begin
      for i:=1 to length(SAdr) do SAdr[i]:=UpCase(SAdr[i]);
      IF DEBUG THEN WRITELN('PROCESS ',SADR);
      new(Ptr);
      Ptr^.Item:=SAdr;
      Ptr^.Link:=NIL;
      If NOT Found(Ptr) then Put(Ptr);
    end;
  end;

Begin { ReadLines }
  while NOT eof(f) do
  begin
    readln(f,Line);
    p:=pos('(',Line);
    if NOT (p=NUL) then
    begin
      if ((pos(')',Line)-p)=succ(len)) AND
          (Line[succ(p)] in ['l','L'])     then TryIt;
    end else
    begin
      l:=pos('ld',Line);
      if (l=NUL) then l:=pos('LD',Line);
      if NOT (l=NUL) then
      begin
        p:=pos(',',Line);
        if ((length(Line)-p)>=len)      AND
            (Line[succ(p)] in ['l','L'])     then TryIt;

      end;
    end;
  end;
  close(f);
End;

procedure LoadOld(var f:text;name:Nstring);
var
  Line         : string[255];
  Ptr          : Lab;
Begin
  assign(f,name);
  if exist(f) then
  begin
    reset(f);
    writeln('Loading old file ',name);
    while NOT eof(f) do
    begin
      readln(f,Line);
      if (length(Line)>len) then
      begin
        new(Ptr);
        Ptr^.Item:=copy(Line,1,len);
        Ptr^.Link:=NIL;
        Put(Ptr);
      end;
    end;
    close(f);
  end;
End;

procedure WriteLines(var f:text);
var
  col          : integer;
Begin
  if NOT ItsCON then writeln;
  col:=0;
  Cur:=Base;
  while NOT (Cur=NIL) do
  begin
    case ItsCON of
      TRUE  : begin
                write(f,Cur^.Item);
                inc(col);
                if (col=13) then
                begin
                  col:=0;
                  writeln(f);
                end else write(f,' ');
              end;
      FALSE : begin
                write(f,Cur^.Item,tab,'EQU',tab);
                if NOT (Cur^.Item[2] in ['0'..'9']) then write(f,'0');
                writeln(f,copy(Cur^.Item,2,pred(len)),'H');
                write('Put ',Cur^.Item,cr);
              end;
    end;
    Cur:=Cur^.Link;
end;
  if ItsCON AND (NOT (col=NUL)) then writeln(f);
  close(f);
End;

BEGIN  { MAIN }
  len:=length(Sample);
  Base:=NIL;
  TopAdr:=$0fff;
  DstFile:=Console;
  LabFound:=0;
  If (ParamCount>NUL) then Option:=ParamStr(First);
  case ParamCount of
    One   : begin
              SrcFile:=ParamStr(First);
            end;
    Two   : if OptionFound then
            begin
              SrcFile:=ParamStr(Second);
              TopAdr:=GetAdr;
            end else
            begin
              SrcFile:=ParamStr(First);
              DstFile:=ParamStr(Second);
            end;
    Three : begin
              SrcFile:=ParamStr(Second);
              DstFile:=ParamStr(Third);
              TopAdr:=GetAdr;
            end;
    else    Help;
  end;
  IF DEBUG THEN WRITELN('START FOR ',$0100,'..',TOPADR);
  if (DstFile[1]='-') then
  begin
    delete(DstFile,1,1);
    if NOT (DstFile=Console) then
    begin
      assign(Fi,DstFile);
      if exist(Fi) then erase(Fi);
    end;
  end;
  ItsCON:= (DstFile=Console);
  if NOT ItsCON then LoadOld(Fi,DstFile);
  Open(Fi,SrcFile,r);
  Open(Fo,DstFile,w);
  ReadLines(fi);
  WriteLines(fo);
  if NOT ItsCON then writeln;
  writeln(LabFound,' labels processed');
 END.