Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/INLINE22.ZIP/UNPARS.INC

Text File | 1987-09-27 | 7.0 KB | 318 lines

                       {
UnPars.inc}
(*********  Source code Copyright 1986, by L. David Baldwin   *********)

Type
  Symb = (Nul,Ident4,Ident2,Identunk,Bytesy,Wordsy,Lparn,Rparn);
Var
  Sy  : Symb;

{
-------------DefaultExtension}
PROCEDURE DefaultExtension(Extension:Filestring;Var Infile,Name :Filestring);
{Given a filename, infile, add a default extension if none exists. Return
 also the name without any extension.}
Var
 I,J : Integer;
 Temp : Filestring;
begin
I:=Pos('..',Infile);
if I=0 then
  Temp:=Infile
else
  begin   {a pathname starting with ..}
  Temp:=Copy(Infile,I+2,64);
  I:=I+1;
  end;
J:=Pos('.',Temp);
if J=0 then
  begin
  Name := Infile;
  Infile:=Infile+'.'+Extension;
  end
else Name:=Copy(Infile,1,I+J-1);
end;

{
-------------GetCh}
PROCEDURE GetCh;
{Return next char in Uch and lch with Uch in upper case. Ignore comments}
Var Comment : Boolean;
  PROCEDURE GetchBasic; {read a character and a character pair}
  begin
  if Chi<=Ord(St[0]) then
    begin  {NOTE: pair has the same address as lch}
    Move(St[Chi], Pair, 2);
    if LCh=Chr(Tab) then LCh:=' ';
    UCh := UpCase(LCh);
    Chi := Chi+1;
    end
  else
    if not EOF(Inf) then
      begin
      ReadLn(Inf,St);
      St:=St+' ';  {EOL is equivalent to space}
      Chi:=1;
      GetCh;
      end
    else
      begin
      EofInf:=True;
      if Comment then
        begin
        WriteLn('Open Comment at End of Input File');
        Halt(1);
        end;
      end;
  end;

begin  {Getch}
if UCh<>' ' then
  Symname:=Symname+UCh;  {build up a phrase with old character}
repeat
  if EofInf then
    begin WriteLn('Unexpected End of Input File'); Halt(1) end;
  Comment:=False;
  GetchBasic;
  if (UCh='{') or (Pair='(*') then
    begin
    Comment:=True;
    if UCh='{' then repeat GetchBasic; until UCh='}'
    else
      begin
      repeat GetchBasic; until Pair='*)';
      GetchBasic;  {pass by the '*'}
      end;
    end;
until not Comment;
end;

{
-------------SkipSpaces}
PROCEDURE SkipSpaces;
begin
while (UCh=' ') or (UCh=Chr(Tab)) do
  GetCh;
end;

{
-------------GetDec}
FUNCTION GetDec(Var V :Integer): Boolean ;
Const
  Ssize = 8;
Var
  S        : String[Ssize];
  Getd     : Boolean;
  Code     : Integer;
begin
Getd := False;
S := '';
while (UCh>='0') and (UCh<='9') do
  begin
  Getd := True;
  if Ord(S[0])<Ssize
    then S := S+UCh;
  GetCh;
  end;
if Getd then
    begin
    Val(S,V,Code);
    if Code<>0
      then Error(Chi,'Bad Number Format');
    end;
GetDec := Getd;
end;

{
-------------GetHex}
FUNCTION GetHex(Var H :Integer): Boolean;
Var
  Digit   : Integer;     {check for '$' before the call}
begin
H := 0;
GetHex := False;
while (UCh in ['A'..'F','0'..'9']) do
  begin
  GetHex := True;
  if (UCh>='A')
    then Digit := Ord(UCh)-Ord('A')+10
    else Digit := Ord(UCh)-Ord('0');
  if H>=$1000
    then Error(Chi,'Overflow');
  H := (H Shl 4)+Digit;
  GetCh;
  end;
end;

{
-------------GetNumber}
FUNCTION GetNumber(Var N :Integer): Boolean;
{get a number and return it in n}
begin
SkipSpaces;
N := 0;
if UCh='$'
  then
    begin        {a hex number}
    GetCh;
    if not GetHex(N)
      then Error(Chi, 'Hex Number Exp');
    GetNumber := True;
    end
  else
    begin        {maybe a decimal number}
    GetNumber := GetDec(N);
    end;
end;

{
-------------GetExpr}
FUNCTION GetExpr(Var Rslt :Integer): Boolean;
Var
  Rs1,Rs2 : Integer;
  Pos,Neg,GE : Boolean;
begin
GE := False;
SkipSpaces;
Neg := UCh='-';
Pos := UCh='+';
if Pos or Neg
  then GetCh;
if GetNumber(Rs1)
  then
    begin
    GE := True;
    if Neg
      then Rs1 := -Rs1;
    SkipSpaces;
    if (UCh='+') or (UCh='-') then
      if GetExpr(Rs2) then
        Rs1 := Rs1+Rs2      {GetExpr will take care of sign}
      else GE:=False;
    Rslt := Rs1;
    end;
SkipSpaces;
GetExpr:=GE and ((UCh='/') or (UCh=')'));  {must terminate in '/' or ')'}
end;

{
-------------GetToken}
PROCEDURE GetToken;
Const
  Tokenchars : set of Char = ['A'..'Z','0'..'9','_'];
  Startchars : set of Char = ['A'..'Z','_'];
begin
while not (UCh in Startchars) and not EofInf do GetCh;
Token[0] := #0;
if not EofInf then
    while UCh in Tokenchars do
      begin
      if Ord(Token[0])<Tokenleng
        then Token := Token+UCh;
      GetCh;
      end;
end;

{
-------------Next}
PROCEDURE Next;
Var C : Char;

  FUNCTION GetExprX(Var N : Word; Var C : Char): Boolean;
  begin
  C:=UCh;
  if (UCh='>') or (UCh='<') then GetCh;
  GetExprX:=GetExpr(Integer(N));
  end;

begin
Sy := Nul;
repeat
  SkipSpaces;
  Symname[0]:=#0;     {build up a phrase which may be needed later}
  if BytePending then
    begin
    NValue:=PendingByte;
    BytePending:=False;
    Sy:=Bytesy;
    end
  else if UCh='(' then begin Sy:=Lparn; GetCh; end
  else if UCh=')' then begin Sy:=Rparn; GetCh; end
  else if UCh='/' then Error(Chi+2, 'Syntax')
  else if GetExprX(NValue,C) then
    begin
    if C='<' then Sy:=Bytesy
      else if C='>' then Sy:=Wordsy
      else if NValue and $FF00 = 0 then Sy := Bytesy
      else Sy:=Wordsy;
    if UCh='/' then GetCh;
    end
  else
    begin  {it's a symbolic phrase}
    while (UCh<>'/') and (UCh<>')') do GetCh;  {finish reading the phrase}
    if UCh='/' then
      begin
      GetCh;  {pass the '/' by}
      Symname[0]:=Pred(Symname[0]); {but remove it from phrase}
      end;
    if (Pos('>',Symname)>0) or (Pos('*',Symname)>0) then
      Sy:=Ident4
    else if Pos('<',Symname)>0 then Sy:=Ident2
    else Sy:=Identunk;    {unknown size}
    end;
  if Sy=Nul then GetCh;
until Sy<>Nul;
end;

{
-------------GetByte}
FUNCTION GetByte(Var P :Packet; PhraseOk : Boolean): Boolean;
Var Result : Boolean;
begin
Result:=True;
with P do
  begin
  Dispsize:=Bytesize;  Phrase:=False;
  if (Sy=Ident2) or (Sy=Identunk) then
    begin
    if not PhraseOk then Result:=False
    else
      begin
      Phrase:=True;
      if Sy=Identunk then Insert('<',Symname,1);
      S:=Symname;  {the phrase}
      end;
    end
  else if Sy=Bytesy then Value:=Lo(NValue)
  else if Sy=Wordsy then
    begin
    Value:=Lo(NValue);
    BytePending:=True;
    PendingByte:=Hi(NValue);
    end
  else Result:=False;
  if Result then
    begin
    PC:=PC+1;
    Next;
    end;
  GetByte:=Result;
  end;
end;

{
-------------GetWord}
PROCEDURE GetWord(Var P :Packet);
Var H,L : Packet;
  PROCEDURE WordErr;
  begin Error(Chi,'Word or two bytes exp'); PC:=PC+2; Next; end;
begin
with P do
  begin
  Dispsize:=Wordsize; Phrase:=False;
  if (Sy=Ident4) or (Sy=Identunk) then
    begin
    if Sy=Identunk then Insert('>',Symname,1);
    Phrase:=True; S:=Symname;
    PC:=PC+2;  Next;
    end
  else if Sy=Ident2 then WordErr
  else if Sy=Wordsy then
    begin Value:=NValue; PC:=PC+2;  Next; end
  else if GetByte(L,not PhraseOk) then
    begin
    if not GetByte(H, not PhraseOk) then NumbyteErr;
    Value:=H.Value Shl 8 +L.Value;
    end
  else WordErr;
  end;
end;