Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/PCRF.ZIP/PCRF.PAS

Pascal/Delphi Source File | 1985-12-28 | 19.6 KB | 848 lines

(*
 * pcrf - pascal cross reference utility
 *        for use with output filters
 *
 * usage:
 *       pcrf FILE.PAS | crfprn >PRN
 *            for a procedure crossreference listing
 *
 *       pcrf FILE.PAS | ph >PRN
 *            for a procedure heriarchy listing
 *
 * shs 9/9/85
 *
 *)

{$g1024,p128,d-,c-}


program pascalcrf (input,
                   output);
const
   identsize =    40;         {identifier size for data type alignment}

   {must match 'ph' ident size}

   linelen =      128;        {longest line length}

   newline =      ^J;

type
   anystring =    string [linelen];
   toktypes =     (number,
                   identifier,
                   strng,
                   comment,
                   unknown);

var
   ltok:          anystring;
   ptok:          anystring;
   ptoktype:      toktypes;
   tok:           anystring;
   toktype:       toktypes;
   unchrflag:     char;
   utok:          anystring;
   untokflag:     boolean;
   utoktype:      toktypes;
   inproc:        anystring;
   line:          integer;
   srcline:       integer;
   crfall:        boolean;
   crfdata:       boolean;

(*
 * pascal lexical scanner
 *
 *)


function getchar: char;
   var
      c:             char;

   begin

      if unchrflag <> chr (0) then
      begin
         getchar := unchrflag;
         unchrflag := chr (0);
      end
      else
      begin

         if eof (input) then
         begin
            writeln(con, #13, srcline, ' source lines, ',
                              line,    ' crf lines written');
            halt;
         end;

         read(input, c);

         if c = newline then
         begin
            srcline := srcline + 1;
            if (srcline mod 16) = 1 then
               write(con, #13, srcline);
         end;

         getchar := c;
      end;
   end;

procedure ungetchar (c:             char);
   begin
      unchrflag := c;
   end;

procedure scanident;
   var
      c:             char;

   begin
      toktype := unknown;

      repeat
         c := getchar;

         case c of
            'a'..'z', 'A'..'Z', '0'..'9', '_':
               ltok := ltok + c;

            else           toktype := identifier;
         end;
      until toktype = identifier;

      ungetchar(c);
   end;

procedure scannumber;
   var
      c:             char;

   begin
      toktype := unknown;

      repeat
         c := getchar;

         case c of
            '0'..'9', '.': ltok := ltok + c;

            else           toktype := number;
         end;
      until toktype = number;

      ungetchar(c);
   end;

procedure scanstring;
   var
      c:             char;

   begin
      toktype := unknown;

      repeat
         c := getchar;
         ltok := ltok + c;

         if c = '''' then
         begin
            c := getchar;

            if c = '''' then
               ltok := ltok + c
            else
            begin
               ungetchar(c);
               toktype := strng;
            end;
         end;
      until toktype = strng;
   end;

procedure scanhex;
   var
      c:             char;

   begin
      c := getchar;

      while c in ['0'..'9', 'A'..'F', 'a'..'f'] do
      begin
         ltok := ltok + c;
         c := getchar;
      end;

      ungetchar(c);
      toktype := number;
   end;

procedure scantok;
   var
      c:             char;

   begin

      repeat
         c := getchar;


         case c of
            ' ',^I,^M,^J,^@,^L:
               c := newline;
         end;
      until c <> newline;

      ltok := c;

      case c of
         'a'..'z', '_', 'A'..'Z':
            scanident;

         '0'..'9', '#': scannumber;

         '''':          scanstring;

         '$':           scanhex;

 BEGIN
              New (TPLoc);
              WITH TPLoc^ DO
                BEGIN
                  PLoc     := PosCnt;
                  Oprtion  := OprCh;
                  PAdj     := PAValue;
                  OSet     := AOffset;
                  TwoBytes := Both;
                  PNext    := Nil
                END;
              New (TPatch);
              WITH TPatch^ DO
                BEGIN
                  PName      := Id;
                  FixLoc     := TPLoc;
                  LeftPatch  := Nil;
                  RightPatch := Nil
                END;
              APatch := TPatch
            END
          ELSE IF Id < APatch^.PName THEN
            AddPatch (APatch^.LeftPatch, Both, Id, AOffset, OprCh, PAValue)
          ELSE IF Id > APatch^.PName THEN
            AddPatch (APatch^.RightPatch, Both, Id, AOffset, OprCh, PAValue)
          ELSE
            BEGIN
              New (TPLoc);
              WITH TPLoc^ DO
                BEGIN
                  PLoc     := PosCnt;
                  Oprtion  := OprCh;
                  PAdj     := PAValue;
                  OSet     := AOffset;
                  TwoBytes := Both;
                  PNext    := Nil
                END;
              AddLoc (APatch^.FixLoc, TPLoc)
            END
        END;  { AddPatch }

      PROCEDURE ViaLabel ( LeadIn  : _String;
                           Both    : Boolean;
                           Id      : LabelStr;
                           AOffset : Boolean;
                           OprCh   : Char;
                           PAValue : Integer );

        BEGIN { ViaLabel }
          Write (' Via label [', Id, ']');
          Generate (LeadIn);
          AddPatch (Patches, Both, Id, AOffset, OprCh, PAValue);
          Generate (Null);
          IF Both THEN
            Generate (Null)
        END;  { ViaLabel }

      PROCEDURE OperLabel ( LeadIn  : _String;
                            Both    : Boolean;
                            Id      : LabelStr;
                            AOffset : Boolean );

        BEGIN { OperLabel }
          Get_Symbol; { Operation | ? }
          IF Sym <> Operation THEN
            ViaLabel (LeadIn, Both, Id, AOffset, '+', 0)
          ELSE
            BEGIN
              TempOpCh := Ch;
              Get_Symbol; { Number }
              IF Sym <> Number THEN
                Write ('Number expected');
              ViaLabel (LeadIn, Both, Id, AOffset, TempOpCh, Val_Radix (Num, P_Radix) )
            END
        END;  { OperLabel }

      PROCEDURE DoReg1 ( LeadIn  : Char;
                         StartOp : Byte );

        BEGIN { DoReg1 }
          IF LeadIn <> Skip THEN
            Generate (LeadIn);
          CASE Check_Reg OF
            A : Generate (Chr (StartOp - 0) );
            B : Generate (Chr (StartOp - 7) );
            C : Generate (Chr (StartOp - 6) );
            D : Generate (Chr (StartOp - 5) );
            E : Generate (Chr (StartOp - 4) );
            H : Generate (Chr (StartOp - 3) );
            L : Generate (Chr (StartOp - 2) );
          END
        END;  { DoReg1 }

      PROCEDURE DoONCR ( StartOp : Byte );

        BEGIN { DoONCR }
          CASE Sym OF
            Identifier : DoReg1 (#$CB, StartOp);
            Left_Bp    :
              BEGIN
                Get_Symbol;
                  IF Sym <> Identifier THEN
                    Error ('Op code expected')
                  ELSE
                    CASE Check_Reg OF
                      HL : Generate (#$CB + Chr (StartOp - 1) );
                      IX :
                        BEGIN
                          Get_Symbol;
                          IF Sym <> Operation THEN
                            Error ('+ Expected')
                          ELSE
                            Get_Symbol;
                          Generate (#$DD + #$CB + Chr (Val_Radix (Num, P_Radix) ) + Chr (StartOp - 1) )
                        END;
                      IY :
                        BEGIN
              else           toktype := unknown;
      end;
   end;

procedure ungettoken;
   var
      i:             integer;

   begin
      untokflag := true;
      utoktype := toktype;
      utok := ltok;
      toktype := ptoktype;
      ltok := ptok;
      tok := ptok;

      for i := 1 to length (tok) do
         tok[i]:= upcase (tok [i]);
   end;

procedure gettok; forward;

procedure skipcurlycomment;
   var
      c:             char;

   begin

      repeat
         c := getchar;
      until c = '}';

      toktype := comment;
   end;

procedure skipparencomment;
   var
      c:             char;

   begin

      repeat
         c := getchar;

         if c = '*' then
         begin
            c := getchar;

            if c = ')' then
               toktype := comment
            else
               ungetchar(c);
         end;
      until toktype = comment;
   end;

procedure gettok;
   var
      i:             integer;
      c:             char;

   begin

      if keypressed then
      begin
         read(kbd, c);

         if c =^C then
         begin
            writeln(con, '** ^C');
            halt;
         end;
      end;

      if untokflag then
      begin
         untokflag := false;
         toktype := utoktype;
         ltok := utok;
         tok := utok;

         for i := 1 to length (tok) do
            tok[i]:= upcase (tok [i]);
      end
      else
      begin
         ptok := ltok;

         repeat
            ptoktype := toktype;
            scantok;

            if ltok = '{' then
               skipcurlycomment;

            if ltok = '(' then
            begin
               c := getchar;

               if c = '*' then
                  skipparencomment
               else
                  ungetchar(c);
            end;
         until toktype <> comment;
      end;

      tok := ltok;

      if toktype = identifier then

         for i := 1 to length (ltok) do
            tok[i]:= upcase (ltok [i]);
   end;

procedure scaninit;
   begin
      ltok := '';
      ptok := '';
      tok := '';
      toktype := unknown;
      untokflag := false;
      unchrflag := chr (0);
      line := 0;
      srcline := 0;
      inproc := 'MAIN';
   end;

procedure nexttoken;
   begin
      gettok;
   end;


(*
 * pascal parser and output formatting
 *
 *)

procedure pblock; forward;

procedure pstatement; forward;

procedure punit; forward;

procedure pvar; forward;

procedure syntax (message:       anystring);
   begin
      writeln(con);
      writeln(con, '****** ', message, ',  token="', tok, '"');
   end;


(*
 * output a token to crf stream unless it is a
 * pascal reserved word
 *
 *)

procedure crf_output (lt:            anystring);
   var
      i:             integer;
      t:             anystring;

   const
      nkey = 21;
      keyword: array[1..nkey] of anystring =
         ('AND',  'BEGIN', 'CASE',  'DIV',  'DO',   'ELSE', 'END',
          'FOR',  'IF',    'IN',   'MOD',  'NOT',  'OF',
          'OR',   'REPEAT','THEN', 'TO',   'UNTIL','VAR',   'WHILE',
          'WITH');
   begin
      t := lt;

      for i := 1 to length (t) do
         t[i]:= upcase (t [i]);

      for i := 1 to nkey do
      begin
         if keyword[i] > t then
         begin
            writeln(lt, '' : identsize - length (lt), inproc);
            line := line + 1;
            exit;
         end;


         if keyword[i] = t then
            exit;
      end;

      writeln(lt, '' : identsize - length (lt), inproc);
      line := line + 1;
   end;


(*
 * get next token and decide if any output
 * to the crf stream is needed
 *
 *)

procedure crf_nexttoken;
   begin
      nexttoken;

      if crfdata then
      begin                        {generate crossreference for all
                                    identifiers that don't look like procedure
                                    references}

         if (tok <> '(') and (ptoktype = identifier) then
            crf_output(ptok);

      end
      else

      if crfall then
      begin                         {generate corssreference for all
                                      identifiers}
         if toktype = identifier then
            crf_output(ltok);
      end
      else                       {crossreference only procedure and function
                                   calls. note that this will not find
                                   function calls in an expression that
                                   do not have parameters}


      if (tok = '(') and (ptoktype = identifier) then
         crf_output(ptok);

   end;


(*
 * control statement processors
 *    for, while, repeat, with, idents
 *
 * all expect tok to be keyword
 * all exit at end of statement with next nexttoken as ; or end
 *
 *)

procedure pfor;
   begin

      repeat
         crf_nexttoken;
      until tok = 'DO';

      crf_nexttoken;
      pstatement;
   end;

procedure pwhile;
   begin

      repeat
         crf_nexttoken;
      until tok = 'DO';

      crf_nexttoken;
      pstatement;
   end;

procedure pwith;
   begin

      repeat
         crf_nexttoken;
      until tok = 'DO';

      crf_nexttoken;
      pstatement;
   end;

procedure prepeat;
   begin
      crf_nexttoken;

      while tok <> 'UNTIL' do
      begin
         pstatement;
         crf_nexttoken;

         if tok = ';' then
            crf_nexttoken;
      end;

      repeat
         crf_nexttoken;
      until (tok = ';') or (tok = 'END') or (tok = 'ELSE');

      ungettoken;
   end;

procedure pcase;
   begin

      repeat
         crf_nexttoken;
      until tok = 'OF';

      crf_nexttoken;

      repeat

         if tok <> 'ELSE' then

            repeat
               crf_nexttoken;
            until tok = ':';

         crf_nexttoken;
         pstatement;
         crf_nexttoken;

         if tok = ';' then
            crf_nexttoken;
      until tok = 'END';
   end;

procedure pif;
   begin

      repeat
         crf_nexttoken;
      until tok = 'THEN';

      crf_nexttoken;
      pstatement;
      crf_nexttoken;

      if tok = 'ELSE' then
      begin
         crf_nexttoken;
         pstatement
      end
      else
         ungettoken;
   end;

procedure pident;
   begin
      crf_nexttoken;             {get seperator token and decide if this
                                  is a procedure call with no parameters
                                  that will be missed by crf_nexttoken}

      if (tok = ';') and (not crfall) and (not crfdata) then
         crf_output(ptok);

      while (tok <> ';') and (tok <> 'END')
            and (tok <> 'ELSE') do
         crf_nexttoken;

      ungettoken;
   end;


(*
 * process single statement
 *
 * expects tok to be first token of statement
 * processes nested blocks
 * exits with tok as end of statement
 *
 *)

procedure pstatement;
   begin

      if tok = ';' then
         ungettoken
      else

      if tok = 'BEGIN' then
         pblock
      else

      if tok = 'FOR' then
         pfor
      else

      if tok = 'WHILE' then
         pwhile
      else

      if tok = 'WITH' then
         pwith
      else

      if tok = 'REPEAT' then
         prepeat
      else

      if tok = 'CASE' then
         pcase
      else

      if tok = 'IF' then
         pif
      else
         pident;
   end;


(*
 * process begin...end blocks
 *
 * expects tok to be begin
 * exits with tok = end
 *
 *)

procedure pblock;
   begin
      crf_nexttoken;                 {get first token of first statement}


      while tok <> 'END' do
      begin
                          Get_Symbol;
                          IF Sym <> Operation THEN
                            Error ('+ Expected')
                          ELSE
                            Get_Symbol;
                          Generate (#$FD + #$CB + Chr (Val_Radix (Num, P_Radix) ) + Chr (StartOp - 1) )
                        END
                    END;
                Get_Symbol { Right_BP }
              END
          END
        END;   { DoONCR }

      PROCEDURE DoOR;

        BEGIN { DoOR }
          Sym   := Sym2;
          Ident := Ident2;
          Num   := Num2;
          CASE OpIs OF
            AND_ :
              IF Check_Reg IN [A .. L] THEN
                DoReg1 (Skip, $A7)
              ELSE IF Sym = Number THEN
                Generate (#$E6 + Chr (Val_Radix (Num, P_Radix) ) )
              ELSE
                ViaLabel (#$E6, False, Ident, False, '+', 0);
            CALL :
              IF Sym = Number THEN
                Generate (#$CD + Chr (Lo (Val_Radix (Num, P_Radix) ) ) + Chr (Hi (Val_Radix (Num, P_Radix) ) ) )
              ELSE
                ViaLabel (#$CD, True, Ident, False, '+', 0);
            CP   :
              IF Check_Reg IN [A .. L] THEN
                DoReg1 (Skip, $BF)
              ELSE IF Sym = Number THEN
                Generate (#$FE + Chr (Val_Radix (Num, P_Radix) ) )
              ELSE
                ViaLabel (#$FE, False, Ident, False, '+', 0);
            DEC  :
              CASE Check_Reg OF
                A  : Generate (#$3D);
                B  : Generate (#$05);
                BC : Generate (#$0B);
                C  : Generate (#$0D);
                D  : Generate (#$15);
                DE : Generate (#$1B);
                E  : Generate (#$1D);
                H  : Generate (#$25);
                HL : Generate (#$2B);
                IX : Generate (#$DD + #$2B);
                IY : Generate (#$FD + #$2B);
                L  : Generate (#$2D);
                SP : Generate (#$3B);
              END;
            IM   :
              CASE Val_Radix (Num, P_Radix) OF
                0 : Generate (#$ED + #$46);
                1 : Generate (#$ED + #$56);
                2 : Generate (#$ED + #$5E);
              END;
            INC  :
              CASE Check_Reg OF
                A  : Generate (#$3C);
                B  : Generate (#$04);
                BC : Generate (#$03);
                C  : Generate (#$0C);
                D  : Generate (#$14);
                DE : Generate (#$13);
                E  : Generate (#$1C);
                H  : Generate (#$24);
                HL : Generate (#$23);
                IX : Generate (#$DD + #$23);
                IY : Generate (#$FD + #$23);
                L  : Generate (#$2C);
                SP : Generate (#$33);
              END;
            JP   :
              IF Sym = Number THEN
                Generate (#$C3 + Chr (Lo (Val_Radix (Num, P_Radix) ) ) + Chr (Hi (Val_Radix (Num, P_Radix) ) ) )
              ELSE
                ViaLabel (#$C3, True, Ident, False, '+', 0);
            JR   :
              IF Sym = Number THEN
                Generate (#$18 + Chr (Val_Radix (Num, P_Radix) ) )
              ELSE
                ViaLabel (#$18, False, Ident, True, '+', 0);
            OR_  :
              IF Check_Reg IN [A .. L] THEN
                DoReg1 (Skip, $B7)
              ELSE IF Sym = Number THEN
                Generate (#$F6 + Chr (Val_Radix (Num, P_Radix) ) )
              ELSE
                ViaLabel (#$F6, False, Ident, False, '+', 0);
            POP  :
              CASE Check_Reg OF
                AF : Generate (#$