Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/XREFPAS4.ZIP/XREFPAS.PAS

Pascal/Delphi Source File | 1985-11-23 | 9.0 KB | 303 lines

program XREFPAS;

{-----------------------------------------------------------------------

 *** TURBO PASCAL (tm) PROGRAM LISTER AND CROSS REFERENCE GENERATOR ***
                         Version 4.00, 11/13/85
                        Author: Glen F. Marshall

 Usage: XREFPAS filename [listname]

 Where: filename is the input Turbo Pascal program file

        listname is the output list file (default is LST:)

 Note:  Programs which contain syntax errors may be processed
        incorrectly by this program.

-----------------------------------------------------------------------}

{$P128,D-,C-,K-,R-,U-}

{$I sort.box}
{$I datetime.pas}

const
  C1        = 16;            { characters per symbolic name }
  C2        = 12;            { line numbers per printed reference line }
  C3        =  5;            { size of displayed line numbers }
  FF        = #12;           { form-feed character }
  NUL       = #0;            { hex-zero character }

type
  State     = (Other,Symbol,Num,Quote,Hex,Com1,Paren,Com2,Com2x);
  IDstr     = string[127];   { Symbolic name string }
  ErrStr    = string[79];    { error message string }
  Word      = record         { sort record }
                SortKey: string[C1];
                RefLine: integer;
              end;

var
  SortRec:    Word;          { input/output sort record }
  InpFile:    text[4096];    { input file }
  InpName:    IDstr;         { input file name }
  InpStr:     string[255];   { current input string }
  InpPtr:     integer;       { current input character ptr }
  InpChar:    char;          { current input character }
  Scan:       State;         { current input "word" type }
  ID:         IDstr;         { current input symbolic name }
  OutpFile:   text[4096];    { output listing file }
  OutpName:   IDstr;         { output listing file name }
  Title:      string[4];     { listing type: LIST or XREF }
  Date:       DateTimeResult;{ system date }
  Time:       DateTimeResult;{ system time }
  LineNo:     integer;       { current line number }
  PageNo:     integer;       { current page number }
  SortResult: integer;       { sort return-code }

procedure Abort(Msg: ErrStr);
  var
    MsDosRegs: record
                 AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags: integer;
               end;
  begin
    with MsDosRegs do begin
      AX := $4000;
      BX := 2;
      CX := ord(Msg[0]);
      DS := seg(Msg[1]);
      DX := ofs(Msg[1]);
      MsDos(MsDosRegs);
    end;
    sound(1000);
    delay(500);
    nosound;
    delay(1500);
    halt;
  end {Abort};

procedure Initialize;
  begin
    Date := SysDate;
    Time := SysTime;
    if paramcount < 1 then Abort('Input file name is missing');
    InpName := paramstr(1);
    assign(InpFile,InpName);
{$I-}
    reset(InpFile);
{$I+}
    if ioresult <> 0 then Abort('Input file does not exist');
    if paramcount < 2 then OutpName := 'LST:'
                      else OutpName := paramstr(2);
    assign(OutpFile,OutpName);
{$I-}
    rewrite(OutpFile);
{$I+}
    if ioresult <> 0 then Abort('Output listing file open error');
    if InpName[2] = ':' then delete(InpName,1,2);
    while pos('\',InpName) <> 0 do delete(InpName,1,1);
  end {Initialize};

procedure NewPage;
  begin
    PageNo := PageNo+1;
    writeln(OutpFile,FF,Title,': ',InpName,
            Date:10,Time:10,'PAGE ':35,PageNo);
    writeln(OutpFile);
  end {NewPage};

function UpStr(var Str): IDstr;
  var
    i : integer;
    s: IDstr absolute Str;
  begin
    UpStr[0] := s[0];
    for i := 1 to length(s) do UpStr[i] := upcase(s[i]);
  end {UpStr};

procedure Inp;
  function NewState: State;
    begin
      case upcase(InpChar) of
        ' '         : NewState := Other;
        'A'..'Z','_': NewState := Symbol;
        '0'..'9'    : NewState := Num;
        ''''        : NewState := Quote;
        '$'         : NewState := Hex;
        '{'         : NewState := Com1;
        '('         : NewState := Paren;
        else          NewState := Other;
      end;
    end {NewState};
  procedure writeID;
    function ReservedWord: boolean;
      const
        Wordlist: array[1..44] of string[9] =
          ('ABSOLUTE','AND','ARRAY','BEGIN','CASE','CONST','DIV','DO',
           'DOWNTO','ELSE','END','EXTERNAL','FILE','FOR','FORWARD',
           'FUNCTION','GOTO','IF','IN','INLINE','LABEL','MOD','NIL',
           'NOT','OF','OR','OVERLAY','PACKED','PROCEDURE','PROGRAM',
           'RECORD','REPEAT','SET','SHL','SHR','STRING','THEN','TO',
           'TYPE','UNTIL','VAR','WHILE','WITH','XOR');
      var
        i, j, k: integer;
        UpID: IDstr;
      begin
        UpID := UpStr(ID);
        i := 1;
        j := 44;
        repeat
          k := (i+j) div 2;
          if UpID > Wordlist[k] then i := k+1
                                else j := k;
        until i = j;
        ReservedWord := (UpID = Wordlist[i]);
      end {ReservedWord};
    begin
      if not ReservedWord then begin
        with SortRec do begin
          SortKey := ID;
          RefLine := LineNo;
        end;
        SortRelease(SortRec);
      end;
      ID[0] := NUL;
    end {writeID};
  begin
    LineNo := 0;
    PageNo := 0;
    Title := 'LIST';
    Scan := Other;
    while not eof(InpFile) do begin
      readln(InpFile,InpStr);
      if (LineNo mod 60) = 0 then NewPage;
      LineNo := LineNo+1;
      writeln(OutpFile,LineNo:C3,' ',InpStr);
      for InpPtr := 1 to length(InpStr) do begin
        InpChar := InpStr[InpPtr];
        case Scan of
          Other:  begin
                    Scan := NewState;
                    if Scan = Symbol then ID := InpChar;
                  end;
          Symbol: begin
                    Scan := NewState;
                    case Scan of
                      Symbol,Num: begin
                                    ID := ID + InpChar;
                                    Scan := Symbol;
                                  end;
                      else        writeID;
                    end;
                  end;
          Num:    if upcase(InpChar) = 'E' then
                    Scan := Other
                  else
                    Scan := NewState;
          Quote:  if InpChar = '''' then Scan := Other;
          Hex:    if not (upcase(InpChar) in['0'..'9','A'..'F']) then
                    Scan := NewState;
          Com1:   if InpChar = '}' then Scan := Other;
          Paren:  if InpChar = '*' then
                    Scan := Com2
                  else begin
                    Scan := NewState;
                    if Scan = Symbol then ID := InpChar;
                  end;
          Com2:   if InpChar = '*' then Scan := Com2x;
          Com2x:  case InpChar of
                    ')': Scan := Other;
                    '*': Scan := Com2x;
                    else Scan := Com2;
                  end;
        end;
      end;
      case Scan of
        Symbol:     begin
                      writeID;
                      Scan := Other;
                    end;
        Com2x:      Scan := Com2;
        Com1, Com2: ;
        else        Scan := Other;
      end;
    end;
    flush(OutpFile);
  end {Inp};

function Less;
  var
    SortRec1: Word absolute X;
    SortRec2: Word absolute Y;
    k1, k2: IDstr;
  begin
    k1 := UpStr(SortRec1.SortKey);
    k2 := UpStr(SortRec2.SortKey);
    if k1 = k2 then
      Less := SortRec1.RefLine < SortRec2.RefLine
    else
      Less := k1 < k2;
  end {Less};

procedure Outp;
  var
    l: integer;
  begin
    LineNo := 0;
    PageNo := 0;
    Title := 'XREF';
    l := 0;
    ID[0] := NUL;
    while not SortEOS do begin
      SortReturn(SortRec);
      with SortRec do begin
        if length(SortKey) < C1 then begin
          SortKey := SortKey + ' ';
          while length(SortKey) < C1 do SortKey := SortKey + '.';
        end;
        if UpStr(SortKey) <> ID then begin
          if l <> 0 then begin
            writeln(OutpFile);
            LineNo := LineNo+1;
            l := 0;
          end;
          if (LineNo mod 60) = 0 then NewPage;
          write(OutpFile,SortKey,' ');
          ID := UpStr(SortKey);
        end;
        if l = C2 then begin
          writeln(OutpFile);
          LineNo := LineNo+1;
          if (LineNo mod 60) = 0 then NewPage;
          write(OutpFile,' ':C1+1);
          l := 0;
        end ;
        l := l+1;
        write(OutpFile,RefLine:C3);
      end;
    end;
    writeln(OutpFile);
  end {Outp};

procedure Terminate;
  begin
    write(OutpFile,FF);
    close(InpFile);
    close(OutpFile);
    case SortResult of
      3:  Abort('Insufficient memory for sort');
      8:  Abort('Internal sort error');
      9:  Abort('Too many records for sort');
      10: Abort('Disk error or disk full during sort');
      11: Abort('Read error during sort');
      12: Abort('File creation error during sort');
    end;
  end {Terminate};

begin
  Initialize;
  SortResult := TurboSort(sizeof(SortRec));
  Terminate;
end.