$ TITLE('=====>>>  STOPIF   <<<=====')

STOPIF: DO;

/************************************************************************/
/*																		*/
/*     'Copyright 1981,1983 Intel Corporation'.  All rights reserved.	*/
/*      No part of this program or publication may be reproduced,		*/
/*      transmitted, transcribed, stored in a retrievel system, or		*/
/*      translated into any language or computer language, in any		*/
/*      form or by any means, electronic, mechanical, magnetic,			*/
/*      optical, chemical, manual or otherwise, without the prior		*/
/*      written permission of Intel Corporation, 3065 Bowers			*/
/*      Avenue, Santa Clara, California, 95051, Attn: Software			*/
/*      License Administration.											*/
/*																		*/
/************************************************************************/

$IF XVERSION
DECLARE PROPRIETARY(*) BYTE DATA ('INTEL PROPRIETARY SOFTWARE');
DECLARE PROGRAM$VERSION$NUMBER$STRING (*) BYTE DATA
    ('program_version_number=X107',0);
$ELSE
DECLARE COPYRIGHT (*) BYTE DATA  ('COPYRIGHT 1981,1983 INTEL ');
DECLARE PROGRAM$VERSION$NUMBER$STRING (*) BYTE DATA
    ('program_version_number=V1.1',0);
$ENDIF

    
      
/* THIS IMPROVED VERSION OF STOPIF IS DESIGNED TO RUN WITH THE ASSEMBLERS AS
WELL AS PL/M.  ADDITIONALLY, THE PRESENCE OF A PAGE BREAK SHOULD NOT FOUL UP
STOPIF. */
/* MODIFICATION:  20 Sept 1982 by M. L. - scans back upto 1024
                  characters for ERROR line; this lookback amount is 
                  a compile time constant (simply set MAX$BUFFER$SIZE).

   MODIFICATION:  23 Sept 1982 by M. L. - 1) generalized error or 
                  warning message searching task in order to support
                  all of the existing compilers' and assemblers' listings.
                  2) implement IGNORE WARNING switch.
*/
                  

/* LITERALLY DEFINITIONS */

  DECLARE
    TRUE LITERALLY '0FFH',
    FALSE LITERALLY '0',
    WORD LITERALLY 'ADDRESS',
    POINTER LITERALLY 'ADDRESS',
    CR LITERALLY '0DH',
    LF LITERALLY '0AH',
    TAB LITERALLY '09H',
    FF LITERALLY '0CH',
    BELL LITERALLY '07H',
    BOOLEAN LITERALLY 'BYTE',
    esc literally '1bH',

    error$or$warning$found literally '1',
    no$error$or$warning literally '2',
    non$list$file literally '3',
    space literally '20H',
    max$buffer$size literally '1024',
    max$num$blocks literally '(max$buffer$size/128)';


/* EXTERNAL PROCEDURES FROM ISIS */

OPEN: PROCEDURE(AFTN$P,FILENAME$P,ACCESS,MODE,STATUS$P) EXTERNAL;
  DECLARE (AFTN$P,FILENAME$P,STATUS$P) POINTER, (ACCESS,MODE) WORD; END;
READ: PROCEDURE(AFTN,BUF$P,COUNT,ACTUAL$P,STATUS$P) EXTERNAL;
  DECLARE (AFTN,COUNT) WORD, (BUF$P,ACTUAL$P,STATUS$P) POINTER; END;
WRITE: PROCEDURE(AFTN,BUF$P,COUNT,STATUS$P) EXTERNAL;
  DECLARE (AFTN,COUNT) WORD, (BUF$P,STATUS$P) POINTER; END;
SEEK: PROCEDURE(AFTN,MODE,BLOCKNO$P,BYTENO$P,STATUS$P) EXTERNAL;
  DECLARE (AFTN,MODE) WORD, (BLOCKNO$P,BYTENO$P,STATUS$P) POINTER; END;
ERROR: PROCEDURE (NUMBER) EXTERNAL; DECLARE NUMBER WORD; END;
EXIT: PROCEDURE EXTERNAL; END;
WHOCON: PROCEDURE(AFTN,FILE$NAME$P) EXTERNAL;
  DECLARE AFTN WORD, FILENAME$P POINTER; END;
CONSOL: PROCEDURE(INFILE$P,OUTFILE$P,STATUS$P) EXTERNAL;
  DECLARE (INFILE$P,OUTFILE$P,STATUS$P) POINTER; END;

/* GLOBAL VARIABLES */

DECLARE
  STATUS WORD, /* FOR CALLS TO ISIS */
  COMMAND$SIZE WORD,
  ACTUAL WORD,
  AFTN WORD,
  (BLOCK$NUMBER, BYTE$NUMBER) WORD,
  BUFFER(MAX$BUFFER$SIZE) BYTE, /* THE LAST 1024 BYTES OF THE LISTING */
  TIMER BYTE, /* FOR TIMING THE BELL */
  COMMAND$TAIL(122) BYTE,
  NON$LIST$MSG (*) BYTE DATA('NOT A LISTING ==> ',0),
  EMSG (*) BYTE DATA ('PROGRAM ERROR IN ',0),
  WMSG (*) BYTE DATA ('PROGRAM WARNING IN ',0),
  ignore$warning  boolean initial (false),
  file$name$length byte,
  find$error byte,
  find$warning byte,
  in$file$ptr address,
  command$ptr address,
  command$ch based command$ptr byte;
  


/* LOCAL PROCEDURES */


CHECK$STATUS: PROCEDURE;

  IF STATUS <> 0
  THEN DO;
    CALL ERROR(STATUS);
    CALL CONSOL(.(':VI: '),.(':VO: '),.STATUS);
    IF STATUS <> 0
    THEN CALL ERROR(STATUS);
    CALL EXIT;
  END;

END CHECK$STATUS;



DISPLAY: PROCEDURE(LEN,BUF) PUBLIC; /* WRITE OUT A BUFFER TO THE CONSOL */

  DECLARE
    LEN WORD, /* THE NUMBER OF CHARACTER TO WRITE OUT */
    BUF ADDRESS; /* THE ADDRESS OF THE BUFFER */

  IF LEN > 0
  THEN DO;

    CALL WRITE(0,BUF,LEN,.STATUS);
    CALL CHECK$STATUS;

  END;

END DISPLAY;



PRINT: PROCEDURE(BUF) PUBLIC;
         /* WRITE OUT A BUFFER TERMINATED BY NULL TO :CO: */

  DECLARE
    BUF ADDRESS, /* ADDRESS OF BUFFER */
    PTR ADDRESS, /* POINTER INTO BUFFER */
    CHAR BASED PTR BYTE; /* CHARACTER IN BUFFER */

  /* SEARCH FOR NULL */
  PTR = BUF;
  DO WHILE CHAR <> 0;
    PTR = PTR + 1;
  END;

  /* print out buffer */
  CALL DISPLAY(PTR - BUF,BUF);

END PRINT;



FAIL: PROCEDURE(MSG$P);

  DECLARE MSG$P POINTER,
          OUT$FILE$NAME(15) BYTE;

  CALL PRINT(MSG$P);
  CALL DISPLAY(file$name$length, in$file$ptr);
  call print(.(cr,lf,0));
  CALL WHOCON(0,.OUT$FILE$NAME);
  CALL CONSOL(.(':VI: '),.(':VO: '),.STATUS);
  CALL CHECK$STATUS;
  IF OUT$FILE$NAME(1) <> 'V' /* VIDEO OUTPUT */
  THEN DO;
    CALL PRINT(MSG$P);
    CALL DISPLAY(file$name$length, in$file$ptr);
  END;
  CALL PRINT(.(CR,LF,0));
  DO TIMER = 1 TO 80;
    CALL DISPLAY(1,.(BELL));
    CALL TIME(250);
  END;
  CALL EXIT;

END FAIL;



capitalize: procedure (buff$ptr, len);

  declare buff$ptr pointer,
          len word,
          buff based buff$ptr (1) byte,
          i word;

  i = 0;
  do while i < len;
    if buff(i) >= 'a' and buff(i) <= 'z' then
      buff(i) = buff(i) - 20H;
    i = i + 1;
  end;

end capitalize;



READ$BUF: PROCEDURE;

  if block$number < max$num$blocks then
    block$number, byte$number = 0;
  else
    block$number = block$number - max$num$blocks;

  call seek(aftn, 2, .block$number, .byte$number, .status);
  call check$status;
  
  CALL READ(AFTN, .BUFFER, max$buffer$size, .ACTUAL, .STATUS);
  CALL CHECK$STATUS;

  call capitalize(.buffer, actual);

END READ$BUF;



cmp: procedure (str$ptr$1, str$ptr$2, count) boolean; 

  /* compare strings */

  declare (str$ptr$1, str$ptr$2) pointer,
          str$1 based str$ptr$1 (1) byte,
          str$2 based str$ptr$2 (1) byte,
          (count, j) byte;

  j = 0;
  do while j < count  ;
    if str$1(j) <> str$2(j) then
      return false;
    else
      j = j + 1;
  end;
  return true;
  
end cmp;



digit: procedure (ch) boolean;

  declare ch byte;

  if (ch >= '0') and (ch <= '9') then 
    return true;
  else
    return false;

end digit;



search: procedure (search$str$ptr) byte;

  /* returns:
     error$or$warning$found -  If search$str is found and there is a non-zero 
                         number preceding it.
     no$error$or$warning -  If search$str is found and either '0' or 
                         'NO' preceds it.
     non$list$file -  If search$str is not found  */
     

  declare search$str$ptr pointer,  /* points to (5,'ERROR')   */
                                   /*        or (7,'WARNING') */
  
          search$str based search$str$ptr (1) byte, 
          i word;

  if actual = 0 then
    return non$list$file;
  if actual <= search$str(0) then
    i = actual - 1;
  else
    i = actual - search$str(0) - 1;
    
  do while i > 0;
    if cmp(.buffer(i), .search$str(1), search$str(0))  then
      do;
        /* back up and search for '0' or 'NO' */

        do while i > 0;
          i = i - 1;
          if digit(buffer(i)) then
            do;
              do while digit(buffer(i)) and i > 0;
                i = i - 1;
              end;

              if i = 0 then
                /* not enough room in buffer to backup,
                   so pretend string is never found */
                return non$list$file;
              else
                if buffer(i+1) > '0'  then 
                  return error$or$warning$found;
                else
                  return no$error$or$warning;
            end;
          else
            if cmp(.buffer(i), .('NO'), 2)  then
              return no$error$or$warning;
        end;

         /* Even though the target string is found, number of errors  
            or word 'NO' is not found. It will be considered as a 
            non-listing file.  */
        return non$list$file;

      end;  /* string not found */
    i = i - 1;
  end;
  return non$list$file;

end search;



deblanks:  procedure (buff$ptr) address;

  declare buff$ptr address,
          buff based buff$ptr byte;

  do while buff = space;
    buff$ptr = buff$ptr + 1;
  end;
  return buff$ptr;
  
end deblanks;



scan$blanks:  procedure (buff$ptr) address;

  declare buff$ptr address,
          buff based buff$ptr byte;

  do while (buff <> space) and (buff <> cr) and (buff <> esc);
    buff$ptr = buff$ptr + 1;
  end;
  return buff$ptr;
  
end scan$blanks;



/**************  MAIN BEGIN ******************/

/* READ COMMAND TAIL */
CALL READ(1,.COMMAND$TAIL,128,.COMMAND$SIZE,.STATUS);
CALL CHECK$STATUS;

call capitalize(.command$tail, command$size);
in$file$ptr = deblanks(.command$tail);
command$ptr = scan$blanks(in$file$ptr);
file$name$length = command$ptr - in$file$ptr;

call open(.aftn, in$file$ptr, 1, 0, .status);
if status = 13 then 
  call fail(.('NO SUCH FILE ==> ', 0));
else
  if status = 4 or status = 5 or status = 23 or status = 28 then
    call fail(.('ILLEGAL FILENAME SPECIFICATION ==> ', 0));
  else
    call check$status;

command$ptr = deblanks(command$ptr);
if command$ch <> cr then
  do;
    if cmp(command$ptr, .('IW'), 2) or
       cmp(command$ptr, .('IGNOREWARNING'), 13)  then
       ignore$warning = true;
    else
       ignore$warning = false;
  end;
  
  
    
CALL SEEK(AFTN,4,.BLOCK$NUMBER,.BYTE$NUMBER,.STATUS);
CALL CHECK$STATUS;

CALL SEEK(AFTN,0,.BLOCK$NUMBER,.BYTE$NUMBER,.STATUS);

call read$buf;
BUFFER(actual) = CR;

find$error = search(.(5,'ERROR'));

if find$error = error$or$warning$found  then
  call fail(.emsg);
else
  if find$error = no$error$or$warning  then
    do;
      if ignore$warning then
        call exit;
      else
        find$warning = search(.(7,'WARNING'));
        if find$warning = error$or$warning$found  then
          call fail(.wmsg);
        else
          call exit;
    end;
  else
    call fail(.non$list$msg);
        

END STOPIF;