(*
  :Program.       Def2Ref
  :Author.        Volker Rudolph
  :Address.       Medicusstr. 31 / 6750 Kaiserslautern
  :Phone.         0631/17160
  :ShortCut.      [vor]
  :Version.       1.2
  :Date.          15.7.1989
  :Copyright.     PD
  :Language.      Modula-II
  :Translator.    M2Amiga 3.2d
  :Imports.       Printf [vor]
  :Contents.      Def2Ref wandelt Modula-2 Definitions-Module in
  :Contents.      DME-Reference-Dateien (dme.refs) um.
  :Usage.         Def2Ref [file|dir] path ref [COMPACT]
*)

MODULE Def2Ref;

FROM Arguments IMPORT NumArgs, GetArg;
FROM Arts      IMPORT Assert, Terminate, TermProcedure, CurrentLevel, wbStarted;
FROM Ascii     IMPORT nul, lf;
FROM Dos       IMPORT Lock, UnLock, Examine, Delay, Open, Read, Close, Write,
                      ExNext,IoErr,
                      FileHandlePtr, FileLockPtr, FileInfoBlockPtr, oldFile,
                      newFile, sharedLock;
FROM Heap      IMPORT Allocate, Deallocate;
FROM Printf    IMPORT SPrintf0, SPrintf1, SPrintf2, SPrintf3, SPrintf4,
                      SPrintf5, SPrintf6, Printf0, Printf1, Printf2, Printf3,
                      Printf4, Printf5, Printf6,L;
FROM Str       IMPORT CapString, Copy, Compare, LastPos, Concat,
                      noOccur;
FROM Strings   IMPORT Length,Occurs,first;
FROM SYSTEM    IMPORT ADDRESS, ADR;

CONST
   StringLen = 120;

TYPE
   A = ADDRESS;
   CHARPtr = POINTER TO CHAR;
   StringPtr = POINTER TO String;
   String = ARRAY [1..StringLen] OF CHAR;
   FileType = (dir, file, notFound);

VAR
   argc:INTEGER;
   len:INTEGER;
   length:LONGINT;
   refName:String;
   defName:String;
   pathName:String;
   comp:String;
   compact:BOOLEAN;
   ftype:FileType;
   writeHandle:FileHandlePtr;

PROCEDURE FileInfo(name:ARRAY OF CHAR;VAR ftype:FileType; VAR len:LONGINT);
VAR
   fib:FileInfoBlockPtr;
   lock:FileLockPtr;
   result:BOOLEAN;
BEGIN
   lock := Lock(ADR(name),sharedLock);
   IF lock = NIL THEN
      Printf1("I can't find '%s'\n",ADR(name));
      ftype := notFound;
   ELSE
      Allocate(fib ,SIZE(fib^));
      result := Examine(lock,fib);
      Assert(result , ADR("Examine error"));
      IF (fib^.dirEntryType > 0) THEN
         ftype := dir;
      ELSE
         ftype := file;
      END; (* IF *)
      len := fib^.size;
      Deallocate(fib);
      UnLock(lock);
   END; (* IF *)
END FileInfo;

PROCEDURE CloseIt;
BEGIN
   IF writeHandle # NIL THEN
      Close(writeHandle);
      writeHandle := NIL;
   END; (* IF *)
END CloseIt;

PROCEDURE FileRefs(path,name:ARRAY OF CHAR;len:LONGINT);
VAR
   bufPtr:CHARPtr;
   bufEnd:LONGINT;
   linePtr:CHARPtr;
   startPtr:CHARPtr;
   buffer:CHARPtr;
   str:String;
   word:String;
   word2:String;
   next:CHAR;
   next2:CHAR;
   fullPath:String;
   writeName:String;
   pos:INTEGER;
   end:BOOLEAN;
   lastLine:CARDINAL;
   currentLine:CARDINAL;
   res:LONGINT;
   handle:FileHandlePtr;

   PROCEDURE WriteRef(ref,pattern:ARRAY OF CHAR;lines:CARDINAL);
   VAR
      str:String;
      res:LONGINT;
      len:INTEGER;
   BEGIN
      IF compact THEN
         SPrintf4(str,"%s %ld %s %s\n",
                  ADR(ref),lines,ADR(fullPath),ADR(pattern));
      ELSE
         SPrintf4(str,"%-25s %4ld  %-15s %s\n",
                  ADR(ref),lines,ADR(fullPath),ADR(pattern));
      END; (* IF *)
      len := Length(str);
      res := Write(writeHandle,ADR(str),len);
      Assert(len = res,ADR("Write error"));
   END WriteRef;

   PROCEDURE SubStr(VAR str:ARRAY OF CHAR;ptr:CHARPtr;len:CARDINAL);
   VAR
      i:CARDINAL;
   BEGIN
      i := 0;
      WHILE (len > 0) AND (ptr^ = ' ') DO
         DEC(len);
         INC(ptr);
      END; (* WHILE *)
      WHILE (i < len) DO
         str[i] := ptr^;
         INC(i);
         INC(ptr);
      END; (* WHILE *)
      str[i] := 0C;
   END SubStr;

   PROCEDURE IncBuf(ch:CHAR);
   VAR
      nextPtr:CHARPtr;

      PROCEDURE SkipComments;
      BEGIN
         REPEAT
            IF (bufPtr^) = lf THEN
               INC(currentLine);
               linePtr := bufPtr;
            END; (* IF *)
            INC(bufPtr);
            INC(nextPtr);
            IF (bufPtr^ = '(') AND (nextPtr^ = '*') THEN
               SkipComments;
            END; (* IF *)
         UNTIL (bufPtr^ = '*') AND (nextPtr^ = ')');
      END SkipComments;

   BEGIN
      INC(bufPtr);
      nextPtr := A(L(bufPtr)+1);
      IF (bufPtr^ = '(') AND (nextPtr^ = '*') THEN
         SkipComments;
      END; (* IF *)
      CASE bufPtr^ OF
          '(':IncBuf(')');
         |'{':IncBuf('}');
         |'[':IncBuf(']');
         |lf :IncBuf(nul);
              INC(currentLine);
              linePtr := bufPtr;
      ELSE
      END; (* CASE *)
      IF (ch # nul) THEN
         WHILE (bufPtr^ # ch) AND (L(bufPtr) < bufEnd) DO
            IncBuf(nul);
         END; (* WHILE *)
         IncBuf(nul);
      END; (* IF *)
   END IncBuf;

   PROCEDURE GetNextWord(VAR str:ARRAY OF CHAR;VAR next:CHAR;inc:BOOLEAN):BOOLEAN;
   VAR
      strPtr:CHARPtr;
      strEnd:CHARPtr;
      oldBuf:CHARPtr;
      oldLine:CHARPtr;
   BEGIN
      strPtr := ADR(str);
      strEnd := A(L(strPtr) + HIGH(str));
      oldBuf := bufPtr;
      oldLine := linePtr;
      WHILE ((bufPtr^ < '0') OR ((bufPtr^ > '9') AND (bufPtr^ < 'A')) OR
            (CAP(bufPtr^) > 'Z'))  AND (L(bufPtr) < bufEnd) DO
         IncBuf(nul);
      END; (* WHILE *)
      WHILE ((bufPtr^ >= '0') AND (bufPtr^ <= '9')) OR
            ((CAP(bufPtr^) >= 'A') AND (CAP(bufPtr^) <= 'Z')) AND
            (strPtr # strEnd) AND (L(bufPtr) < bufEnd) DO
         strPtr^ := bufPtr^;
         INC(strPtr);
         IncBuf(nul);
      END; (* WHILE *)
      next := bufPtr^;
      strPtr^ := nul;
      IF NOT inc THEN
         bufPtr := oldBuf;
         linePtr := oldLine;
      END; (* IF *)
      RETURN (L(bufPtr) >= bufEnd);
   END GetNextWord;

   PROCEDURE SkipToSemicolon;
   BEGIN
      WHILE (bufPtr^ # ';') AND (L(bufPtr) < bufEnd) DO
         IncBuf(nul);
      END; (* WHILE *)
   END SkipToSemicolon;

   PROCEDURE SkipToEND;
   VAR
      word:String;
      next:CHAR;
      end:BOOLEAN;
   BEGIN
      REPEAT
         end := GetNextWord(word,next,TRUE);
         IF (Compare(word,"RECORD") = 0) OR (Compare(word,"CASE") = 0) THEN
            SkipToEND;
         END; (* IF *)
      UNTIL Compare(word,"END") = 0;
   END SkipToEND;

BEGIN
   IF Occurs(name,first,".def",FALSE) # (Length(name)-4) THEN
      Printf0("No DEFINITION-Module\n");
      RETURN;
   END; (* IF *)
   pos := Length(path);
   IF pos > 0 THEN
      IF (path[pos-1] # ':') AND (path[pos-1] # '/') THEN
         path[pos] := '/';
         path[pos+1] := 0C;
      END; (* IF *)
   END; (* IF *)
   Concat(path,name);

   Copy(fullPath,pathName);
   Concat(fullPath,name);

   Allocate(buffer,len);
   bufPtr := buffer;
   linePtr := buffer;
   handle := Open(ADR(path),oldFile);
   Assert(handle # NIL,ADR("Open error"));
   len := Read(handle,bufPtr,len);
   Close(handle);

   SPrintf1(word,"\n# %s\n\n",ADR(name));
   res := Write(writeHandle,ADR(word),Length(word));
   pos := LastPos(name,StringLen,'.');
   IF pos # noOccur THEN
      name[pos] := 0C;
   END; (* IF *)
   word := "(DEFINITION)";
   WriteRef(name,word,9999);

   bufEnd := L(bufPtr) + len;
   DEC(bufPtr);
   IncBuf(nul);
   currentLine := 1;
   REPEAT
      end  := GetNextWord(word,next,TRUE);
      IF (Compare(word,"FROM") = 0)           OR
         (Compare(word,"END") = 0)            OR
         (Compare(word,"CODE") = 0)           OR
         (Compare(word,"IMPORT") = 0)         OR
         (Compare(word,"IMPLEMENTATION") = 0) OR
         (Compare(word,"DEFINITION") = 0)   THEN
         SkipToSemicolon;
      ELSIF (Compare(word,"CONST") = 0)   OR
            (Compare(word,"TYPE") = 0)    OR
            (Compare(word,"VAR") = 0)   THEN
         (* nichts *)
      ELSIF (Compare(word,"PROCEDURE") = 0) THEN
         lastLine := currentLine;
         startPtr := bufPtr;
         WHILE (startPtr^ # '(') AND (startPtr^ # ';') DO
            INC(startPtr);
         END; (* WHILE *)
         WHILE linePtr^ # lf DO
            DEC(linePtr);
         END; (* WHILE *)
         INC(linePtr);
         SubStr(word2,linePtr,L(startPtr)-L(linePtr));
         end  := GetNextWord(word,next,TRUE);
         SkipToSemicolon;
         SPrintf1(str,"`%s'",ADR(word2));
         WriteRef(word,str,currentLine-lastLine+1);
      ELSIF NOT end THEN
         end  := GetNextWord(word2,next2,FALSE);
         IF (Compare(word2,"RECORD") = 0) THEN
            lastLine := currentLine;
            end  := GetNextWord(word2,next2,TRUE);
            SkipToEND;
            SPrintf2(word2,"`%s%lc'",ADR(word),L(next));
            WriteRef(word,word2,currentLine-lastLine+1);
         ELSE
            lastLine := currentLine;
            WHILE (next = ',') DO
               SubStr(word2,linePtr,L(bufPtr)-L(linePtr));
               SPrintf2(str,"`%s%lc'",ADR(word2),L(next));
               WriteRef(word,str,currentLine-lastLine+1);
               end := GetNextWord(word,next,TRUE);
            END; (* WHILE *)
            SubStr(word2,linePtr,L(bufPtr)-L(linePtr));
            SPrintf2(str,"`%s%lc'",ADR(word2),L(next));
            SkipToSemicolon;
            WriteRef(word,str,currentLine-lastLine+1);
         END; (* IF *)
      END; (* IF *)
   UNTIL end;

   Deallocate(buffer);
END FileRefs;

PROCEDURE DirRefs(name:ARRAY OF CHAR);
VAR
   lock:FileLockPtr;
   fib:FileInfoBlockPtr;
   res:BOOLEAN;
   ftype:FileType;
   len:LONGINT;
BEGIN
   FileInfo(name,ftype,len);
   Assert(ftype = dir, ADR("Dir not found"));
   Allocate(fib, SIZE(fib^));
   lock := Lock(ADR(name),sharedLock);
   res := Examine(lock,fib);
   WHILE res DO
      res := ExNext(lock,fib);
      IF (fib^.dirEntryType <= 0) AND res THEN
         Printf1("-->%s\n",ADR(fib^.fileName));
         FileRefs(defName,fib^.fileName,fib^.size);
      END; (* IF *)
   END; (* WHILE *)
   UnLock(lock);
   Deallocate(fib);
END DirRefs;

BEGIN
   Assert(NOT wbStarted,ADR("PLEASE USE FROM CLI"));
   argc := NumArgs();
   IF argc < 3 THEN
      GetArg(0,refName,len);
      Printf1("Aufruf:\n  %s [file|dir] path ref [COMPACT]\n",ADR(refName));
      Terminate(CurrentLevel());
   END; (* IF *)
   Close(writeHandle);
   writeHandle := NIL;
   TermProcedure(CloseIt);

   GetArg(1,defName,len);
   GetArg(2,pathName,len);
   IF (pathName[len] # ':') AND (pathName[len] # '/') THEN
      pathName[len+1] := '/';
      pathName[len+2] := 0C;
   END; (* IF *)
   GetArg(3,refName,len);
   GetArg(4,comp,len);
   CapString(comp);
   compact := Compare(comp,"COMPACT") = 0;
   FileInfo(defName,ftype,length);
   IF (ftype # notFound) THEN
      Printf1("Creating '%s'\n",ADR(refName));
      writeHandle := Open(ADR(refName),newFile);
      IF ftype = dir THEN
         DirRefs(defName);
      ELSE
         comp := "";
         FileRefs(comp,defName,length);
      END; (* IF *)
      Close(writeHandle);
      writeHandle := NIL;
   END; (* IF *)
END Def2Ref.