PROGRAM P3EXT;

{
  File: [22,310]P3EXT.PAS
  Author: Phil Hannay oct-87

  Last Edit: 12-APR-1989 08:55:42 

  History: 

  Phil Hannay -- 26-Jan-84  Fixed bug where leading <TAB> characters
    were not ignored when searching for procedure or function keyword.

  Phil Hannay -- 19-Oct-83  Changed output file name to a max of 9 chars
    from the old max of 6 chars.

  Phil Hannay -- 7-Oct-83  Fixed bug where a procedure name starting
    with a lower case letter was not found.

}

{Error handling is done a little differently than normal.  We will work
 away assuming all is in order until proven otherwise.  When proven otherwise,
 we will issue an error message, and then continue as normal, which will
 cause us to crash the program by attempting some fatal action.  This way
 we need not provide any means of funneling errors to the normal program
 exit.  Since all errors are unrecoverable, there is no need to come to
 a controlled stop, and further, we can then put this program in a command
 file that can then use <EXSTAT> to see if we terminated normally or not.}

%INCLUDE pas$ext:General.typ

PROCEDURE EXITST(STATUS:INTEGER);EXTERNAL;
  {OMSI supplied external to exit w/status}  

CONST
  TRANFILNAME='TRANEXT.DAT;1';

VAR
  PASFIL,EXTFIL:TEXT;
  PASFILNAME,EXTFILDEV:PACKED ARRAY [1..25] OF CHAR;
  ENTRY,ENTRYHOLD:CH10;
  ENTRYLEN:INTEGER;
  DONE:BOOLEAN;
  

PROCEDURE GET_PARAMETERS;

VAR
  TRANFIL:TEXT;
  I,FILSTAT:INTEGER;

BEGIN
RESET(TRANFIL,TRANFILNAME,,FILSTAT);
IF FILSTAT<=0
  THEN 
    BEGIN
    WRITELN('P3EXT> Error: could not open file "',TRANFILNAME,'"');
    EXITST(4)
    END;
READLN(TRANFIL,PASFILNAME);
READLN(TRANFIL,ENTRY);
ENTRYLEN:=1;
ENTRY[10]:=' ';
WHILE ENTRY[ENTRYLEN]<>' ' DO ENTRYLEN:=ENTRYLEN+1;
{Blank out any letters following the first occurring space}
FOR I:=ENTRYLEN TO 10 DO ENTRY[I]:=' ';
ENTRYLEN:=ENTRYLEN-1;
READLN(TRANFIL,EXTFILDEV);
CLOSE(TRANFIL);
END;  {PROCEDURE GET_PARAMETERS}


PROCEDURE PUT_EXTERNAL_CALL;

VAR
  I,COUNT:INTEGER;
  BUFFER:PACKED ARRAY [1..133] OF CHAR;
  PROCHOLD:CH9;
  FOUND_HEADER:BOOLEAN;


PROCEDURE PUT_CALL;

VAR
  SYMBOL:CHAR;
  I,LINELEN:INTEGER;

BEGIN
WRITELN(EXTFIL);
WHILE NOT((BUFFER[COUNT]=';')OR(BUFFER[COUNT]='(')OR(BUFFER[COUNT]=':')) DO
  BEGIN
  IF COUNT>132
    THEN 
      BEGIN
      LINELEN:=133;
      WHILE (LINELEN>1) AND (BUFFER[LINELEN]=' ') DO LINELEN:=LINELEN-1;
      FOR I:=1 TO LINELEN DO WRITE(EXTFIL,BUFFER[I]);
      WRITELN(EXTFIL);
      IF EOF(PASFIL) 
        THEN
          BEGIN
          WRITELN('P3EXT> Error: no ";" after ',
                            'procedure (function) header');
          EXITST(4)
          END;
      READLN(PASFIL,BUFFER);
      BUFFER[133]:=' ';
      IF BUFFER[1]=';' THEN BUFFER[1]:=' ';
      COUNT:=1
      END
    ELSE
      BEGIN
      COUNT:=COUNT+1
      END
  END;
CASE BUFFER[COUNT] OF
  '(':SYMBOL:=')';
  ':':SYMBOL:=';';
  ';':
    BEGIN
    SYMBOL:=';';
    COUNT:=COUNT-1
    END;
  OTHERWISE SYMBOL:=';'
  END; {CASE}
REPEAT
  IF COUNT>132
    THEN
      BEGIN
      LINELEN:=133;
      WHILE (LINELEN>1) AND (BUFFER[LINELEN]=' ') DO LINELEN:=LINELEN-1;
      FOR I:=1 TO LINELEN DO WRITE(EXTFIL,BUFFER[I]);
      WRITELN(EXTFIL);
      IF EOF(PASFIL) 
        THEN 
          BEGIN
          WRITELN('P3EXT> Error: no "',SYMBOL,'" found');
          EXITST(4)
          END;
      READLN(PASFIL,BUFFER);
      BUFFER[133]:=' ';
      IF BUFFER[1]=';' THEN BUFFER[1]:=' ';
      COUNT:=1
      END
    ELSE
      BEGIN
      COUNT:=COUNT+1
      END;
  IF BUFFER[COUNT]=')' THEN SYMBOL:=';'
  UNTIL BUFFER[COUNT]=SYMBOL;
{We are now at the end of the procedure call.  We will copy just up to
 this terminating semi-colon, and not the rest of the line, since
 it may or may not (in macro file) contain an external statement.
 We then will blank out the call, but leave the rest of the line, since
 the comment may begin on the same line.}
LINELEN:=COUNT;
FOR I:=1 TO LINELEN DO WRITE(EXTFIL,BUFFER[I]);
WRITELN(EXTFIL);
FOR I:=1 TO LINELEN DO BUFFER[I]:=' ';
BUFFER[133]:=' ';
IF BUFFER[1]=';' THEN BUFFER[1]:=' ';
COUNT:=0;
WRITELN(EXTFIL,'   EXTERNAL;');
{Now we seek out the comment.  Look first for the open bracket.}
SYMBOL:='{';
REPEAT
  IF COUNT>132
    THEN
      BEGIN
      {We are at the end of the line.}
      IF SYMBOL='}'
        THEN
          BEGIN
          {We are inside the comment looking for the end, so this is a
           valid line to write to the EXT file.}
          LINELEN:=133;
          WHILE (LINELEN>1) AND (BUFFER[LINELEN]=' ') DO LINELEN:=LINELEN-1;
          FOR I:=1 TO LINELEN DO WRITE(EXTFIL,BUFFER[I]);
          WRITELN(EXTFIL)
          END;
      IF EOF(PASFIL) 
        THEN 
          BEGIN
          {Still working on the comment. Cannot have end of file yet.}
          WRITELN('P3EXT> Error: Did not find a comment');
          WRITELN('P3EXT> Error: the "',SYMBOL,
                                  '" bracket not found');
          EXITST(4)
          END;
      READLN(PASFIL,BUFFER);
      BUFFER[133]:=' ';
      IF BUFFER[1]=';' THEN BUFFER[1]:=' ';
      COUNT:=1
      END
    ELSE
      BEGIN
      {Continue scanning the line for the SYMBOL}
      COUNT:=COUNT+1
      END;
  IF BUFFER[COUNT]=SYMBOL THEN SYMBOL:='}'
  UNTIL BUFFER[COUNT]=SYMBOL;
{We are done with the comment.  All that remains is to write the
 last line of the comment to the EXT file.  Note that we write just
 up thru the close bracket symbol, because there could be a statement
 following it on the same line.}
LINELEN:=COUNT;
FOR I:=1 TO LINELEN DO WRITE(EXTFIL,BUFFER[I]);
{A couple of blank lines for pretty formatting, and we are done.}
WRITELN(EXTFIL);
WRITELN(EXTFIL);
CLOSE(EXTFIL);
DONE:=TRUE
END; {PROCEDURE PUT_CALL}


BEGIN {MAIN - PUT_EXTERNAL_CALL}
FOUND_HEADER:=FALSE;
{Make ENTRY all uppercase.}
FOR I:=1 TO ENTRYLEN DO
  IF ORD(ENTRY[I])>=97 THEN ENTRY[I]:=CHR(ORD(ENTRY[I])-32);
WHILE (NOT(EOF(PASFIL))) AND (DONE=FALSE) DO
  BEGIN
  READLN(PASFIL,BUFFER);
  BUFFER[133]:=' ';
  IF BUFFER[1]=';' THEN BUFFER[1]:=' ';
  COUNT:=1;
  {Disregard leading semi-colons if they occur in column one.  This allows 
   us to imbed pascal call headers and comments in macro source programs.}
  {Ignore leading blanks or tabs}
  WHILE ((BUFFER[COUNT]=' ')OR(BUFFER[COUNT]=CHR(9)))
                          AND (COUNT<=132) DO COUNT:=COUNT+1;
  IF ((BUFFER[COUNT]='P')OR(BUFFER[COUNT]='p')OR(BUFFER[COUNT]='F')
    OR(BUFFER[COUNT]='f')) AND (COUNT<=122)
    THEN
      BEGIN
      {A word beginning with P (Procedure?) or F (Function?) encountered.
       Let's see if it is what we think it is.}
      FOR I:=1 TO 9 DO PROCHOLD[I]:=BUFFER[COUNT+I-1];
      {Make PROCHOLD all uppercase.}
      FOR I:=1 TO 9 DO
        IF ORD(PROCHOLD[I])>=97 THEN PROCHOLD[I]:=CHR(ORD(PROCHOLD[I])-32);
      IF (PROCHOLD='PROCEDURE') OR (PROCHOLD='FUNCTION ') 
        THEN
          BEGIN
          IF PROCHOLD[1]='P'
            THEN COUNT:=COUNT+9
            ELSE COUNT:=COUNT+8;
          WHILE (BUFFER[COUNT]=' ') AND (COUNT<=132) DO COUNT:=COUNT+1;
          IF ((BUFFER[COUNT]=ENTRY[1])OR(BUFFER[COUNT]=CHR(ORD(ENTRY[1])+32)))
                AND (COUNT<=133-ENTRYLEN)
            THEN
              BEGIN
              ENTRYHOLD:='          ';
              FOR I:=1 TO ENTRYLEN 
                DO ENTRYHOLD[I]:=BUFFER[COUNT+I-1];
              {Make ENTRYHOLD all uppercase.}
              FOR I:=1 TO ENTRYLEN DO
                IF ORD(ENTRYHOLD[I])>=97 
                  THEN ENTRYHOLD[I]:=CHR(ORD(ENTRYHOLD[I])-32);
              {Note that both ENTRYHOLD and ENTRY have been forced
               to uppercase, that way we have no problem with upper/lower
               case mismatches for identical letters.}
              IF ENTRYHOLD=ENTRY
                THEN
                  BEGIN
                  {The procedure or function was found and verified, now
                   we will generate the external call from the procedure
                   header, and add the first encountered comment}
                  FOUND_HEADER:=TRUE;
                  COUNT:=COUNT+ENTRYLEN;
                  PUT_CALL
                  END
              END
          END
      END
  END;
IF FOUND_HEADER=FALSE
  THEN
    BEGIN
    WRITELN('P3EXT> Error: Could not find procedure or ',
       'function named "',ENTRY,'"');
    EXITST(4)
    END;
END; {PROCEDURE PUT_EXTERNAL_CALL}



PROCEDURE EXTRACT_EXTERNAL_CALL;

VAR
  EXTFILNAME:CH15;
  FILSTAT,I,COUNT:INTEGER;

BEGIN
EXTFILNAME:='         .EXT;1';
FOR I:=1 TO 9 DO EXTFILNAME[I]:=ENTRY[I];
FILSTAT:=0;
REWRITE(EXTFIL,EXTFILDEV,EXTFILNAME,FILSTAT);
IF FILSTAT<0 
  THEN 
    BEGIN
    WRITELN('P3EXT> Error: Unable to open EXT file "',
        EXTFILDEV,EXTFILNAME,'"');
    EXITST(4)
    END;
PUT_EXTERNAL_CALL;
CLOSE(EXTFIL)
END;  {PROCEDURE EXTRACT_EXTERNAL_CALL}


PROCEDURE EXT_FILE_EXTRACT;

VAR
  FILSTAT:INTEGER;

BEGIN
RESET(PASFIL,PASFILNAME,,FILSTAT);
IF FILSTAT<0 
  THEN 
    BEGIN
    WRITELN('P3EXT> Error: Unable to open source file "',PASFILNAME,'"');
    EXITST(4)
    END;
IF ENTRYLEN<=0
  THEN 
    BEGIN
    WRITELN('P3EXT> Error: A blank entry point name specified');
    EXITST(4)
    END;
EXTRACT_EXTERNAL_CALL;
CLOSE(PASFIL)
END;  {PROCEDURE EXT_FILE_EXTRACT}


BEGIN
DONE:=FALSE;
GET_PARAMETERS;
EXT_FILE_EXTRACT;    
END.