Chip 1998 November/Chip_1998-11_cd.bin/zkuste/pascal/refer/PASCRF22.ZIP/PASCREF.PAS

Pascal/Delphi Source File | 1996-12-26 | 18KB | 638 lines

{ PASCREF.PAS : Pascal Cross-Reference generator

  Title   : PASCREF
  Language: Borland Pascal v4.0 through 7.0, DOS real or protected mode
  Version : 2.2
  Date    : Dec 26,1996
  Author  : J R Ferguson
  Usage   : refer procedure Help
  Download: http://www.xs4all.nl/~ferguson
  E-mail  : [e-mail]

This program and its source may be used and copied freely without charge,
but  only  for non-commercial purposes. The author is not responsible for
any damage or loss of data that may be caused by using it.

To compile this source file, you wil need  some  units  from  the  JRFPAS
Pascal  routine  library by the same author, which can be downloaded from
the Internet address mentioned above.
}

{$V-}
{$R+}

{$UNDEF OUTBUFHEAP}   { UNDEF to work around a BP 7.0 bug resulting in
                        erroneous file output }

program PASCREF;
Uses DefLib, ArgLib, StpLib, StfLib, ChrLib, TimLib, CvtLib;

const
  PROGIDN   = 'PASCREF';
  PROGVERS  = 'v2.2';
  { Defaults: }
  DFLCASE   = false;   { Case sensitive parsing }
  DFLLINE   = true ;   { Line number references }
  DFLOCNT   = false;   { Occurrence counts }
  DFLPAGE   = true ;   { Page formatting }
  DFLRESW   = false;   { Reserved words }
  DFLSTDI   = false;   { Standard identifiers }
  DFLINPT   = '.PAS';  { Input file type }
  DFLOUTT   = '.CRF';  { Output file type }

  MAXFNAME  = 79; { Max filename length (including drive and path) }
  CNTLEN    =  4; { Length of occurrence count field }
  REFLEN    =  4; { Length of line number references }
  MINIDN    = 20; { Minimum print width of identifier field }
  MAXIDN    = 32; { Max nr of identifier characters recognized }

  LINLEN    = 80; { Characters per line (including left and right margins }
  PAGLEN    = 66; { Lines per page Page (including top and bottom margins }
  LEFMAR    =  2; { Left margin for page formatted output }
  RIGMAR    =  2; { Right margin for page formatted output }
  TOPMAR    =  2; { Page top line number for page formatted output }
  BOTMAR    =  6; { Page bottom line number for page formatted output }

  INPBUFSIZ = 4096;
  OUTBUFSIZ = 4096;

  { Error codes and messages: }
  ERROK     = 0;
  ERRARG    = 1;
  ERRINP    = 2;
  ERROUT    = 3;

  ERRMSG    : array[ERRARG..ERROUT] of StpTyp =
 ('',
  'File not found : ',
  'Can''t open output : '
 );

type
  InpBufTyp = array[1..INPBUFSIZ] of char;   InpBufPtr = ^InpBufTyp;
  OutBufTyp = array[1..OUTBUFSIZ] of char;   OutBufPtr = ^OutBufTyp;

  IdnStp    = string[MAXIDN];
  IdnInd    = 0..MAXIDN;

  LstElm    = record
                num: integer;
                def: boolean;  { << not implemented >> : line number where defined }
              end;
  LstPtr    = ^LstEntry;
  LstEntry  = record
                inh: LstElm;
                nxt: LstPtr;
              end;
  LstTyp    = record           { Linked List }
                head : LstPtr;
                tail : LstPtr;
              end;

  TblElm    = record
                idn: IdnStp;
                cnt: integer;
                ref: LstTyp;
              end;
  TblPtr    = ^TblEntry;       { Binary Tree }
  TblEntry  = record
                inh: TblElm;
                prv,
                nxt: TblPtr;
              end;

var
  InpFname,
  InpFnameShort,
  OutFname  : StpTyp;
  InpFvar,
  OutFvar   : Text;
  InpBuf    : InpBufPtr;
{$IFDEF OUTBUFHEAP}
  OutBuf    : OutBufPtr;
{$ELSE}
  OutBuf    : OutBufTyp;
{$ENDIF}
  InpOpen,
  OutOpen   : boolean;
  ErrCod    : integer;
  CurArg    : StpTyp;
  OptCase,
  OptLine,
  OptOcnt,
  OptPage,
  OptResW,
  OptStdI   : boolean;
  PagCnt    : integer;   { Current page }
  LinCnt,                { Current print line }
  MinLin,                { First print line on page }
  MaxLin    : integer;   { Last print line on page }
  ColCnt,                { Current print column }
  MinCol,                { First print column on line }
  MaxCol,                { Last print column on line }
  CntCol,                { Start column for occurrence count }
  WrnCol,
  IdnCol,                { Start column for identifier }
  RefCol    : integer;   { Start column for line number references }
  TimeStamp : StpTyp;

  ResWords1,
  ResWords2,
  StdIdents : StpTyp;
  CrfTbl    : TblPtr;
  CurLine   : StpTyp;
  CurIdn    : IdnStp;
  PrvIdn    : IdnStp;
  CurNum    : integer;
  CurDef    : boolean;
  CurPos    : integer;
  CurChr    : char;
  SaveChr   : char;
  SaveSta   : boolean;
  EolnSta   : boolean;

{--- General routines ---}

procedure Help;
begin
  WriteLn('usage   : PASCREF inpfile [outfile] [/option[...] [...]]');
  WriteLn('defaults: inpfile type = .PAS');
  WriteLn('          outfile name = inpfile name');
  WriteLn('                  type = .CRF');
  WriteLn('');
  WriteLn('options : s[+] or s-, where switch s is one of the following:');
  WriteLn('');
  WriteLn('   switch  default  meaning');
  WriteLn('   ------  -------  ---------------------------------');
  WriteLn('     C        -     case sensitive identifier-parsing');
  WriteLn('     L        +     line reference numbers');
  WriteLn('     O        -     occurrence count');
  WriteLn('     P        +     page formattting');
  WriteLn('     R        -     include reserved words');
  WriteLn('     S        -     include standard identifiers');
  WriteLn('');
  WriteLn('remarks : - No recognition of scope');
  WriteLn('          - No recognition of declaration vs. reference');
  WriteLn('          - With the /C option a ">" warns for an identifier');
  WriteLn('            matching the previous one in uppercase');
end;

procedure GetTimeStamp;
var date: TimDateRec; time: TimTimeRec;
  function ItoS(num,len: integer): StpTyp;
  var tmp: StpTyp;
  begin ItoABl(num,tmp,10,len); ItoS:= tmp; end;
begin { GetTimeStamp }
  TimGetDate(date); TimGetTime(time);
  with date,time do begin
    TimeStamp:= ItoS(day,2)  + '-' + ItoS(month,2)   + '-' + ItoS(year,4)
        + ' ' + ItoS(hours,2) + ':' + ItoS(minutes,2);
  end;
end; { GetTimeStamp }

{--- Command Line parsing routines ---}

procedure ReadSwitch(var option: boolean);
begin
  case StpcRet(CurArg,1) of
   '-' : begin option:= false; StpDel(CurArg,1,1); end;
   '+' : begin option:= true ; StpDel(CurArg,1,1); end;
   else  option:= true;
  end;
end;

procedure ReadOpt;
begin
  StpDel(CurArg,1,1); if StpEmpty(CurArg) then ErrCod:= ERRARG;
  while (ErrCod = ERROK) and not StpEmpty(CurArg) do
  case StpcGet(CurArg) of
    'C' : ReadSwitch(OptCase);
    'L' : ReadSwitch(OptLine);
    'O' : ReadSwitch(OptOcnt);
    'P' : ReadSwitch(OptPage);
    'R' : ReadSwitch(OptResW);
    'S' : ReadSwitch(OptStdI);
    else ErrCod:= ERRARG;
  end;
end;

procedure ReadArgs;
var i   : ArgInd;
    p   : StpInd;
begin
  StpCreate(InpFname); StpCreate(OutFname);
  GetArgs;
  i:= 0;
  while (i < ArgC) and (ErrCod = ERROK) do begin
    Inc(i); StpCpy(CurArg,ArgV[i]); StpUpp(CurArg);
    if      StpcRet(CurArg,1) = '/' then ReadOpt
    else if StpEmpty(InpFname)      then StpNCpy(InpFname,CurArg,MAXFNAME)
    else if StpEmpty(OutFname)      then StpNCpy(OutFname,CurArg,MAXFNAME)
    else ErrCod:= ERRARG;
  end;
  if StpEmpty(InpFname) then ErrCod:= ERRARG
  else begin
    if StpcPos(InpFname,'.')=0 then StpCat(InpFname,DFLINPT);
    StpCpy(InpFnameShort,InpFname);
    StpDel(InpFnameShort,1,StpcRPos(InpFnameShort,'\'));
    if StpEmpty(OutFname) then StpBefore(OutFname,InpFnameShort,'.');
    if StpcPos(OutFname,'.')=0 then StpCat(OutFname,DFLOUTT);
  end;
end;

{--- I/O routines ---}

procedure OpenInp;
begin
  Assign(InpFvar,InpFname); new(InpBuf); SetTextBuf(InpFvar,InpBuf^);
  {$I-} reset(InpFvar) {$I+};
  if IOresult <> 0 then ErrCod:= ERRINP else InpOpen:= true;
end;

procedure CloseInp;
begin if InpOpen then begin
  Close(InpFvar); dispose(InpBuf); InpOpen:= false;
end end;

procedure OpenOut;
begin
  Assign(OutFvar,OutFname);
{$IFDEF OUTBUFHEAP}
  new(OutBuf); SetTextBuf(OutFvar,OutBuf^);
{$ELSE}
  SetTextBuf(OutFvar,OutBuf);
{$ENDIF}
  {$I-} rewrite(OutFvar) {$I+};
  if IOresult <> 0 then ErrCod:= ERROUT else OutOpen:= true;
end;

procedure CloseOut;
begin if OutOpen then begin
  Close(OutFvar);
{$IFDEF OUTBUFHEAP}
  dispose(OutBuf);
{$ENDIF}
  OutOpen:= false;
end end;

procedure PushChr;
begin SaveSta:= true; SaveChr:= CurChr; end;

function PopChr: boolean;
begin
  if SaveSta then begin
    CurChr:= SaveChr; SaveSta:= false;
    PopChr:= true;
  end
  else PopChr:= false;
end;

function NxtChr: char;
begin
  if not PopChr then begin
    if EolnSta then begin
      if eof(InpFvar) then StpCreate(CurLine) else ReadLn(InpFvar,CurLine);
      CurNum:= CurNum + 1; CurPos:= 0; EolnSta:= false;
    end;
    if CurPos < StpLen(CurLine) then begin
      CurPos:= CurPos + 1;
      CurChr:= StpcRet(CurLine,CurPos);
    end
    else begin
      EolnSta:= true;
      CurChr := ' ';
    end;
  end;
  if not OptCase then CurChr:= ToUpper(CurChr);
  NxtChr:= CurChr;
end;

procedure GetChr;
var Skipping: boolean;
begin
  case NxtChr of
    '''': begin
            Skipping:= true;
            while Skipping do begin
              if NxtChr = '''' then
                if NxtChr <> '''' then begin PushChr; Skipping:= false end;
            end;
            CurChr:= ' ';
          end;
    '{' : begin
            repeat CurChr:= NxtChr until CurChr = '}';
            CurChr:= ' ';
          end;
    '(' : if NxtChr='*' then begin
            Skipping:= true;
            while Skipping do
              if NxtChr = '*' then Skipping:= NxtChr <> ')';
            CurChr:= ' ';
          end
          else begin
            PushChr;
            CurChr:= '(';
          end;
  end;
end;

procedure GetIdn;
begin
  while not (CurChr in ['A'..'Z','a'..'z','_']) and not eof(InpFvar) do
    GetChr;
  StpCreate(CurIdn);
  while CurChr in ['A'..'Z','a'..'z','_','0'..'9'] do begin
    if StpLen(CurIdn) < MAXIDN then StpcCat(CurIdn,CurChr);
    GetChr;
  end;
  CurDef:= false;   { << not yet implemented >> }
end;

procedure NewLine; forward;

procedure WriteChr(c: char);
begin Write(OutFvar,c); Inc(ColCnt); end;

procedure WriteStp(str: StpTyp);
begin Write(OutFvar,str); Inc(ColCnt,StpLen(str)); end;

procedure WriteInt(value: integer; width: integer);
begin Write(OutFvar,value:width); Inc(ColCnt,width); end;

procedure SkipToCol(col: integer);
begin
  if ColCnt > col then NewLine;
  Write(OutFvar,'':col-ColCnt); ColCnt:= col;
end;

procedure SkipToLin(lin: integer);
begin
  while LinCnt < lin do begin WriteLn(OutFvar); Inc(LinCnt); end;
  ColCnt:=0; SkipToCol(MinCol);
end;

procedure PageHeader;
begin
  if PagCnt > 1 then Write(OutFvar,chr(AsciiFF));
  SkipToLin(MinLin);
  WriteStp('Pascal Cross-Reference   '+InpFnameShort+'   '+TimeStamp);
  SkipToCol(MaxCol - 8); WriteStp('Page '); WriteInt(PagCnt,1); NewLine;
  if OptCase then WriteStp('Case sensitive.  ');
  if OptResW then WriteStp('Reserved words included.  ');
  if OptStdI then WriteStp('Standard identifiers included.');
  NewLine;
  NewLine;
  NewLine;
  if OptOcnt then begin SkipToCol(CntCol); WriteStp(' Cnt'); end;
                        SkipToCol(IdnCol); WriteStp('Identifier');
  if OptLine then begin SkipToCol(RefCol); WriteStp('Referenced'); end;
  NewLine;
  if OptOcnt then begin SkipToCol(CntCol); WriteStp(' ---'); end;
                        SkipToCol(IdnCol); WriteStp('----------');
  if OptLine then begin SkipToCol(RefCol); WriteStp('----------'); end;
  NewLine;
end;

procedure NewPage;
begin Inc(PagCnt); LinCnt:= 0; ColCnt:= 0; if OptPage then PageHeader; end;

procedure NewLine;
begin
  WriteLn(OutFvar); Inc(LinCnt); ColCnt:= 0;
  if LinCnt > MaxLin then NewPage;
  SkipToCol(MinCol);
end;

{--- Reference list handling routines ---}

procedure LstCreate(var ref: LstTyp);
begin with ref do begin head:= nil; tail:= nil; end end;

procedure LstDispose(var ref: LstTyp);
var p: LstPtr;
begin with ref do begin
  while head <> nil do begin
    p:= head^.nxt;
    dispose(head);
    head:= p;
  end;
  tail:= nil;
end end;

procedure LstAppend(var ref: LstTyp; number: integer; defined: boolean);
var p: LstPtr;
begin
  new(p);
  with p^ do begin
    inh.num:= number;
    inh.def:= defined;
    nxt    := nil;
  end;
  with ref do begin
    if head=nil then head:= p else tail^.nxt:= p;
    tail:= p;
  end;
end;

procedure LstWriteElm(var elm: LstElm);
begin
  if ColCnt + REFLEN + 2 > MaxCol then begin NewLine; SkipToCol(RefCol) end;
  if elm.def then WriteChr('*') else WriteChr(' ');
  WriteInt(elm.num,REFLEN);
  WriteChr(' ');
end;

procedure LstWrite(var ref: LstTyp);
var p: LstPtr;
begin
  p:= ref.head;
  while p<>nil do begin
    LstWriteElm(p^.inh);
    p:= p^.nxt;
  end;
end;

{--- Table handling routines ---}

function TblOrder(idn1,idn2: IdnStp): integer;
{ result < 0 if idn1 < idn2, 0 if idn1 = idn2, > 0 if idn1 > idn2 }
var order: integer;
begin
  if OptCase then begin     { alphabet first, then upper/lower case }
    order:= StpUppCmp(idn1,idn2);
    if order = 0 then order:= StpCmp(idn1,idn2);
    TblOrder:= order;
  end
  else TblOrder:= StpCmp(idn1,idn2);
end;

procedure TblCreate(var tbl: TblPtr);
begin tbl:= nil end;

procedure TblDispose(var tbl: TblPtr);
begin if tbl<>nil then begin
  with tbl^ do begin
    if OptLine then LstDispose(inh.ref);
    TblDispose(prv);
    TblDispose(nxt);
  end;
  dispose(tbl);
end; end;

procedure TblInsert(var tbl    : TblPtr;
                    var ident  : IdnStp;
                        number : integer;
                        defined: boolean);
var order: integer;
  procedure TblIns(var p: TblPtr);
  begin
    if p=nil then begin
      new(p);
      with p^ do begin
        with inh do begin
          idn:= ident;
          cnt:= 1;
          if OptLine then begin
            LstCreate(ref);
            LstAppend(ref, number, defined);
          end;
        end;
        prv:= nil;
        nxt:= nil;
      end;
    end
    else with p^ do begin
      order:= TblOrder(ident,inh.idn);
      if        order < 0 then   TblIns(prv)
      else   if order > 0 then   TblIns(nxt)
      else { if order = 0 then } with inh do begin
        Inc(cnt);
    if OptLine then LstAppend(ref, number, defined);
      end;
    end;
  end;
begin { TblInsert }
  TblIns(tbl);
end;

procedure TblWriteElm(var elm: TblElm);
begin with elm do begin
  if OptOcnt then begin
    SkipToCol(CntCol);
    WriteInt(cnt,CNTLEN);
  end;
  if OptCase then begin
    SkipToCol(WrnCol);
    if StpUppCmp(idn,PrvIdn) = 0 then WriteChr('>') else WriteChr(' ');
    PrvIdn:= idn;
  end;
  SkipToCol(IdnCol); WriteStp(idn);
  if OptLine then begin SkipToCol(RefCol); LstWrite(ref); end;
end end;

procedure TblWrite(var tbl: TblPtr);
begin if tbl<>nil then with tbl^ do begin
  TblWrite(prv);
  TblWriteElm(inh);
  TblWrite(nxt);
end end;

{--- Main Line ---}

procedure ReadTable;
  function Included(var wrd: IdnStp): boolean;
  var tmp: StpTyp;
  begin
    tmp:= ' ' + StfUpp(wrd) + ' ';
    Included:=
         ( OptStdI or ( Pos(tmp,StdIdents)                      = 0 ) )
     and ( OptResW or ( Pos(tmp,ResWords1) + Pos(tmp,ResWords2) = 0 ) )
  end;
begin { ReadTable }
  OpenInp;
  if ErrCod = ERROK then begin
    TblCreate(CrfTbl);
    CurNum := 0; EolnSta:= true; SaveSta:= false;
    GetChr;
    while not eof(InpFvar) do begin
      GetIdn;
      if Included(CurIdn) then TblInsert(CrfTbl,CurIdn,CurNum,CurDef);
    end;
    CloseInp;
  end;
end;

procedure WriteTable;
begin
  OpenOut;
  if ErrCod = ERROK then begin
    StpCreate(PrvIdn); PagCnt:= 0;
    NewPage;
    TblWrite(CrfTbl);
    TblDispose(CrfTbl);
    CloseOut;
  end;
end;

procedure MainInit;
begin
  ResWords1:=' ABSOLUTE AND ARRAY ASM BEGIN CASE CONST CONSTRUCTOR DESTRUCTOR '
           + 'DIV DO DOWNTO ELSE END EXPORTS EXTERNAL FILE FOR FORWARD FUNCTIO'
           + 'N GOTO IF IMPLEMENTATION IN INHERITED INLINE INTERFACE INTERRUPT'
           + ' LABEL LIBRARY MOD NIL NOT OBJECT OF OR PACKED PROCEDURE PROGRAM';
  ResWords2:=' RECORD REPEAT SET SHL SHR STRING THEN TO TYPE UNIT UNTIL USES V'
           + 'AR WHILE WITH XOR ';
  StdIdents:=' ABS ARCTAN BOOLEAN CHAR CHR COS DISPOSE EOF EOLN EXP FALSE GET '
           + 'INPUT INTEGER LN MAXINT NEW ODD ORD OUTPUT PACK PAGE PRED PUT RE'
           + 'AD READLN REAL RESET REWRITE ROUND SIN SQR SQRT SUCC TEXT TRUE T'
           + 'RUNC UNPACK WRITE WRITELN ';
  ErrCod := ERROK;
  InpOpen:= false; OutOpen:= false;
  OptCase:= DFLCASE; OptLine:= DFLLINE; OptOcnt:= DFLOCNT;
  OptPage:= DFLPAGE; OptResW:= DFLRESW; OptStdI:= DFLSTDI;
  ReadArgs;
  if ErrCod=ERROK then begin
    MinLin:= 0; MaxLin:= PAGLEN;
    MinCol:= 0; MaxCol:= LINLEN;
    if OptPage then begin
      Inc(MinLin,TOPMAR); Dec(MaxLin,BOTMAR);
      Inc(MinCol,LEFMAR); Dec(MaxCol,RIGMAR);
    end;
    CntCol:= MinCol;
    WrnCol:= CntCol; if OptOcnt then Inc(WrnCol,CNTLEN+1);
    IdnCol:= WrnCol; if OptCase then Inc(IdnCol,1);
    RefCol:= IdnCol + MINIDN + 1;
  end;
end;


procedure MainExit;
begin
  if ErrCod <> ERROK then begin
    Write(ERRMSG[ErrCod]);
    case ErrCod of
      ERRARG : Help;
      ERRINP : WriteLn(InpFname);
      ERROUT : WriteLn(OutFname);
    end;
  end;
end;


begin { Main program }
  WriteLn(PROGIDN+' '+PROGVERS+' : Pascal Cross-Reference generator');
  MainInit;
  if ErrCod = ERROK then begin
    Write(InpFname,' ==> ',OutFname);
    GetTimeStamp;
    Write('  Reading ');
    ReadTable;
    if ErrCod = ERROK then begin
      Write(', Writing ');
      WriteTable;
      WriteLn(', Done.');
    end;
  end;
  MainExit;
end.