MODULE RefDef;
(*
Title   : RefDef.MOD
Author  : Kim Moser
System  : JPI's TopSpeed Modula-2 with PMI's Repertoire 1.5
Descrip : Finds unreferenced identifiers and multiply defined global
          identifiers within a module and generates a .LST file
          compatible with Logitech's MOD editor.

Usage   : REFDEF [<module_name>]

*)

FROM SYSTEM IMPORT SIZE, ADR;

IMPORT InitJPI;
FROM EnvironUtils IMPORT ParsedParam;
FROM ErrorManager IMPORT StraightToDOS, WARN;
FROM FileIO IMPORT CreateFile, CloseHandle;
FROM GenLists IMPORT DisposeList, ElmtNow, GenList, GetChildList, GetElmt,
     GetElmtAdr, Initialized, ListCode, ListDelete, ListInsert,
     ListInsertAdr, ListLength, ListReplace, NewList, NilList, ScanList,
     SortList, StrCode;
FROM KbdInput IMPORT CAPkey, KeyHit, YorN;
FROM ListUtils IMPORT CheckLength, GetStr, TextFileToList, TextListToFile;
FROM LowLevel IMPORT Fill;
FROM M2Strings IMPORT Assign, CompareStr, Copy, Delete, Insert, Length;
FROM Numbers IMPORT Min;
FROM Parser IMPORT delimiters, GetNextWord, LastIndex, TheLine;
FROM PosUtils IMPORT Equal, Pos, Positn, Present;
FROM StrConv IMPORT CardinalToStr;
FROM StrEdit IMPORT Append, AssignStr, CAPstr, CrunchBlanks, ReplaceStr,
     SetLength;
FROM StringIO IMPORT inp, outp, PrintMessage, ReadStr, WriteEol, WriteStr,
  ErrorMessage;
FROM SYSTEM IMPORT ADDRESS, ADR;

TYPE
  CharSet = SET OF CHAR;

CONST
  MaxWordLen = 80;
  IdentifierCode = 525;  (* Arbitrary *)
  ErrorCode = 5221;  (* Arbitrary *)
  DigitSet = CharSet{ '0'..'9' };

TYPE
  WordType = ARRAY [0..MaxWordLen] OF CHAR;

  ErrType =  ( NotDefined, AlreadyDefined );
  FromType = ( KeyWord, Import, Const, Type, Var, Procedure, NoFromType );

  ErrorRec = RECORD
    name: WordType;
    srcX, srcY: CARDINAL;
    CASE err: ErrType OF
      AlreadyDefined:
        from: FromType;
    END;
  END;

  IdentifierType = RECORD
    name: WordType;
    count: CARDINAL;
    CASE from: FromType OF
      KeyWord:
    ELSE
      (* KeyWords are not from the source file *)
      srcX, srcY: CARDINAL;
        (* Location defined/declared/imported in source code *)
    END;
  END;

VAR
  ProcedureLevel: CARDINAL;
  Spaces255: ARRAY [0..255] OF CHAR;
  fname1, errFname, keyWordFname, ModuleName, CurrentWord, LastWord: WordType;
  Terminator: CHAR;
  LineCnt, ColCnt, OldLineCnt, OldColCnt: CARDINAL;
  TextList, IdentifierList, ErrorList: GenList;


PROCEDURE LastWordWas( TheStr: ARRAY OF CHAR ): BOOLEAN;
  BEGIN
    RETURN CompareStr( TheStr, LastWord ) = 0;
  END LastWordWas;

PROCEDURE CurrentWordIs( TheStr: ARRAY OF CHAR ): BOOLEAN;
  BEGIN
    RETURN CompareStr( TheStr, CurrentWord ) = 0;
  END CurrentWordIs;

PROCEDURE NextWord();
  BEGIN
    Assign( CurrentWord, LastWord );
    GetNextWord( TextList, LineCnt, ColCnt, CurrentWord, Terminator );
  END NextWord;

PROCEDURE AddError( name: ARRAY OF CHAR; err: ErrType; from: FromType );
VAR
  e: ErrorRec;
BEGIN
  IF NOT (name[0] IN DigitSet) THEN
    AssignStr( name, e.name );
    e.err := err;
    e.from := from;
    IF (from <> KeyWord) THEN
      e.srcX := ColCnt;
      e.srcY := LineCnt;
    END;
    ListInsert( e, ErrorCode, ErrorList, 65535 );
  END;
END AddError;

PROCEDURE FetchIdentifierNumbered( n: CARDINAL; VAR id: IdentifierType );
(* Attempts to get identifier number 'n' from identifier list.  Assumes
   ListLength of identifier list <= 'n'. *)
VAR typ: CARDINAL;
BEGIN
  GetElmt( IdentifierList, n, id, typ );
  IF (typ <> IdentifierCode) THEN
    WARN( 'Element from identifiers list is not of type IdentifierCode.' );
  END;
END FetchIdentifierNumbered;

PROCEDURE FetchIdentifier( name: ARRAY OF CHAR; VAR id: IdentifierType ): CARDINAL;
(* Attemps to get identifier 'name' from identifier list; if successful,
   returns its record in 'id' and returns the spot it held in the list;
   otherwise returns 0. *)
VAR
  i, len, typ: CARDINAL;
BEGIN
  len := ListLength( IdentifierList );
  IF len > 0 THEN
    FOR i := 1 TO len DO
      FetchIdentifierNumbered( i, id );
      IF Equal( id.name, name ) THEN
        RETURN i;
      END;
    END;
  END;
  RETURN 0;
END FetchIdentifier;

PROCEDURE AddIdentifier( name: ARRAY OF CHAR; f: FromType );
(* If identifier 'name' is not already in the list of identifiers, then adds
   it; else adds an element to the Errors list *)
  VAR
    id: IdentifierType;
  BEGIN
    (* Don't bother adding literal constants: *)
    IF NOT (name[0] IN DigitSet) THEN
      IF FetchIdentifier( name, id ) > 0 THEN
        (* Identifier already existed, so flag an error *)
        AddError( id.name, AlreadyDefined, id.from );
      ELSE
        (* Identifier didn't exist, so add it *)
        AssignStr( name, id.name );
        id.count := 0;
        id.from := f;
        IF f <> KeyWord THEN
          id.srcX := ColCnt;
          id.srcY := LineCnt;
        END;
        ListInsert( id, IdentifierCode, IdentifierList, 65535 );
      END;
    END;
  END AddIdentifier;

PROCEDURE MarkIdentifierUsed( name: ARRAY OF CHAR );
VAR
  id: IdentifierType;
  p: CARDINAL;
BEGIN
  p := FetchIdentifier( name, id );
  IF p > 0 THEN
    INC( id.count );
    ListReplace( id, IdentifierCode, IdentifierList, p );
  ELSE
    (* Identifier didn't exist, so flag an error: *)
    AddError( name, NotDefined, NoFromType );
  END;
END MarkIdentifierUsed;

PROCEDURE GetModuleName();
BEGIN
  REPEAT
    NextWord();
  UNTIL LastWordWas( 'MODULE' );
  AssignStr( CurrentWord, ModuleName );
  WriteStr( outp, 'Module: ' );
  WriteEol( outp, ModuleName );
END GetModuleName;

PROCEDURE DoImports();

  PROCEDURE EndOfImports(): BOOLEAN;
    BEGIN
      RETURN CurrentWordIs( 'CONST' )
        OR CurrentWordIs( 'TYPE' )
        OR CurrentWordIs( 'VAR' )
        OR CurrentWordIs( 'EXPORT' )
        OR CurrentWordIs( 'PROCEDURE' )
        OR CurrentWordIs( 'BEGIN' )
        OR (LineCnt >= ListLength(TextList));
     END EndOfImports;

  PROCEDURE EndOfStatement(): BOOLEAN;
    BEGIN
      RETURN Equal( CurrentWord, 'FROM' ) OR
             Equal( CurrentWord, 'IMPORT' ) OR EndOfImports();
    END EndOfStatement;

  BEGIN  (* DoImports() *)
    WriteEol( outp, 'Doing imports' );
    (* Get to first import, if any: *)
    REPEAT
      NextWord();
      IF EndOfImports() THEN
        RETURN;  (* No imports found *)
      END;
    UNTIL EndOfStatement();

    (* CurrentWord == 'FROM' or 'IMPORT' *)
    REPEAT
      NextWord();  (* module_name *)
      IF LastWordWas( 'FROM' ) THEN
        NextWord();  (* get and ignore 'IMPORT' *)
        LOOP
          NextWord();  (* Get identifier being imported *)
          IF EndOfStatement() THEN
            (* No more imports from current module *)
            EXIT;
          ELSE
            AddIdentifier( CurrentWord, Import );
          END;
        END;
      ELSIF LastWordWas( 'IMPORT' ) THEN
        AddIdentifier( CurrentWord, Import );
        REPEAT
          NextWord();
        UNTIL EndOfStatement();
      ELSE
        WARN( 'Last word should have been "FROM" or "IMPORT"' );
      END;
    UNTIL EndOfImports();
  END DoImports;

(*
PROCEDURE SaveCoords();
BEGIN
  OldColCnt := ColCnt;
  OldLineCnt := LineCnt;
END SaveCoords;

PROCEDURE RestoreCoords();
BEGIN
  ColCnt := OldColCnt;
  LineCnt := OldLineCnt;
END RestoreCoords;
*)

PROCEDURE DoOtherIdentifiers();

  PROCEDURE EndOfGroup(): BOOLEAN;
    BEGIN
      RETURN CurrentWordIs( 'CONST' )
        OR CurrentWordIs( 'TYPE' )
        OR CurrentWordIs( 'VAR' )
        OR CurrentWordIs( 'EXPORT' )
        OR CurrentWordIs( 'PROCEDURE' )
        OR CurrentWordIs( 'BEGIN' )
        OR (LineCnt >= ListLength(TextList));
    END EndOfGroup;

  PROCEDURE DoProcedure();
    VAR
      ProcName: WordType;

    PROCEDURE WriteSpaces();
      VAR i: CARDINAL;
      BEGIN
        FOR i := 1 TO ProcedureLevel DO
          WriteStr( outp, '  ' );
        END;
      END WriteSpaces;

    PROCEDURE DoLocalConst();
    (* Just check if any imports are being referenced: *)
      VAR
        LastTerm: CHAR;
      BEGIN
        WriteSpaces();
        WriteEol( outp, 'Doing local CONSTants' );
        REPEAT
          LastTerm := Terminator;
          NextWord();
          IF (LastTerm = '=') THEN
            MarkIdentifierUsed( CurrentWord );
          END;
        UNTIL EndOfGroup();
      END DoLocalConst;

    PROCEDURE DoLocalType();
    (* Just check if any imports are being referenced: *)
      VAR
        LastTerm: CHAR;
      BEGIN
        WriteSpaces();
        WriteEol( outp, 'Doing local TYPEs' );
        REPEAT
          LastTerm := Terminator;
          NextWord();
          IF (LastTerm = '=') THEN
            MarkIdentifierUsed( CurrentWord );
          END;
        UNTIL EndOfGroup();
      END DoLocalType;

    PROCEDURE DoLocalVar();
    (* Just check if any imports are being referenced: *)
      VAR
        LastTerm: CHAR;
      BEGIN
        WriteSpaces();
        WriteEol( outp, 'Doing local VARs' );
        REPEAT
          LastTerm := Terminator;
          NextWord();
          IF (LastTerm = ':') THEN
            MarkIdentifierUsed( CurrentWord );
          END;
        UNTIL EndOfGroup();
      END DoLocalVar;

    BEGIN  (* DoProcedure *)
      INC( ProcedureLevel );
      NextWord();  (* Procedure name *)

      WriteSpaces();
      WriteStr( outp, 'Doing procedure ' );
      WriteEol( outp, CurrentWord );

      (* Only add procedures that are not {sub-}procedures: *)
      IF ProcedureLevel = 1 THEN
        AddIdentifier( CurrentWord, Procedure );
      END;

      AssignStr( CurrentWord, ProcName );  (* Remember it *)
      (* Skip to 'BEGIN', but watch for local
         procedures, consts, types, and vars: *)
      NextWord();
      REPEAT
        IF CurrentWordIs( 'PROCEDURE' ) THEN
          DoProcedure();  (* We're at a {sub-}subprocedure *)
        ELSIF CurrentWordIs( 'CONST' ) THEN
          (* Local CONSTants *)
          DoLocalConst();
        ELSIF CurrentWordIs( 'TYPE' ) THEN
          DoLocalType();
        ELSIF CurrentWordIs( 'VAR' ) THEN
          DoLocalVar();
        ELSE
          (* Only mark identifier as used if it is NOT
             a formal parameter NAME: *)
          IF (Terminator=';') OR (Terminator=')') THEN
            MarkIdentifierUsed( CurrentWord );
          END;
          NextWord();
        END;
      UNTIL CurrentWordIs( 'BEGIN' );
      LOOP  (* Do body of procedure: *)
        NextWord();
        WriteEol( outp, CurrentWord );
        IF LastWordWas( 'END' ) AND CurrentWordIs( ProcName ) THEN EXIT END;
        MarkIdentifierUsed( CurrentWord );  (* Mark it as used *)
      END;
      NextWord();  (* Setup *)

      IF ProcedureLevel = 0 THEN
        WARN( 'ProcedureLevel should not be zero; check structure of source file.' );
      END;
      DEC( ProcedureLevel );
    END DoProcedure;

  PROCEDURE DoConst();
  (* Add CONStants as identifiers, and mark as being used what they're
     being identified as: *)
    VAR
      LastTerm: CHAR;
    BEGIN
      WriteEol( outp, 'Doing main CONSTants' );
      REPEAT
        LastTerm := Terminator;
        NextWord();
        IF (Terminator = '=') THEN
          (* We just parsed a CONStant, so add it: *)
          AddIdentifier( CurrentWord, Const );
        ELSIF LastTerm = '=' THEN
        (* We just parsed what it is being equated with,
           so mark that as used: *)
          MarkIdentifierUsed( CurrentWord );
        END;
      UNTIL EndOfGroup();
    END DoConst;
  
  PROCEDURE DoType();
  (* Add TYPEs as identifiers, and mark as being used what they're
     being identified as: *)
    VAR
      LastTerm: CHAR;
    BEGIN
      WriteEol( outp, 'Doing main TYPEs' );
      REPEAT
        LastTerm := Terminator;
        NextWord();
        IF (Terminator = '=') THEN
          (* We just parsed a TYPE, so add it: *)
          AddIdentifier( CurrentWord, Type );
        ELSIF (LastTerm = '=') THEN
          (* We just parsed what it is being equated with,
             so mark that as used: *)
          MarkIdentifierUsed( CurrentWord );
        END;
      UNTIL EndOfGroup();
    END DoType;
  
  PROCEDURE DoVar();
  (* Add VARs as identifiers, and mark as being used what they're
     being identified as: *)
    VAR
      LastTerm: CHAR;
    BEGIN
      WriteEol( outp, 'Doing main VARs' );
      REPEAT
        LastTerm := Terminator;
        NextWord();
        IF (Terminator = ':') THEN
          (* We just parsed a VAR, so add it: *)
          AddIdentifier( CurrentWord, Var );
        ELSIF (LastTerm = ':') THEN
          (* We just parsed what it is being equated with,
             so mark that as used: *)
          MarkIdentifierUsed( CurrentWord );
        END;
      UNTIL EndOfGroup();
    END DoVar;
  
  PROCEDURE DoMain();
    BEGIN
      WriteEol( outp, 'Doing module body/initialization' );
      REPEAT
        NextWord();
        WriteEol( outp, CurrentWord );
        MarkIdentifierUsed( CurrentWord );
      UNTIL LastWordWas( 'END' ) AND CurrentWordIs( ModuleName );
    END DoMain;

  BEGIN  (* DoOtherIdentifiers() *)
    REPEAT
      IF CurrentWordIs( 'PROCEDURE' ) THEN
        DoProcedure();
      ELSIF CurrentWordIs( 'VAR' ) THEN
        DoVar();
      ELSIF CurrentWordIs( 'CONST' ) THEN
        DoConst();
      ELSIF CurrentWordIs( 'TYPE' ) THEN
        DoType();
      ELSIF CurrentWordIs( 'BEGIN' ) THEN
        DoMain();
      END;
    UNTIL Equal(LastWord, 'END' ) AND Equal(CurrentWord, ModuleName);
  END DoOtherIdentifiers;


PROCEDURE PrintIdentifiers();

  PROCEDURE OutIdentifier( id: IdentifierType );
  VAR s: WordType;
  BEGIN
    AssignStr( id.name, s );
    WHILE Length( s ) < 32 DO
      Append( s, ' ' );
    END;
    WriteStr( outp, s );
    CardinalToStr( id.count, 5, s );
    WriteEol( outp, s );
  END OutIdentifier;

  PROCEDURE PrintKeyWords();
  VAR
    typ, cnt, i: CARDINAL;
    id: IdentifierType;
    s: WordType;
  BEGIN
    cnt := ListLength( IdentifierList );
    IF cnt > 0 THEN
      WriteEol( outp, 'Keywords:' );
      FOR i := 1 TO cnt DO
        FetchIdentifierNumbered( i, id );
        IF (id.from = KeyWord) THEN
          OutIdentifier( id );
        END;
      END;
    END;
  END PrintKeyWords;
  
  PROCEDURE PrintOtherIdentifiers();
  VAR
    typ, cnt, i: CARDINAL;
    id: IdentifierType;
    s: WordType;
  BEGIN
    cnt := ListLength( IdentifierList );
    IF cnt > 0 THEN
      WriteEol( outp, 'Other identifiers:' );
      FOR i := 1 TO cnt DO
        FetchIdentifierNumbered( i, id );
        IF (id.from <> KeyWord) THEN
          OutIdentifier( id );
        END;
      END;
    END;
  END PrintOtherIdentifiers;

VAR  (* PrintIdentifiers() *)
  typ, cnt, i: CARDINAL;
  id: IdentifierType;
  s: WordType;
BEGIN
  PrintKeyWords();
  PrintOtherIdentifiers();
END PrintIdentifiers;


PROCEDURE PrintErrors();

  VAR
    file: CARDINAL;
    cnt: CARDINAL;

  PROCEDURE WriteLST( VAR f: CARDINAL; lineStr: ARRAY OF CHAR;
                      row, col: CARDINAL; errMsg: ARRAY OF CHAR );
  (* Writes a 'record' to the .LST file 'f' using the parameters passed. *)
    VAR
      c: CARDINAL;
      dumStr: ARRAY [0..255] OF CHAR;
    BEGIN
      CardinalToStr( row, 4, dumStr );
      Append( dumStr, '   ' );
      Append( dumStr, lineStr );
      WriteEol( f, dumStr );

      WriteStr( f, ' *****' );
      IF (col > 0) THEN
        AssignStr( Spaces255, dumStr );
        SetLength( dumStr, col-1 );
      ELSE
        dumStr := '';
      END;
      Append( dumStr, '^' );
      WriteEol( f, dumStr );

      WriteStr( f, ' *????: ' );
      WriteEol( f, errMsg );

      WriteEol( f, '' );  (* Separate errors with a blank line *)
    END WriteLST;

  
  PROCEDURE GetSrcLine( n: CARDINAL; VAR s: ARRAY OF CHAR );
  (* Assumes that n <= ListLength(TextList) *)
    VAR
      typ: CARDINAL;
    BEGIN
      GetElmt( TextList, n, s, typ );
      IF (typ <> StrCode) THEN
        WARN( 'Element from TextList is not of type StrCode.' );
      END;
    END GetSrcLine;

  PROCEDURE PrintDefinitionErrors( VAR f: CARDINAL );
    VAR
      i, typ, cnt: CARDINAL;
      e: ErrorRec;
      errMsg: WordType;
      srcLine: ARRAY [0..255] OF CHAR;
    BEGIN
      (* Not/already defined errors: *)
      cnt := ListLength( ErrorList );
      IF cnt > 0 THEN
        WriteEol( outp, '  Definition errors' );
        FOR i := 1 TO cnt DO
          GetElmt( ErrorList, i, e, typ );
          AssignStr( '"', errMsg );
          Append( errMsg, e.name );
          Append( errMsg, '"' );
          CASE e.err OF
            NotDefined:
              Append( errMsg, ' is not defined.' );
          | AlreadyDefined:
              CASE e.from OF
                Import:
                  Append( errMsg, ' is already imported.' );
              | Const:
                  Append( errMsg, ' is already declared as a CONSTant.' );
              | Type:
                  Append( errMsg, ' already defined as a TYPE.' );
              | Var:
                  Append( errMsg, ' already declared as a VARiable.' );
              | Procedure:
                  Append( errMsg, ' already defined as a PROCEDURE.' );
              ELSE
                WARN( 'Unknown "from" type.' );
              END;
          ELSE
            WARN( 'Unknown "error" type.' );
          END;
          GetSrcLine( e.srcY, srcLine );
          WriteLST( f, srcLine, e.srcY, e.srcX, errMsg );
        END;
      END;
    END PrintDefinitionErrors;

  PROCEDURE PrintReferenceErrors( VAR f: CARDINAL );
    VAR
      id: IdentifierType;
      i, cnt, typ: CARDINAL;
      errMsg: WordType;
      srcLine: ARRAY [0..255] OF CHAR;
    BEGIN
      cnt := ListLength( IdentifierList );
      IF cnt > 0 THEN
        WriteEol( outp, '  Reference errors' );
        FOR i := 1 TO cnt DO
          GetElmt( IdentifierList, i, id, typ );
          IF (typ <> IdentifierCode) THEN
            WARN( 'Element from identifiers list is not of type IdentifierCode.' );
          END;
          IF (id.from <> KeyWord) AND (id.count=0) THEN
            (* This identifier is not a key word, but it was never referenced *)
            GetSrcLine( id.srcY, srcLine );
            AssignStr( id.name, errMsg );
            Append( errMsg, ' not referenced.' );
            WriteLST( f, srcLine, id.srcY, id.srcX, errMsg );
          END;
        END;
      END;
    END PrintReferenceErrors;

  BEGIN
    cnt := ListLength( ErrorList );
    IF cnt < 0 THEN
      WriteEol( outp, 'No errors.' );
    ELSE
      WriteEol( outp, 'Writing .LST file...' );
      IF CreateFile( file, errFname ) <> NoError THEN
        WARN( 'Unable to create .LST file.' );
      END;
  
      PrintDefinitionErrors( file );
      PrintReferenceErrors( file );
  
      IF CloseHandle( file ) <> NoError THEN
        WARN( 'Unable to close .LST file.' );
      END;
    END;
  END PrintErrors;

PROCEDURE Init();
  PROCEDURE InitKeyWordList();
  VAR
    tmpList: GenList;
    i: CARDINAL;
    w: WordType;
  BEGIN
    NewList( tmpList );
    PrintMessage( TextFileToList( keyWordFname, tmpList ) );
    FOR i := 1 TO ListLength( tmpList ) DO
      GetStr( tmpList, i, w );
      AddIdentifier( w, KeyWord );
    END;
    DisposeList( tmpList );
  END InitKeyWordList;
BEGIN  (* Init() *)
  ProcedureLevel := 0;
  Fill( ADR(Spaces255), SIZE(Spaces255), BYTE(' ') );
  NewList( IdentifierList );
  NewList( TextList );
  NewList( ErrorList );

  LineCnt := 0;
  ColCnt := 0;

  LastWord := '';
  CurrentWord := '';

  AssignStr( 'refdef.dat', keyWordFname );

  InitKeyWordList();
END Init;

BEGIN
  Init();

  IF NOT (ParsedParam( 1, fname1 ) ) THEN
    WriteStr( outp, 'Input file name: ' );
    ReadStr( inp, fname1 );
    IF Length(fname1) = 0 THEN RETURN END;
  END;

  AssignStr( fname1, errFname );
  IF Present( '.', fname1 ) THEN
    SetLength( errFname, Pos('.',fname1) );
  ELSE
    Append( fname1, '.MOD' );
  END;
  Append( errFname, '.LST' );

  PrintMessage( TextFileToList( fname1, TextList ) );

  GetModuleName();
  DoImports();
  DoOtherIdentifiers();

  PrintIdentifiers();
  PrintErrors();

  DisposeList( TextList );
  DisposeList( IdentifierList );
  DisposeList( ErrorList );
END RefDef.