$   goto start
$!***************************************************************************
$!*                                                                         *
$!*  DCL_CHECK.COM                                                          *
$!*                                                                         *
$!*  Copyright 1995, 2003  Hewlett-Packard Development Company, L.P.        *
$!*                                                                         *
$!* Confidential computer software.  Valid license from HP and/or           *
$!* its subsidiaries required for possession, use, or copying.              *
$!*                                                                         *
$!* Consistent with FAR 12.211 and 12.212, Commercial Computer Software,    *
$!* Computer Software Documentation, and Technical Data for Commercial      *
$!* Items are licensed to the U.S. Government under vendor's standard       *
$!* commercial license.                                                     *
$!*                                                                         *
$!* Neither HP nor any of its subsidiaries shall be liable for technical    *
$!* or editorial errors or omissions contained herein.  The information     *
$!* in this document is provided "as is" without warranty of any kind and   *
$!* is subject to change without notice.  The warranties for HP products    *
$!* are set forth in the express limited warranty statements accompanying   *
$!* such products.  Nothing herein should be construed as constituting an   *
$!* additional warranty.                                                    *
$!*                                                                         *
$!***************************************************************************
$!
$!  Abstract:   Check DCL procedures for certain errors that are easy
$!              to make and/or potentially difficult to locate, as well
$!              as some others.  Note that this procedure cannot
$!              guarantee total correctness.
$!
$!    Author:   Charles W Hammond
$!
$!   Created:   October/November 1996
$!
$!    Inputs:   P1 is the procedure file to be checked.
$!              Current default directory is assumed if not included.
$!              .COM extension is assumed if not included.
$!
$!              If P1 is not entered or if the file is not found
$!              the procedure prompts for the file.
$!
$!              If P1 contains "HELP" (not case sensitive) the DCL_CHECK
$!              help subsystem is accessed.
$!
$!              If P1 is a file name (i.e. not "HELP) then P2 may contain
$!              the name for a listing file.  If p2 is not supplied, the
$!              listing is displayed on SYS$OUTPUT.
$!
$!              if P1 contains "HELP", then P2 through P8 may contain
$!              help topics and sub-topics.
$!
$!              SYS$SCRATCH is used for intermediate work files.
$!
$!   Outputs:   Listing of errors.
$!
$!
$!  MODIFICATION HISTORY
$!
$!  V3.3    2004-Nov-22             Charlie Hammond
$!      Change version to V.
$!
$!  B3.3    2004-Nov-15             Charlie Hammond
$!      Add $! DCL_CHECK COMMENT "tag" to add comments to diagnostic list.
$!
$!  A3.3    2004-Nov-10             Charlie Hammond
$!      Improve CCN to avoid some unnecessary diagnostics.
$!      Improved check for perceives to eliminate some false PSQ diagnostics.
$!
$!  V3.2    2004-Aug-23             Charlie Hammond
$!      No change from K3.2.  V3.2 will be sumitted to the FREEWARE CD.
$!
$!  K3.2    2004-Aug-19             Charlie Hammond
$!      Implement Ed Millers SLAC-J3.2 version.
$!      This is another fine piece of work by Ed.  Thanks!
$!    SLAC-J3.2  2004-AUG-12      Ed Miller (esm@slac.stanford.edu)
$!      Split UMP into two checks: UMP and USP (for parentheses
$!      outside and inside quoted strings).  Similarly for
$!      bracket tests UMB and USB.
$!
$!  J3.2      2004-APR-19             Charlie Hammond
$!      Fix problems with similar lables in different subroutines
$!
$!  I3.2      2004-APR-07             Charlie Hammond
$!      -- Thanks to Paddy O'Brien for reporting these problems.
$!      Fix parsing of DECK w/ /DOLLARS
$!      Do check for UMB in quoted strings (previously did not)
$!      Avoid LNS for label on CALL
$!      Avoid ONW for file with READ/DELETE
$!      Don't create a shadow for EXIT = and GOTO = assignments.
$!
$!  H3.2      2004-APR-05             Charlie Hammond
$!      [no verison change]
$!      Fix one check for " "")"""
$!
$!  H3.2      2004-APR-02             Charlie Hammond
$!      [no verison change]
$!      Don't use PIPE command on pre V7.1 systems
$!
$!  H3.2      2004-MAR-05             Charlie Hammond
$!      Add LNS-S  errlr --
$!      referenced label  is not in this subroutine
$!
$!  H3.1-B    2004-FEB-18             Charlie Hammond
$!      Fix problem detecting apparent labels that contain ( or "
$!
$!  H3.1-A    2003-DEC-30             Charlie Hammond
$!      (version not changed)
$!      Dislay elapsed time on systems that support F$DELTA_TIME
$!
$!  H3.1-A  2003-DEC-10             Charlie Hammond
$!      Updated help to reflect improvements made in H3.1.
$!      Change code to eliminate a UMP diagnostic when DCL_CHECK
$!      is used to check itself.
$!      Improved error message (file name) for some cases where
$!      the input file is not found.
$!
$!  H3.1    2003-DEC-03             Ed Miller
$!      Add or remove blanks from dcl_record to avoid invalid diagnostics
$!
$!  Many thanks to Ed Miller, Stanford University, for his efforts to
$!  report many of the problems fixed in versions F3.1 and G3.1,
$!  and for testing (ofter re-testing) these fixes.
$!
$!  G3.1    2003-NOV-03             Charlie Hammond
$!      Parse input file better to allow for logical search list
$!      Catch and warn about wildcard characters
$!      Improve check for SUBROUTINE and ENDSUBROUTINE
$!      Handle a label NOT followed by a space
$!      Avoid confusing @<dir>:<file> as a lable
$!
$!  F3.1    2003-OCT-08             Charlie Hammond
$!      Most of the fixes in these version are the result of errors
$!      reported by Ed Miller -- esm@slac.stanford.edu -- Thanks, Ed!
$!
$!      Use F$LOCATE to indentify SUBROUTINE and ENDSUBROUTINE
$!      to avoind confusion with symbols starting with SUBRxxx or ENDSxxx
$!        out-> if $extract(0,4,token) .eqs. "SUBR"
$!        out-> if $extract(0,4,token) .eqs. "ENDS"
$!        new-> if f$locate(token,"SUBROUTINE") .eq. 0
$!        new-> if f$locate(token,"ENDSUBROUTINE") .eq. 0
$!
$!      Convert a PIPE to inline code so that we don't need to
$!      redefine SYS$OUTPUT in other than user mode.
$!      (This preserves a customer SYS$OUTPUT definition.)
$!
$!      Add a display of DCL_CHECK$* logicals to file listing.
$!
$!      Allow for the possibility that OPEN, READ, WRITE and CLOSE
$!      may be used as variables.
$!
$!      remove handling of /OUT -- this is done by DCL, which sees
$!      /out as a qualifier on the @ command.
$!
$!      Look for "$GOTO" as well as "GOTO" to find labels
$!
$!      Add OCE diagnostic for /END on OPEN or CLOSE
$!
$!      Avoid possible infinite loop trying to prompt for input file
$!
$!      Find I/O verbs on lines with labels
$!
$!  E3.1    2003-SEP-17             Charlie Hammond
$!      Fixed false "END IF" such as
$!          $ Read/Error=3DCheck_MEP_End IF Rec
$!                                   ^^^^^^
$!      Fixed problem with operators not preceded/followed by spaces
$!          $ If.not.condition
$!      Fixed some false truncated lexical problems
$!
$!  D3.1    2003-AUG-21             Charlie Hammond
$!      Fixed some false instances of UMP and PSQ/PSR errors.
$!
$!  C3.1    2003-AUG-20             Charlie Hammond
$!      Avoid flagging possessives ("'s " in quoted string) as
$!      PSQ-W  possible error using single-quote (') in quoted string
$!
$!  B3.1    2003-AUG-20             Charlie Hammond
$!      Re-write code that finds the file-name logical-name on I/P verbs
$!      so that it can handle quoted strings and symbol substitution
$!      within quoted strings.
$!
$!  A3.1    2003-JUN-05             Charlie Hammond
$!      Improved checking for paired brackets
$!      by not checking in quoted strings
$!
$!  V3.0    2003-JUN-03             Charlie Hammond
$!      Add checking for paired brackets
$!
$!  H3.0    2003-APR-03             Charlie Hammond
$!      Added the contraction "They've".
$!      Added all contractions in all upper case.
$!      Added possessives for common accounting periods.
$!          "Day's", "Week's", "Month's", "Period's", "Quarter's",
$!          "Half's" and "Year's" (also in all lower and all upper case).
$!          Also names of weekdays and months
$!
$!  G3.0    2003-APR-01             Charlie Hammond
$!      Fixed various spelling errors/typos
$!      Fixed aproblem with ICO (Help from Norm Raphael @metso.com)
$!
$!  F3.0    30-Sep-2002             Charlie Hammond
$!      Don't do file checking on SYS$COMMAND, SYS$ERROR or SYS$PIPE
$!      (In addition to SYS$INPUT and SYS$OUTPUT)
$!      Fix a problem with double quotes in symbol used w/ READ/KEY
$!
$!  E3.0    16-Sep-2002             Charlie Hammond
$!      Avoid false diagnostics ICO-S for ">" and "<" in PIPEs
$!      Only check /END and /ERR labels on /END_OF_FILE and /ERROR
$!
$!  D3.0    04-Sep-2002             Charlie Hammond
$!      added " .ea ", " ea. " and " .ea. " to list of invaled
$!      comparison operators.
$!
$!  C3.0    18-Mar-2002             Charlie Hammond
$!      Fix problem getting file logical names when there is an
$!      /END or /ERR qualifier with spaces preceding of following the "="
$!
$!  B3.0    13-Mar-2002             Charlie Hammond
$!      Fix problem with /ERROR on RUN statement
$!
$!  A3.0    18-Feb-2002             Charlie Hammond
$!      Add file verb checking
$!    NLN-S  An OPEN, READ, WRITE or CLOSE statement has no logical name
$!    ONC-E  A file that is opened has no close statement
$!    INR-A  file that is opened for read is not read
$!    ANR-E  A file that is opened for append is not written
$!    ONW-E  A file that is opened for write is not written
$!    RNR-S  A file that is not opened for read is being read
$!    WNW-S  A file that is not opened for write or append is being written
$!    UNU-S  A file that is not opened for read and write is being updated
$!    CNO-S  A file that is closed has no open statement
$!
$!  NOTE: There is no V2.2 --  A3.0 added sufficient functionality
$!        that the major version was bumped.
$!
$!  G2.2    20-Nov-2001             Charlie Hammond
$!          Make an "&" in a PIPE statement a warning.
$!          Re-word several ICF diagnostics.
$!          Include this in help.
$!
$!  F2.2    02-Aug-2001             Charlie Hammond
$!          Spelling corrections, mostly in comments, suggested
$!          by Norm.Raphael@jamesbury.com
$!
$!  E2.2    28-Jun-2001             Charlie Hammond
$!          Improve line number display in pass 2
$!          Display 1000, 2000, etc. instead of 500, 1500, etc.
$!          Also display line numbers in round 100's instead
$!          of actual numbers that could be off a bit.
$!
$!  D2.2    08-Jun-2001             Charlie Hammond
$!          Fix problem mistaking "CALL", "GOTO" and "GOSUB"
$!          at the end of a symbol name as a DCL command.
$!
$!  C2.2    31-May-2001             Charlie Hammond
$!          Fix problem with /END and /ERR on same line.
$!
$!  B2.2    22-Feb-2001             Charlie Hammond
$!          Fix problems with detecting various forms of $DECK and $EOD
$!
$!  A2.2    15-Aug-2000             Charlie Hammond
$!          Fix problem when first blank delimited token on line
$!          ends with ":" but is not a label.
$!
$!  V2.1    15-Aug-2000             Charlie Hammond
$!          Updated freeware release
$!
$!  H2.1    07-Aug-2000             Charlie Hammond
$!          Make ICF as warning for & and %
$!          Add information to ICF help.
$!
$!  G2.1    03-Aug-2000             Charlie Hammond
$!          Allow for a $ in a continued, "one-line" if statement.
$!          Avoid incorrect INT err that could happen if a PSQ error
$!              is found in a nested "one-line" if statement.
$!
$!  F2.1    02-May-2000             Charlie Hammond
$!          Add ICF invalid character found (#, %, ^ or &)
$!
$!  E2.1    24-Mar-2000             Charlie Hammond
$!          Improved EFB detection ("=" found between IF and THEN)
$!
$!  D2.1    13-Dec-1999             Charlie Hammond
$!          Improve detection of single quote errors
$!          Allow /OUT= on output file (P2)
$!
$!  B2.1    04-Dec-1999             Charlie Hammond
$!          Add LDS error -- Label defined by symbol substitution (warning)
$!          Fix single quote (') in definition of valid_lexicals
$!              It should be and now is a comma (,).
$!  A2.1    23-Oct-1999             Charlie Hammond
$!          Correct calculation of code_lines.
$!          We had been subtracting deck_lines twice.
$!
$!  V2.0    17-Sep-1999             Charlie Hammond
$!          For FREEWARE release
$!
$!  B2.0    31-Jul-1999             Charlie Hammond
$!          Correct handling of continuation comment that starts
$!              with only a "!" rather than "$!"
$!          Correct handling of SRT and INT errors.
$!              (SUBROUTINE/IF not terminated)
$!          "Beef up" a few help entries.
$!
$!  A2.0    28 July 1999            Charlie Hammond
$!          Improve handling for TNA/ENA/DNA
$!              (THEN/ELSE/ENDIF statement not allowed here)
$!          Make ENDSUBROUTINE cancel goto and exit shadows
$!          Handle SUBROUTINE and ENDSUBROUTINE
$!              IF/ENDIF and SUBR/ENDS may be disjoint or
$!              strictly nested -- they may not overlap
$!
$!  A1.0 - R1.0
$!          through October 1996    Charlie Hammond
$!          Many changes/additions
$!
$!  X-1     dd-mmm-1996             Charlie Hammond
$!          Original procedure created.
$!
$! ---------------------------------------------------------------------------
$!  This $DECK remains after DCLDIET is run to give a hint...
$DECK
    **************************************************************
    Enter the command @DCL_CHECK HELP for help with this procedure.
    **************************************************************
$EOD
$start:
$!
$!  Set defautl SAVED_LINE for possible errors that occur early
$   saved_line = 0
$!
$!  Make sure DCL verbs aren't unexpected symbols.
$!
$   set = "set"
$   set symbol /scope=(nolocal,noglobal)
$!
$!  Ensure that message text is being displayed
$!
$   sav_msg = f$environment("MESSAGE")
$   set message /TEXT
$!
$!  Set up to handle CTRL_Y and errors.
$!
$   sav_status = 1      ! Default to success
$!
$   on control_y then goto y_exit
$   on warning then goto err_exit
$!
$   pid = f$getjpi("","PID")    ! for unique file names
$!
$   say = "WRITE SYS$OUTPUT"
$!
$!  Define a symbol since the quote character (") is hard to
$!  handle as a literal
$   quote[0,8]=34
$!
$!  Also create a symbol for the single quote character (')
$   s_quote[0,8]=39
$!
$!  And a symbol for TWO single quotes in a row ('')
$   s2_quote = s_quote+s_quote
$!
$!  And, everybody's favorite, a symbol for "''F$FA"
$   s2_fao = s2_quote + "F$FA"
$   s2_upr = s2_quote + "F$"
$   s2_lwr = s2_quote + "f$"
$!
$!  Plus the exclamation point and form-feed character (<FF>)
$   exclaim[0,8]=33
$   form_feed[0,8] = 12
$!
$!  And a couple to help eliminate false UMP when DCL_CHECKing DCL_CHECK
$   if_lpar = "IF" + "("
$   rpar_then = ")" + "THEN"
$!
$!  Set a default for $EOD -- i.e. assume no /DOLLARS is in effect
$   d$w = "$EOD"
$   d$dollars = 0
$!
$!
$!  ------------------------------------------------------------------
$!
$   dcl_ck_vers = "V3.3"
$   say ""
$   say -
    "-*- Charlie Hammond's unsupported DCL checker (Version ''dcl_ck_vers') -*-"
$!
$!  Set up symbols to indicate that we are suppressing diagnostic messages.
$!  This avoids repeatedly translating the logicals.
$!
$   suppress_ANR = f$trnlnm("DCL_CHECK$SUPPRESS_ANR")
$   suppress_BL  = f$trnlnm("DCL_CHECK$SUPPRESS_BL")
$   suppress_CCN = f$trnlnm("DCL_CHECK$SUPPRESS_CCN")
$   suppress_CLD = f$trnlnm("DCL_CHECK$SUPPRESS_CLD")
$   suppress_CLS = f$trnlnm("DCL_CHECK$SUPPRESS_CLS")
$   suppress_CNO = f$trnlnm("DCL_CHECK$SUPPRESS_CNO")
$   suppress_CRE = f$trnlnm("DCL_CHECK$SUPPRESS_CRE")
$   suppress_CRG = f$trnlnm("DCL_CHECK$SUPPRESS_CRG")
$   suppress_DFB = f$trnlnm("DCL_CHECK$SUPPRESS_DFB")
$   suppress_DL  = f$trnlnm("DCL_CHECK$SUPPRESS_DL")
$   suppress_DNA = f$trnlnm("DCL_CHECK$SUPPRESS_DNA")
$   suppress_EFB = f$trnlnm("DCL_CHECK$SUPPRESS_EFB")
$   suppress_EFN = f$trnlnm("DCL_CHECK$SUPPRESS_EFN")
$   suppress_ENA = f$trnlnm("DCL_CHECK$SUPPRESS_ENA")
$   suppress_ICF = f$trnlnm("DCL_CHECK$SUPPRESS_ICF")
$   suppress_ICO = f$trnlnm("DCL_CHECK$SUPPRESS_ICO")
$   suppress_INR = f$trnlnm("DCL_CHECK$SUPPRESS_INR")
$   suppress_INT = f$trnlnm("DCL_CHECK$SUPPRESS_INT")
$   suppress_LC  = f$trnlnm("DCL_CHECK$SUPPRESS_LC")
$   suppress_LDS = f$trnlnm("DCL_CHECK$SUPPRESS_LDS")
$   suppress_LFF = f$trnlnm("DCL_CHECK$SUPPRESS_LFF")
$   suppress_LND = f$trnlnm("DCL_CHECK$SUPPRESS_LND")
$   suppress_LNF = f$trnlnm("DCL_CHECK$SUPPRESS_LNF")
$   suppress_LNR = f$trnlnm("DCL_CHECK$SUPPRESS_LNR")
$   suppress_LNS = f$trnlnm("DCL_CHECK$SUPPRESS_LNS")
$   suppress_LOD = f$trnlnm("DCL_CHECK$SUPPRESS_LOD")
$   suppress_MEC = f$trnlnm("DCL_CHECK$SUPPRESS_MEC")
$   suppress_NCL = f$trnlnm("DCL_CHECK$SUPPRESS_NCL")
$   suppress_NED = f$trnlnm("DCL_CHECK$SUPPRESS_NED")
$   suppress_NLN = f$trnlnm("DCL_CHECK$SUPPRESS_NLN")
$   suppress_OCE = f$trnlnm("DCL_CHECK$SUPPRESS_OCE")
$   suppress_ONA = f$trnlnm("DCL_CHECK$SUPPRESS_ONA")
$   suppress_ONC = f$trnlnm("DCL_CHECK$SUPPRESS_ONC")
$   suppress_ONW = f$trnlnm("DCL_CHECK$SUPPRESS_ONW")
$   suppress_PML = f$trnlnm("DCL_CHECK$SUPPRESS_PML")
$   suppress_PRQ = f$trnlnm("DCL_CHECK$SUPPRESS_PRQ")
$   suppress_PSQ = f$trnlnm("DCL_CHECK$SUPPRESS_PSQ")
$   suppress_PTL = f$trnlnm("DCL_CHECK$SUPPRESS_PTL")
$   suppress_RLI = f$trnlnm("DCL_CHECK$SUPPRESS_RLI")
$   suppress_RLS = f$trnlnm("DCL_CHECK$SUPPRESS_RLS")
$   suppress_RNA = f$trnlnm("DCL_CHECK$SUPPRESS_RNA")
$   suppress_RNR = f$trnlnm("DCL_CHECK$SUPPRESS_RNR")
$   suppress_SNT = f$trnlnm("DCL_CHECK$SUPPRESS_SNT")
$   suppress_TLS = f$trnlnm("DCL_CHECK$SUPPRESS_TLS")
$   suppress_TML = f$trnlnm("DCL_CHECK$SUPPRESS_TML")
$   suppress_TNA = f$trnlnm("DCL_CHECK$SUPPRESS_TNA")
$   suppress_TRH = f$trnlnm("DCL_CHECK$SUPPRESS_TRH")
$   suppress_UMB = f$trnlnm("DCL_CHECK$SUPPRESS_UMB")
$   suppress_UMP = f$trnlnm("DCL_CHECK$SUPPRESS_UMP")
$   suppress_UNU = f$trnlnm("DCL_CHECK$SUPPRESS_UNU")
$   suppress_UPQ = f$trnlnm("DCL_CHECK$SUPPRESS_UPQ")
$   suppress_USB = f$trnlnm("DCL_CHECK$SUPPRESS_USB")
$   suppress_USP = f$trnlnm("DCL_CHECK$SUPPRESS_USP")
$   suppress_WCT = f$trnlnm("DCL_CHECK$SUPPRESS_WCT")
$   suppress_WNW = f$trnlnm("DCL_CHECK$SUPPRESS_WNW")
$!
$get_help:
$!
$!  Make certain that P2 exists
$!
$   if f$type(p2) .eqs. "" then p2 = ""
$!
$   if f$edit(p1,"UPCASE") .nes. "HELP" then goto get_filename1
$!
$!  Invoke the DCL HELP utility
$!
$   help_dir = f$parse(F$ENVIRONMENT("PROCEDURE"),,,"DEVICE") -
    + f$parse(F$ENVIRONMENT("PROCEDURE"),,,"DIRECTORY")
$   define/user sys$input sys$output
$   if p2 .eqs. ""
$   then
$   help/libr='help_dir'dcl_check/nouser/prompt DCL_CHECK
$   else
$   help/libr='help_dir'dcl_check/nouser/prompt -
        'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8'
$   endif
$!
$!  Reset Params
$   p1 = ""
$   p2 = ""
$   p3 = ""
$   p4 = ""
$   p5 = ""
$   p6 = ""
$   p7 = ""
$   p8 = ""
$!
$!
$   say ""
$   say -
    "-*- Charlie Hammond's unsupported DCL checker (Version ''dcl_ck_vers') -*-"
$!
$! Get the name of the file to be checked
$!
$get_filename1:
$   get_file_count = 0  ! initialize counter
$get_filename:
$   if p1 .eqs. ""
$   then
$       if get_file_count .gt. 99
$       then
$           say ""
$           say "Too many attempts to input filename -- aborting..."
$           say ""
$           say "Do you have SYS$OUTPUT re-defined?"
$           say -
    " If so, you MUST supply the file to be checked on the command line!"
$           say ""
$           goto common_exit
$       endif
$       say ""
$       say "You can follow the name of the file to be checked with a name"
$       say "for the report file (default is SYS$OUTPUT). (blank separated)"
$       say ""
$!      Count how many times we get here
$       get_file_count = get_file_count + 1
$       read sys$output /end=common_exit /err=get_filename in$ -
            /prompt= -
            "enter name of file (or HELP or EXIT): "
$       in$ = f$edit(in$,"TRIM,COMPRESS")
$       if f$element(0," ",in$) .gts. " " then p1 = f$element(0," ",in$)
$       if f$element(1," ",in$) .gts. " " then p2 = f$element(1," ",in$)
$       if f$element(2," ",in$) .gts. " " then p3 = f$element(2," ",in$)
$       if f$element(3," ",in$) .gts. " " then p4 = f$element(2," ",in$)
$       if f$element(4," ",in$) .gts. " " then p5 = f$element(2," ",in$)
$       if f$element(5," ",in$) .gts. " " then p6 = f$element(2," ",in$)
$       if f$element(6," ",in$) .gts. " " then p7 = f$element(2," ",in$)
$       if f$element(7," ",in$) .gts. " " then p8 = f$element(2," ",in$)
$       goto get_filename
$   endif
$!
$!  create a usage log for DCL_CHECK
$!
$!$   comm_dir = f$parse(F$ENVIRONMENT("PROCEDURE"),,,"DEVICE") -
$!        + f$parse(F$ENVIRONMENT("PROCEDURE"),,,"DIRECTORY")
$!$   if f$search("''comm_dir'dcl_check.access_log") .eqs. "" -
$!        then create 'comm_dir'dcl_check.access_log
$!$   open/error=start/append/share access$log 'comm_dir'dcl_check.access_log
$!$   write access$log f$fao("!%D !12AS !AS",0,f$getjpi(0,"USERNAME"),p1)
$!$   close access$log
$!
$   if f$edit(p1,"UPCASE") .eqs. "HELP" then goto get_help
$   if f$edit(p1,"UPCASE") .eqs. "EXIT" then goto common_exit
$!
$!  P1 may not contain wildcard characters  (*, % or ?)
$!  Note that ^% is not a wildcard.
$!
$   wild$work = p1
$wild$loop:
$   if f$locate("^%",wild$work) .lt. f$length(wild$work)
$   then
$       wild$work = wild$work - "^%"
$       goto wild$loop
$   endif
$   if  ( (f$locate("*",wild$work) .lt. f$length(wild$work) ) -
    .or.  (f$locate("%",wild$work) .lt. f$length(wild$work) ) -
    .or.  (f$locate("?",wild$work) .lt. f$length(wild$work) ) )
$   then
$       say ""
$       say "*** ''P1'"
$       say "*** wildcards not suported!"
$       p1 = ""
$       goto get_filename
$   endif
$!
$!   dcl$file = f$parse(p1,".COM")
$!!
$   dcl$file = p1
$   if f$search (dcl$file,111) .eqs. ""
$   then
$       dcl$file = p1 + ".COM"
$       if f$search (dcl$file,222) .eqs. ""
$       then
$           dcl$file = f$parse (p1,".COM",,,"SYNTAX_ONLY")
$       endif
$   endif
$!!
$   if f$search(dcl$file) .eqs. ""
$   then
$       say "*** Cannot find ''dcl$file'"
$       p1 = ""
$       goto get_filename
$   endif
$   dcl$file = f$search(dcl$file)
$!
$   if p2 .nes. ""
$   then
$       if f$parse(p2,".LIS") .eqs. ""
$       then
$       say ""
$           say "*** ""''p2'"" is not a valid report filename"
$           p1 = ""
$           p2 = ""
$           goto get_filename
$       endif
$   endif
$!
$!  Check if PIPE is available on this verisn of OpenVMS
$!  PIPE was introduced in OpenVMS V7.1
$!
$   use_pipe = 0        ! default to zero (0) -- no pipe
$!  Get OpenVMS major version
$   mvmsv = f$element(0,".",f$extract(1,8,f$getsyi("VERSION")))
$   if mvmsv .lt. 7
$   then
$       use_pipe = 0        ! set to zero (0) -- no pipe
$       goto after_pipe_check
$   endif
$!
$   if mvmsv .eq. 7
$   then
$!      get Openvms minor version
$       nvmsv = -
        f$element(0,"-",f$element(1,".",f$extract(1,8,f$getsyi("VERSION"))))
$       if nvmsv .eq. 0
$       then
$           use_pipe = 0        ! set to zero (0) -- no pipe
$       else
$           use_pipe = 1        ! set to one (1) -- use pipe
$       endif
$       goto after_pipe_check
$   endif
$!
$   if mvmsv .gt. 7
$   then
$       use_pipe = 1        ! set to one (1) -- use pipe
$       goto after_pipe_check
$   endif
$!
$after_pipe_check:
$!
$   dcl_ck_time = f$time()
$   say "Checking file ''dcl$file'"
$   say "''dcl_ck_time'"
$   say ""
$!
$   say "Checking for DCL_CHECK$ logicals..."
$   if use_pipe
$   then
$       pipe sho log DCL_CHECK$* | sear sys$input DCL_CHECK$
$   else
$       sho log DCL_CHECK$*
$   endif
$   say ""
$!
$!
$!  Open the error file -- this will later be used to create the listing.
$!
$!  Attempt to close it in case it was left open
$   close/err=open_error1 err_file
$open_error1:
$!  delete any "left over" error files
$   if f$search("sys$scratch:dcl$error_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$error_'pid'.tmp;*
$!
$!  Use CREATE and OPEN/APPEND instead of OPEN/WRITE because CREATE
$!      results in the desired file characteristics.
$   create sys$scratch:dcl$error_'pid'.tmp
$   open /append err_file sys$scratch:dcl$error_'pid'.tmp
$!
$!  Create and open an indexed file to contain names of all labels defined
$!  Format of this file is:
$!
$!      xnnnnnlll...
$!
$!          x       -- 0 initially; 1 when label is referenced
$!          nnnnn   -- Five digit (ASCII) line number
$!          lll...  -- The label (max of 255 chars)
$!                     This is the key (Ascending String)
$!
$!  Attempt to close it in case it was left open
$   close/err=open_label1 label_file
$open_label1:
$!  delete any "left over" label files
$   if f$search("sys$scratch:dcl$label_''pid'.idx") .nes. "" then -
        delete /nolog sys$scratch:dcl$label_'pid'.idx;*
$!
$   create /fdl=sys$input sys$scratch:dcl$label_'pid'.idx
$DECK
FILE
        ORGANIZATION            indexed
RECORD
        CARRIAGE_CONTROL        carriage_return
        FORMAT                  variable
        SIZE                    261
AREA 0
        ALLOCATION              54
        BEST_TRY_CONTIGUOUS     yes
        BUCKET_SIZE             9
        EXTENSION               27
AREA 1
        ALLOCATION              9
        BEST_TRY_CONTIGUOUS     yes
        BUCKET_SIZE             9
        EXTENSION               9
KEY 0
        CHANGES                 no
        DATA_AREA               0
        DATA_FILL               100
        DATA_KEY_COMPRESSION    yes
        DATA_RECORD_COMPRESSION yes
        DUPLICATES              yes
        INDEX_AREA              1
        INDEX_COMPRESSION       yes
        INDEX_FILL              100
        LEVEL1_INDEX_AREA       1
        PROLOG                  3
        SEG0_LENGTH             255
        SEG0_POSITION           6
        TYPE                    string
$EOD
$!
$   open /read /write label_file sys$scratch:dcl$label_'pid'.idx
$!
$!
$!  Create and open an indexed file to contain information about
$!  "file operations" -- OPEN, CLOSE, READ and WRITE
$!  Format of this file is:
$!
$!      iaorwuclll...
$!              (iaorwuc are 0 if the action not found, and 1 if it is)
$!          i       -- OPEN for Input (/READ -- default)
$!          a       -- OPEN for APPEND
$!          o       -- OPEN for Output (/WRITE)
$!          r       -- READ
$!          w       -- WRITE (w/o /UPDATE)
$!          u       -- WRITE /UPDATE
$!          c       -- Close
$!          lll...  -- The logical name used to reference the file
$!                     (max of 255 chars)
$!                     This is the key (Ascending String)
$!
$!  Attempt to close it in case it was left open
$   close/err=open_file_file file_file
$open_file_file:
$!  delete any "left over" file files
$   if f$search("sys$scratch:dcl$file_''pid'.idx") .nes. "" then -
        delete /nolog sys$scratch:dcl$file_'pid'.idx;*
$!
$   create /fdl=sys$input sys$scratch:dcl$file_'pid'.idx
$DECK
FILE
        ORGANIZATION            indexed

RECORD
        CARRIAGE_CONTROL        carriage_return
        FORMAT                  variable
        SIZE                    262

AREA 0
        ALLOCATION              30
        BEST_TRY_CONTIGUOUS     yes
        BUCKET_SIZE             6
        EXTENSION               12

AREA 1
        ALLOCATION              6
        BEST_TRY_CONTIGUOUS     yes
        BUCKET_SIZE             6
        EXTENSION               6

KEY 0
        CHANGES                 no
        DATA_AREA               0
        DATA_FILL               100
        DATA_KEY_COMPRESSION    yes
        DATA_RECORD_COMPRESSION yes
        DUPLICATES              no
        INDEX_AREA              1
        INDEX_COMPRESSION       yes
        INDEX_FILL              100
        LEVEL1_INDEX_AREA       1
        PROLOG                  3
        SEG0_LENGTH             255
        SEG0_POSITION           7
        TYPE                    string
$EOD
$!
$   open /read /write file_file sys$scratch:dcl$file_'pid'.idx
$!
$!  Create and open an indexed file to contain the line number range
$!  of all multi-line IF/THEN/ELSE statements.
$!  Format of this file is:
$!
$!      iiiiieeeee
$!
$!          iiiii   -- Five digit (ASCII) line number of the IF
$!                     This is the key (Descending String)
$!          eeeee   -- Five digit (ASCII) line number of the ENDIF
$!
$!  Attempt to close it in case it was left open
$   close/err=open_if1 if_file
$open_if1:
$!  delete any "left over" if files
$   if f$search("sys$scratch:dcl$if_''pid'.idx") .nes. "" then -
        delete /nolog sys$scratch:dcl$if_'pid'.idx;*
$!
$   create /fdl=sys$input sys$scratch:dcl$if_'pid'.idx
$DECK
FILE
        ORGANIZATION            indexed
RECORD
        CARRIAGE_CONTROL        carriage_return
        FORMAT                  fixed
        SIZE                    11
AREA 0
        ALLOCATION              6
        BEST_TRY_CONTIGUOUS     yes
        BUCKET_SIZE             3
        EXTENSION               3
AREA 1
        ALLOCATION              3
        BEST_TRY_CONTIGUOUS     yes
        BUCKET_SIZE             3
        EXTENSION               3
KEY 0
        CHANGES                 no
        DATA_AREA               0
        DATA_FILL               100
        DATA_KEY_COMPRESSION    no
        DATA_RECORD_COMPRESSION no
        DUPLICATES              no
        INDEX_AREA              1
        INDEX_COMPRESSION       no
        INDEX_FILL              100
        LEVEL1_INDEX_AREA       1
        PROLOG                  3
        SEG0_LENGTH             5
        SEG0_POSITION           0
        TYPE                    dstring
$EOD
$!
$   open /read /write if_file sys$scratch:dcl$if_'pid'.idx
$!
$!  Open the intermediate work file
$!  This will be a copy of the input file with the statement number
$!  added at the beginning, with comments removed, with quoted strings
$!  removed, with $DECK/$EODgroups removed, and with any records that
$!  are blank (except for starting $, $! or "$ !) removed.
$!
$!  Attempt to close it in case it was left open
$   close/err=open_work1 work_file
$open_work1:
$!  delete any "left over" work files
$   if f$search("sys$scratch:dcl$work_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$work_'pid'.tmp;*
$!
$!  Use CREATE and OPEN/APPEND instead of OPEN/WRITE because CREATE
$!      results in the desired file characteristics.
$   create sys$scratch:dcl$work_'pid'.tmp
$   open /append work_file sys$scratch:dcl$work_'pid'.tmp
$!
$!  Now open the DCL file to be checked for the first pass.
$!
$!  Attempt to close it in case it was left open
$   close/err=open_dcl1 dcl_file
$open_dcl1:
$   open /read dcl_file 'dcl$file'
$!
$!  "Initialize" some symbols
$!
$   exit_shadow = 0     ! lines are not reachable due to preceding EXIT
$   goto_shadow = 0     ! lines are not reachable due to preceding GOTO
$   call$call = 0       ! Assume it is NOT a "CALL"
$!
$   line_number = 0     ! line (record) number w/i DCL procedure
$   total_lines = 0     ! save count of total lines
$   code_lines = 0      ! save count of code lines
$   commented_code_lines = 0    ! save count of code lines w/comments
$   continuation_lines = 0      ! save count of continuation lines
$   deck_lines = 0      ! save count of lines w/i $DECK/$EOD pairs
$   comment_lines = 0   ! save count of comment lines
$   blank_lines = 0     ! save count of blank lines
$   in_deck = 0         ! indicates that we aren't within a $DECK/$EOD
$   deck_line = 0       ! line number of last valid $DECK
$!
$   if_level = 0        ! IF nesting level (index into then_ and else_level)
$!  IF_LEVEL tracks the combined levels of IF and SUBROUTINES.
$!  SR_LEVEL counts how many of IF_LEVEL are SUBROUTINES.
$   sr_level = 0
$!
$   if_lines = ""       ! line numbers of prior if statements
$!  then_ and else_level[if_level,1] = 1 when if/then is found
$   then_level = "000000000000000000000"    ! (level 1 is always satisfied)
$   else_level = "000000000000000000000"    ! (level 1 is always satisfied)
$!  ifsr_level[if_level,1] = "I" or "S" for IF or SUBROUTINE
$   ifsr_level = "000000000000000000000"
$!
$   valid_lexicals = -
    "F$CONTEXT,F$CSID,F$CVSI,F$CVTIME,F$CVUI,F$DELTA_TIME,F$DEVICE,F$DIRECTORY," + -
    "F$EDIT,F$ELEMENT,F$ENVIRONMENT,F$EXTRACT,F$FAO,F$FILE_ATTRIBUTES," + -
    "F$GETENV,F$GETDVI,F$GETJPI,F$GETQUI,F$GETSYI,F$IDENTIFIER,F$INTEGER," + -
    "F$LENGTH,F$LOCATE,F$LOGICAL,F$MESSAGE,F$MODE,F$PARSE,F$PID," + -
    "F$PRIVILEGE,F$PROCESS,F$SEARCH,F$SETPRV,F$STRING,F$TIME,F$TRNLNM," + -
    "F$TYPE,F$USER,F$VERIFY"
$   length_valid_lexicals = f$length(valid_lexicals)
$!
$!
$   Say "Starting Pass 1 -- ''f$time()' ..."
$!
$!  This pass reads the DCL file and does the following:
$!
$!      Copies the file leaving out
$!          comments
$!          $DECKs
$!          quoted strings
$!          Blank lines
$!
$!      collects LABEL info and FILE info (open/close/read/write)
$!
$!      Checks for
$!
$!  BL--I  blank line (warning)
$!  CCN-I  Continuation character (""-"") not preceded by space (warning)
$!  CLD-S  continuation line starts with ""$""
$!  CLS-I  comment line separates continuation line (warning)
$!  CRE-W  code cannot be reached due to EXIT at line !UL
$!  CRG-W  code cannot be reached due to GOTO at line !UL
$!  DFB-I  $DECK found between $DECK and $EOD
$!  DL--E  duplicate label ""!AS""
$!  DNA-S  ENDIF statement not allowed here
$!  EFB-S  ""="" found between IF and THEN
$!  EFN-W  $EOD found with no corresponding $DECK
$!  ENA-S  ELSE statement not allowed here
$!  INT-S  IF statement not terminated
$!  LDS-I  Label ""!AS"" defined by symbol substitution (warning)
$!  LFF-I  line contains only form-feed (<FF>)
$!  LND-E  line does not start with ""$""
$!  LOD-I  line contains only ""$"" (warning)
$!  MEC-S  missing expression for comparison
$!  NCL-S  no continuation line at EOF
$!  NED-S  no $EOD for $DECK at !UL
$!  PML-E  possible misspelled lexical (!AS)
$!  PRQ-E  probable error using single-quote (')
$!  PSQ-W  possible error using single-quote (') in quoted string
$!  PTL-E  possible truncated lexical (!AS)
$!  RNA-S  ENDSUBROUTINE statement not allowed here
$!  SNT-S  SUBROUTINE statement not terminated
$!  TML-S  too many levels of IF statements
$!  TMS-S  too many levels of IF and SUBROUTINE statements
$!  TNA-S  THEN statement not allowed here
$!  TRH-S  THEN statement required here
$!  UMP-S  unmatched parentheses
$!  UPQ-S  unpaired quotation marks ("")
$!  WCT-E  wrong constant type for comparison
$!
$   line_disply_increment = 500
$   line_to_display = line_disply_increment
$read_dcl1:
$!
$   read /end=end_dcl1 dcl_file dcl_record
$!  count line (record) numbers
$   line_number = line_number + 1   ! count every record
$   saved_line = line_number        ! save number in case line is continued
$!
$   if line_number .gt. line_to_display
$   then
$       say f$fao("...processing line number !UL...",line_to_display)
$       line_to_display = line_to_display + line_disply_increment
$   endif
$!
$!  Insert any diagnostic comments into err_file.
$!
$!  Lines that look like this:
$!
$!      $! DCL_CHECK COMMENT: <comment-text>
$!               111111111122
$!     0123456789012345678901
$!
$!  are diagnostic comments to be inserted into the error file.
$!
$   if f$edit(f$element(0,":",dcl_record),"TRIM,COLLAPSE,UPCASE") -
    .EQS. "$!DCL_CHECKCOMMENT"
$   then
$       dcl_comment = dcl_record - f$element(0,":",dcl_record) - ":"
$       write err_file f$fao( -
                "!5UL  -CMNT-!AS",saved_line,dcl_comment)
$       goto read_dcl1
$   endif
$!
$!  remove comments and trim/compress/upcase the line, check if in a deck
$!
$   if in_deck
$   then
$       dcl_record = f$edit(dcl_record,"COMPRESS,UPCASE")
$       deck_lines = deck_lines + 1     ! Count lines in $DECK/$EOD pair
$!
$   else ! not in deck
$!
$       dcl_record = f$edit(dcl_record,"TRIM,COMPRESS,UPCASE")
$!
$!      Check for line containing only "$"
$       if dcl_record .eqs. "$"
$       then
$           if .not. suppress_LOD then write err_file f$fao( -
                "!5UL  LOD-I  line contains only ""$"" (warning)", -
                 saved_line)
$           goto read_dcl1 ! No more checking required
$       endif
$!
$!      Check for a blank lines
$       if dcl_record .eqs. ""
$       then
$           if .not. suppress_BL then write err_file f$fao( -
                "!5UL  BL--I  blank line (warning)", -
                 saved_line)
$           blank_lines = blank_lines + 1       ! Count blank_lines
$           goto read_dcl1 ! No more checking required
$       endif
$!
$!      Check for lines that contain only form-feed
$       if dcl_record .eqs. form_feed
$       then
$           if .not. suppress_LFF then write err_file f$fao( -
                "!5UL  LFF-I  line contains only form-feed (<FF>)", -
                 saved_line)
$           goto read_dcl1 ! No more checking required
$       endif
$!
$!      Check for lines that are only comments
$       if  ( (f$extract(0,2,dcl_record) .eqs. "$!") -
        .or.  (f$extract(0,3,dcl_record) .eqs. "$ !") )
$       then
$!          Is that ALL the line contains?
$           if  ( (dcl_record .eqs. "$!") -
            .or.  (dcl_record .eqs. "$ !") )
$           then    ! Its a blank line
$               blank_lines = blank_lines + 1       ! Count blank lines
$           else    ! Its a comment line
$               comment_lines = comment_lines + 1   ! Count comment lines
$           endif
$           goto read_dcl1 ! No more checking required
$       endif
$!
$   endif
$!
$!  Get the first two tokens on the line
$!  "$" and leading space has been removed from DCL_RECORD at this point
$   t0 = f$element(0," ",dcl_record)
$   t0 = f$element(0,"/",t0)
$   t1 = f$edit(dcl_record - t0,"TRIM")
$!
$!  Check for $DECK and $EOD -- don't write these lines
$!  NOTE: $DECK and $EOD command may NOT include labels
$!        and may NOT be nested.
$!
$   if ( (t0 .eqs. "$DECK") -
    .or. ( (t0 .eqs. "$") .and. (t1 .eqs. "DECK") ) )
$   then
$       if in_deck
$       then
$           if .not. suppress_DFB then write err_file f$fao( -
                    "!5UL  DFB-I  $DECK found between $DECK and ''d$w'", -
                    saved_line)
$           if (.not. suppress_NED) .and. (.not. d$dollars) -
                then write err_file f$fao( -
                    "!5UL  NED-S  no ''d$w' for $DECK at line !UL", -
                    saved_line,deck_line)
$       else
$           in_deck = 1
$           deck_line = saved_line
$!
$!          Check for /DOLLARS
$           d$w = f$edit(dcl_record,"COLLAPSE,UNCOMMENT") - "$DECK"
$           d$w = f$element(1,"=",d$w) - """" - """"
$           if d$w .eqs. "="
$           then                ! no /DOLLARS
$               d$w = "$EOD"    !   assume the default
$               d$dollars = 0   !   Remember we found /DOLLARS
$           else                ! /DOLLARS FOUND
$!                              !   user the value found in d$w
$               d$dollars = 1   !   remember we did not find /DOLLARS
$           endif
$!
$       endif
$!      $DECK, $EOD and lines in a "deck" are not continued and are
$!      not written to the intermediate file.
$       goto read_dcl1
$   endif
$!
$   if ( ( (d$dollars) .and. (t0 .eqs. "''d$w'") )  -
    .or. ( (.not. d$dollars) .and. (t0 .eqs. "''d$w'") ) -
    .or. ( (.not. d$dollars) .and. (t0 .eqs. "$") .and. (t1 .eqs. "EOD") ) )
$   then
$       if in_deck
$       then
$           in_deck = 0
$           d$w = "EOD"
$           deck_lines = deck_lines - 1     ! already counted but should not be
$       else
$           if .not. suppress_EFN then write err_file f$fao( -
                "!5UL  EFN-W  $EOD found with no corresponding $DECK", -
                saved_line)
$       endif
$!      $DECK, $EOD and lines in a "deck" are not continued and are
$!      not written to the intermediate file.
$       goto read_dcl1
$   endif
$!
$!  $DECK, $EOD and lines in a "deck" are not continued and are
$!  not written to the intermediate file.
$   if in_deck then goto read_dcl1
$!
$!
$read_dcl1_c:
$!
$!  Loose "!" from ''F$FA....'
$!
$!  We want to uncomment the dcl record,
$!  But first we must deal with a problem that F$EDIT has with
$!  exclamation marks used for formatting directives in F$FAO control strings.
$!  This only occurs when the F$FAO is preceded by two single quotes
$!  indicating symbol substitution within a quoted string.   e.g.
$!
$!      $ write sys$output "Value is: ''f$fao("!4UL",value)'"
$!
$!  (This may not be good coding practice, but it IS used.)
$!
$!  If a line contains the string "''F$FA" then we will remove any and ALL
$!  exclamation marks from the "''F$FA" to the second occurrence of a
$!  single double-quote (") character.  The first double-quote starts the
$!  control string; the next SINGLE double-quote ends the control string.
$!  (The control string could contain DOUBLE double-quotes ("") representing
$!  output of a single double-quote.)
$!
$!  Of course we only need to do all this if the line contains at least
$!  one instance of "''F$FA" -- so, lets check.
$!  Since is in a quoted string, it may be any combination of upper/lower case.
$!
$   x = f$locate(s2_lwr,dcl_record)
$   if f$edit(f$extract(x,6,dcl_record),"UPCASE") .eqs. s2_fao -
        then goto do_fao
$!
$   x = f$locate(s2_upr,dcl_record)
$   if f$edit(f$extract(x,6,dcl_record),"UPCASE") .eqs. s2_fao -
        then goto do_fao
$!
$!  If no more instances of ;''F$+, we're done
$   goto after_fao_check
$!
$!  Otherwise we gotta do it...
$!
$do_fao:
$!
$   x = x + 2   ! to get all through ''
$   work = f$extract (0,x,dcl_record) + "X$"    ! get the beginning of the rec
$   x = x + 2   ! to allow for the "F$" replaced by "X$"
$!
$   q_count = 0
$   next_char = f$extract(x,1,dcl_record)
$   x = x + 1
$fao_loop:
$!
$!  Are we done?
$!
$   if q_count .ge. 2
$   then    ! we're done with this ''F$
$!      Get the rest of the line
$       work = work + f$extract(x,f$length(dcl_record)-x,dcl_record)
$       dcl_record = work
$!      Loop back to check if there is another F$F to check
$       goto read_dcl1_c
$   endif
$!
$!  Check the character
$   char = next_char
$   next_char = f$extract(x,1,dcl_record)
$   x = x + 1
$!
$   if char .eqs. quote
$   then
$!
$       if next_char .eqs. quote
$       then    ! it's a double double-quote -- copy it
$           work = work + quote + quote
$!          Cycle through the second quote
$           next_char = f$extract(x,1,dcl_record)
$           x = x + 1
$!
$       else    ! it's a single double-quote -- copy and increment q_count
$           work = work + quote
$           q_count = q_count + 1
$!
$       endif
$!
$   else    ! just copy the char, except exclamation point
$       if char .nes. exclaim then work = work + char
$!
$   endif
$!
$!  This loops if there is a missing closing quote, so...
$!  (a smaller number than 1024 would probably do...)
$   if x .ge. 1024 then q_count = q_count + 1
$!
$   goto fao_loop
$!
$after_fao_check:
$!
$!  Now we can safely uncomment the line
$   work = f$edit(dcl_record,"UNCOMMENT,TRIM")
$   if work .nes. dcl_record
$   then
$       commented_code_lines = commented_code_lines + 1
$       dcl_record = work
$   endif
$!
$!  check for continuation
$read_continuation:
$   if f$extract(f$length(dcl_record)-1,1,dcl_record) .eqs. "-"
$   then    ! the line IS continued
$       yes_cont = 1
$       read /end=no_cont dcl_file dcl_c_record
$       line_number = line_number + 1
$       work = f$edit(dcl_c_record,"TRIM,COMPRESS")
$       goto yes_cont
$no_cont:
$       work = ""
$       yes_cont = 0
$yes_cont:
$       if f$extract(0,2,work) .nes. "/"
$       then
$! DCL_CHECK COMMENT: USP O.K. in hext line
$           if  ( (f$extract(f$length(dcl_record)-2,2,dcl_record) .nes. " -") -
            .and. (f$extract(f$length(dcl_record)-2,2,dcl_record) .nes. ",-") -
            .and. (f$extract(f$length(dcl_record)-2,2,dcl_record) .nes. ")-") )
$           then
$!
$!          If there is no space  preceding  the  continuation
$!          character  ("-"), and there is no space at the beginning of the
$!          continuation line, this can result in keywords, qualifiers  or
$!          parameters being incorrectly concatenated.
$!          DCLDIETing a command procedure can cause these condition because
$!          DCLDIET removes all space at the beginning of the continuation line.
$!
$           if .not. suppress_CCN then write err_file f$fao( -
  "!5UL  CCN-I  Continuation character (""-"") not preceded by space (warning)", -
                line_number)
$           endif
$       endif
$       if .not. yes_cont then goto end_dcl1_c
$!      Remove the trailing "-"
$       dcl_record = f$extract(0,f$length(dcl_record)-1,dcl_record)
$!
$!      Check if it is a comment only
$       if ( (f$extract(0,2,work) .eqs. "$!") -
        .or. (f$extract(0,3,work) .eqs. "$ !") -
        .or. (f$extract(0,1,work) .eqs. "!") )
$       then    ! It is a comment only -- issue warning and skip it.
$               ! This condition causes DCLDIET to output invalid code.
$           if .not. suppress_CLS then write err_file f$fao( -
                "!5UL  CLS-I  comment line separates continuation line (warning)", -
                line_number)
$           comment_lines = comment_lines + 1
$           work = f$edit(dcl_c_record,"TRIM,COMPRESS")
$           goto read_continuation
$       endif
$       continuation_lines = continuation_lines + 1   ! count continuation lines
$!
$!       if f$extract(0,1,dcl_c_record) .eqs. "$" .and. -
$!        f$edit(f$extract(f$length(dcl_record)-6,6,dcl_record),"upcase,trim") -
$!        .nes. "THEN"
$!
$       if f$extract(0,1,dcl_c_record) .eqs. "$"
$       then
$           if .not. suppress_CLD then write err_file f$fao( -
                "!5UL  CLD-S  continuation line starts with ""$""", -
                line_number)
$       endif
$       dcl_record = dcl_record + dcl_c_record
$!      trim/compress/upcase the line
$       dcl_record = f$edit(dcl_record,"TRIM,COMPRESS,UPCASE")
$       goto read_dcl1_c
$   endif
$!
$!  Check DCL line for balanced (left/right) parentheses and
$!  brackets.  We check the parts of the statement inside and outside quoted
$!  strings separately.
$!
$!  For statement outside of quoted string:
$!      Demand left and right balance, and demand each left precede
$!      its matching right
$!  For part of statement within quoted string:
$!      Ignore singleton strings (see details below);
$!      Demand left and right balance, but make no requirement that
$!          each left precede a matching right
$!
$!  If there are any parens/brackets in the string, we go thru and
$!  collect characters from non-quoted string and quoted-string
$!  part separately, omitting any singleton strings from the
$!  the quoted-string collection.
$!
$!  Note on singleton strings:
$!      x=a+")"+a       ! is considered singleton ")"
$!      x=a+"..."")"+a  ! is NOT considered singleton ")"
$!      x=a+"(""..."+a  ! is NOT considered singleton "("
$!
$   if  (dcl_record - "(" - ")" - "[" - "]") .nes. dcl_record
$   then
$       ump_fail = 0  ! tentatively assume UMP test passes
$       umb_fail = 0  ! tentatively assume UMB test passes
$       usp_fail = 0  ! tentatively assume USP test passes
$       usb_fail = 0  ! tentatively assume USB test passes
$!
$       dcl_work1 = ""  ! string to accumulate non-quoted parts of DCL line
$       dcl_work2 = ""  ! string to accumulate quoted parts (except singletons)
$       n = 0
$!
$!  Separate the command line into two strings, that part inside and outside
$!  quoted strings.  We ignore 'singleton' quoted strings.
$!
$split_quotstr:
$       str0 = f$element (n,"""",dcl_record)  ! an element of non-quoted part
$       if  str0 .nes. """"
$       then
$           dcl_work1 = dcl_work1 + str0
$!
$           str1 = f$element (n+1,"""",dcl_record)  ! an element of quoted part
$           if  str1 .nes. """"
$           then
$!
$               if  f$length(str1) .ne. 1
$               then
$                   dcl_work2 = dcl_work2 + str1
$               else
$                   if str0 .eqs. "" .or. -
                    (f$element (n+2,"""",dcl_record) .eqs. "" .and. -
                    f$element (n+3,"""",dcl_record) .nes. """")
$                   then
$                       dcl_work2 = dcl_work2 + str1
$                   endif
$               endif
$!
$               n = n + 2
$               goto split_quotstr
$           endif
$       endif
$!
$!  For the non-quoted string, we flag an error if either the
$!  count of left and right delimiters does not match or
$!  if a left delimiter does not precede its matching right delimiter.
$!  For the quoted string, we do only the count test, not the
$!  order test.
$!
$!  First, check the non-quoted string for parentheses balance, if necessary.
$!
$       if  (dcl_work1 - "(" - ")") .nes. dcl_work1
$       then
$           nl = 0  ! count of left delimiter so far
$           nr = 0  ! count of right delimiter so far
$!
$next_lparen_elem:
$           str = f$element (nl,"(",dcl_work1)
$           if  str .nes. "("
$           then
$!
$               if  f$locate (")",str) .ne. f$length (str)
$               then
$                   n = 2
$!
$next_rparen_subelem:
$                   if f$element (n,")",str) .nes. ")"
$                   then
$                       n = n + 1
$                       goto next_rparen_subelem
$                   endif
$!
$                   nr = nr + n-1
$                   if nr .gt. nl  then ump_fail = 1  ! parentheses out of order
$!
$               endif  ! if there are any ")" in this element of dcl_work1
$!
$               nl = nl + 1
$               goto next_lparen_elem
$!
$           endif  ! if there is more text to scan in dcl_work1
$!
$           if  nr .ne. nl-1  then ump_fail = 1  ! parentheses unbalanced
$!
$       endif  ! if there are any parentheses in dcl_work1
$!
$!
$!  Now check the non-quoted string for bracket balance, if necessary.
$!
$       if  (dcl_work1 - "[" - "]") .nes. dcl_work1
$       then
$           nl = 0  ! count of left delimiter so far
$           nr = 0  ! count of right delimiter so far
$!
$next_lbracket_elem:
$           str = f$element (nl,"[",dcl_work1)
$           if  str .nes. "["
$           then
$!
$               if  f$locate ("]",str) .ne. f$length (str)
$               then
$                   n = 2
$!
$next_rbracket_subelem:
$                   if f$element (n,"]",str) .nes. "]"
$                   then
$                       n = n + 1
$                       goto next_rbracket_subelem
$                   endif
$!
$                   nr = nr + n-1
$                   if nr .gt. nl  then umb_fail = 1  ! brackets out of order
$!
$               endif  ! if there are any "]" in this element of dcl_work1
$!
$               nl = nl + 1
$               goto next_lbracket_elem
$!
$           endif  ! if there is more text to scan in dcl_work1
$!
$           if  nr .ne. nl-1  then umb_fail = 1  ! brackets unbalanced
$!
$       endif  ! if there are any brackets in dcl_work1
$!
$!
$!  Now check the quoted string for parenthesis balance, if necessary.
$!
$       if  (dcl_work2 - "(" - ")") .nes. dcl_work2
$       then
$           n = 1
$count_lparen:
$           if  f$element (n,"(",dcl_work2) .nes. "("
$           then
$               n = n + 1
$               goto count_lparen
$           endif
$!
$           usp_fail = f$element (n,  ")",dcl_work2) .nes. ")" .or. -
               f$element (n-1,")",dcl_work2) .eqs. ")"
$!
$       endif  ! if any parentheses in quoted string part of dcl line
$!
$!  Now check the quoted string for bracket balance, if necessary.
$!
$       if  (dcl_work2 - "[" - "]") .nes. dcl_work2
$       then
$           n = 1
$count_lbrack:
$           if  f$element (n,"[",dcl_work2) .nes. "["
$           then
$               n = n + 1
$               goto count_lbrack
$           endif
$!
$           usb_fail = f$element (n,  "]",dcl_work2) .nes. "]" .or. -
                f$element (n-1,"]",dcl_work2) .eqs. "]"
$!
$       endif   ! if any brackets in quoted string part of dcl line
$!
$!
$!  All four unbalanced delimiter tests have been made; report any failures.
$!
$   if ump_fail
$   then
$       if .not. suppress_UMP then write err_file f$fao( -
        "!5UL  UMP-S  unmatched parentheses (not in quoted string)", -
        saved_line)
$   endif
$!
$       if umb_fail
$       then
$           if .not. suppress_UMB then write err_file f$fao( -
            "!5UL  UMB-S  unmatched brackets (not in quoted string)", -
            saved_line)
$       endif
$!
$       if usp_fail
$       then
$           if .not. suppress_USP then write err_file f$fao( -
            "!5UL  USP-W  unmatched parentheses in quoted string", -
            saved_line)
$       endif
$!
$       if usb_fail
$       then
$           if .not. suppress_USB then write err_file f$fao( -
            "!5UL  USB-W  unmatched brackets in quoted string", -
            saved_line)
$       endif
$!
$   endif   ! if any paren/brack in full dcl line
$!
$!
$!  Normaly there is space before and after the comparison operators,
$!      ".eq.", ".ge.", ".gt.", ".le.", ".lt.", ".ne."  (numeric),
$!  and
$!      ".eqs.", ".ges.", ".gts.", ".les.", ".lts.", ".nes.", (string),
$!  and the logical operators,
$!      ".and.", ".or.", and ".not.".
$!  However, DCL does not require this and some code takes advantage
$!  of this, which "confuses" DCL_CHECK.
$!  So we will make sure there is a space before and after
$!  each of these operators.
$!
$!
$!  (The following code provided by Ed Miller --  esm@slac.stanford.edu)
$!  (code has been reformated slightly.)
$!
$!  The code following may add or remove blanks from dcl_record
$!  in order to avoid invalid error reports that may otherwise
$!  occur in the syntax checking which follows.
$!
$!  The first such change is applied only to statements with lexicals.
$!  If unnecessary blanks are not removed from lexical function
$!  references, under certain circumstances invalid PRQ or WCT
$!  diagnostics will be generated.  The removal of unnecessary blanks
$!  here is applied to the whole statement, since it causes no harm.
$!  It is not applied in the absence of a lexical in the statement,
$!  so as not to needlessly extend execution time.
$!
$!  The final pair of changes (changing "IF(" TO "IF (" and
$!  ")THEN" to ") THEN" is applied to all statements.  These may
$!  appear in legal DCL code (and may also be generated when
$!  unnecessary blanks are removed from statements with lexicals).
$!
$   if  f$locate ("F$",dcl_record) .ne. f$length(dcl_record)
$   then
$       dclxrecord = dcl_record
$       lx = f$length (dcl_record) - 1
$loopx:
$       n = f$locate (" ",dclxrecord)
$       if n .lt. lx
$           then
$           if  (f$loca (f$extr(n-1,1,dcl_record),"-+/*,()") .lt. 7 .or. -
                 f$loca (f$extr(n+1,1,dcl_record),"-+/*,()") .lt. 7)
$           then
$               dcl_record = f$extr(0,n,dcl_record) + f$extr(n+1,-1,dcl_record)
$               dclxrecord = f$extr(0,n,dclxrecord) + f$extr(n+1,-1,dclxrecord)
$               lx = lx - 1
$           else
$               dclxrecord = f$extr(0,n,dclxrecord) + "X" + -
                    f$extr(n+1,-1,dclxrecord)
$           endif
$           goto loopx
$       endif
$   endif
$!
$   if  f$locate (if_lpar,dcl_record) .ne. f$length(dcl_record)
$   then
$       p = f$locate (if_lpar,dcl_record)
$       dcl_record = f$extr (0,p+2,dcl_record) + " " + f$extr(p+2,-1,dcl_record)
$   endif
$!
$   if  f$locate (rpar_then,dcl_record) .ne. f$length(dcl_record)
$   then
$       p = f$locate (rpar_then,dcl_record)
$       dcl_record = f$extr (0,p+1,dcl_record) + " " + f$extr(p+1,-1,dcl_record)
$   endif
$!
$!  (End of code provided by Ed Miller.)
$!
$!
$   oper = ".EQ."
$   gosub oper_space
$   oper = ".GE."
$   gosub oper_space
$   oper = ".GT."
$   gosub oper_space
$   oper = ".LE."
$   gosub oper_space
$   oper = ".LT."
$   gosub oper_space
$   oper = ".NE."
$   gosub oper_space
$   oper = ".EQS."
$   gosub oper_space
$   oper = ".GES."
$   gosub oper_space
$   oper = ".GTS."
$   gosub oper_space
$   oper = ".LES."
$   gosub oper_space
$   oper = ".LTS."
$   gosub oper_space
$   oper = ".NES."
$   gosub oper_space
$   oper = ".AND."
$   gosub oper_space
$   oper = ".OR."
$   gosub oper_space
$   oper = ".NOT."
$   gosub oper_space
$!
$   goto after_oper
$!
$!
$oper_space:
$!
$   oper_length = f$length(oper)
$   oper_work = ""
$!
$!  Can't fix this condition so skip it
$   if f$locate("""''oper'""",dcl_record) .lt. f$length(dcl_record) -
        then return
$!
$oper_loop:
$   oper_loc = f$locate(oper,dcl_record)
$   if oper_loc .ge. f$length(dcl_record)
$   then
$       oper_work = oper_work + dcl_record
$       dcl_record = oper_work
$       return
$   endif
$   oper_work = oper_work + -
                f$edit(f$extract(0,oper_loc,dcl_record),"TRIM") + -
                " " + oper + " "
$   dcl_record = f$edit(f$extract(oper_loc+oper_length,511,dcl_record),"TRIM")
$   goto oper_loop
$!
$!
$after_oper:
$!
$!
$!  check for lines not starting w/$ (and not deck or continuation)
$!
$   if f$extract(0,1,dcl_record) .nes. "$"
$   then
$       if .not. suppress_LND then write err_file f$fao( -
            "!5UL  LND-E  line does not start with ""$""", -
             saved_line)
$!      not written to the intermediate file; not checked any further.
$       goto read_dcl1
$   endif
$!
$!  Loose the "$" -- to make things simpler...
$!
$!  Record starts w/ "$ "
$   if f$extract(0,2,dcl_record) .eqs. "$ "
$   then
$       dcl_record = dcl_record - "$ "
$!
$!  Record starts w/ "$" (no space after $)
$   else
$       if f$extract(0,1,dcl_record) .eqs. "$" then -
            dcl_record = dcl_record - "$"
$   endif
$!
$!
$!  Find labels and add to label_file
$!
$!  Save the full line for file checking -- label removed below
$   file_work = dcl_record
$!
$   if f$locate("@",dcl_record) .eq. 0 then goto label_found
$   label = f$element(0," ",dcl_record)
$   label = f$element(0,"/",label)
$   label = f$element(0,"""",label)
$   label = f$element(0,"(",label)
$   lc = f$locate(":",label)
$   if lc .eq. f$locate(":=",label) then goto label_found
$   if lc .gt. f$locate("=",label) then goto label_found
$   If f$locate(":",label) .lt. (f$length(label)-1)
$   then
$       label = f$element(0,":",label) + ":"
$!      now put a space after the label in DCL_RECORD
$       dcl_record = label + " " + (dcl_record - label)
$   endif
$   If f$locate(":",label) .eq. (f$length(label)-1)
$   then    ! it really is a label
$!
$!      Remember that we are no longer in an EXIT or GOTO shadow
$       exit_shadow = 0
$       goto_shadow = 0
$!
$!      Remove the label from file_work (":" and leading space removed)
$       file_work = f$edit(file_work - label,"TRIM")
$!
$       label = label - ":"
$!
$!      Check to see if the label is defined by symbol substitution
$       if f$locate(s_quote,label) .lt. f$length(label)
$       then    ! symbol substitution
$           if .not. suppress_LDS then write err_file f$fao( -
                "!5UL  LDS-I  Label ""!AS"" defined by symbol substitution (warning)", -
                saved_line,label)
$           goto label_found    ! Don't check dup or add to label file
$       endif
$!
$!      Check to see if its already in the label file
$       read /err=add_the_label /key="''f$fao("!255AS",label)'" label_file x
$!
$!      If its found, it is a possible duplicate
$!      (Or it could be a different subroutine...)
$!      Write it to label_file with a D (Duplicate) in position one
$!      (We overwrite the "D" later if it is in a different subroutine)
$!
$       x = f$fao("D!5UL!255AS",saved_line,label)
$       write/symbol label_file x
$   endif
$!
$   goto label_found    ! it's already there -- O.K.
$!
$add_the_label:
$   work_status = $status
$   if work_status .eq. %X000182B2
$   then    ! not found so add it
$       x = f$fao("0!5UL!255AS",saved_line,label)
$       write/symbol label_file x
$   else    ! it is some unexpected error
$       goto err_exit_w_status
$   endif
$label_found:
$!
$!  Check for OPEN/READ/WRITE/CLOSE statements
$!  and write/update entries in file_file
$!
$!  Labels are already stripped.
$!  However, we can still have a DCL verb in a THEN statement/clause.
$!  We need to create a VERB_WORK variable, which is FILE_WORK
$!  with any THEN and whatever precedes it stripped.
$!
$   t$l = f$locate("THEN",file_work)
$   w$l = f$length(file_work)
$   if t$l .eq. w$l
$   then
$       verb_work = file_work
$   else
$       verb_work = f$extract(t$l+5,w$l,file_work)
$   endif
$!
$   verb_loc = 0
$   verb = f$element(0," ",verb_work)
$   verb = f$element(0,"/",verb)
$   verb_work = f$edit(verb_work - verb,"TRIM")
$!
$   if f$length(verb) .lt. 3 then goto after_verb
$!
$!                          1     1     2
$!                1    6    1     7     3   (23 is length)
$   verb_list = "\OPEN\READ\WRITE\CLOSE\"
$   verb_loc = f$locate(verb,verb_list)
$   if verb_loc .eq. 23 then goto after_verb
$!
$!  If verb_work starts with "=" or ":=", then this is a situation in which
$!  an I/O verb is also being used as a symbol.  Skip this.
$   if   ( (f$extract(0,1,verb_work) .eqs. "=") -
    .or.   (f$extract(0,2,verb_work) .eqs. ":=") ) -
    then goto after_verb
$!
$!  Now parse out the logical name used to reference the file
$!
$!  We already removed the verb from verb_work.
$!  The logical will be at the start of the first, blank-delimited
$!  element of verb_work that does NOT start with "/" --
$!  BUT we need to look out for blanks before and/or after the
$!  = sign following a qualifier.
$!
$   log_num = 0
$   log_name = verb_work
$file_log_loop:
$!
$   if f$extract(0,1,log_name) .eqs. "/"
$   then    ! This is a qualifier, not the logical name
$!            It will be terminated by either an equal sign, or a blank,
$!              or by another qualifier.
$       log_name = f$edit(log_name - "/","TRIM")    ! remove the /
$       log_work = f$element(0," ",f$element(0,"=",f$element(0,"/",log_name)))
$!      Strip the qualifier and try again
$       log_name = f$edit(log_name - log_work,"TRIM")
$       goto file_log_loop
$   endif
$!
$   if f$extract(0,1,log_name) .eqs. "="
$   then    ! This introduces a qualifier value (string or symbol) or keyword
$       log_name = f$edit(log_name - "=","TRIM")    ! remove the equal sign
$       if f$extract(0,1,log_name) .eqs. """"
$       then        ! remove the quoted string
$           log_name = f$edit(log_name - """","TRIM")
$           if   ( ( f$extract(0,1,log_name) .eqs. "'" ) -
            .and.  ( f$extract(1,1,log_name) .eqs. "'" ) )
$           then
$               log_name = log_name - "'" - "'"
$               log_work = f$element(0,"'",log_name)
$               log_name = f$edit(log_name - log_work,"TRIM") - "'"
$           endif
$           log_work = f$element(0,"""",log_name)
$           log_name = f$edit(log_name - log_work - """","TRIM")
$           goto file_log_loop
$       else        ! remove the keyword/symbol
$!                  ! It can be terminated by a space or another "/"
$           log_work = f$element(0," ",f$element(0,"/",log_name))
$           log_name = f$edit(log_name - log_work,"TRIM")
$           goto file_log_loop
$       endif
$!
$   endif
$!
$   log_name = f$edit(log_name,"TRIM")          ! remove leading spaces
$   log_name = f$element(0,"/",log_name)        ! strip any qualifiers
$   log_name = f$element(0," ",log_name)        ! strip any other stuff
$!
$   if log_name .eqs. "SYS$OUTPUT" then goto after_verb
$   if log_name .eqs. "SYS$INPUT" then goto after_verb
$   if log_name .eqs. "SYS$PIPE" then goto after_verb
$   if log_name .eqs. "SYS$COMMAND" then goto after_verb
$   if log_name .eqs. "SYS$ERROR" then goto after_verb
$!
$   if log_name .eqs. ""
$   then
$       if .not. suppress_NLN then write err_file f$fao( -
    "!5UL  NLN-S  An OPEN, READ, WRITE or CLOSE statement has no logical name", -
            saved_line)
$       goto after_Verb
$   endif
$!
$!  Setup default output
$   i$o = "0"       ! input (opened for read) (default)
$   a$o = "0"       ! output (opened for append)
$   o$o = "0"       ! output (opened for write)
$   r$o = "0"       ! read
$   w$o = "0"       ! write (w/o /UPDATE) (or READ/DELETE)
$   u$o = "0"       ! write /UPDATE
$   c$o = "0"       ! close
$   logical = ""    ! blank initially
$!
$   if verb_loc .eq. 1
$   then            ! OPEN -- CHECK FOR /READ/WRITE/APPEND
$       v$l = f$length(verb_work)
$       i$l = f$locate("/REA",verb_work)
$       a$l = f$locate("/APP",verb_work)
$       o$l = f$locate("/WRI",verb_work)
$!
$       if i$l .lt. v$l then i$o = "1"
$       if a$l .lt. v$l then a$o = "1"
$       if o$l .lt. v$l then o$o = "1"
$       if ( (i$l .eq. v$l) .and. (a$l .eq. v$l) .and. (o$l .eq. v$l) ) -
            then i$o = "1"      ! default to read
$   endif
$!
$   if verb_loc .eq. 6                      ! READ
$   then
$       v$l = f$length(verb_work)
$       d$l = f$locate("/DEL",verb_work)
$       if d$l .lt. v$l then w$o = "1"      ! /READ with /DELETE => write
$       r$o = "1"                           ! r$o always set for READ
$   endif
$!
$   if verb_loc .eq. 11                     ! WRITE
$   then
$       v$l = f$length(verb_work)
$       u$l = f$locate("/UPD",verb_work)
$       if u$l .eq. v$l
$       then
$           w$o = "1"
$       else
$           u$o = "1"
$       endif
$   endif
$!
$   if verb_loc .eq. 17 then c$o = "1"      ! CLOSE
$!
$!
$!  Check to see if it's already in the file file
$!
$!  Replace any double quotes ("...") with  {*}
$!  This prevents miss-interpretation in the /KEY qualifier
$!  and is consistent with quoted string checking
$!
$file_quote_loop:
$   log_work = f$element(0,"""",log_name)
$   if log_work .eqs. log_name then goto after_file_quote
$   log_name = log_work + "{*}" + f$element(2,"""",log_name)
$   goto file_quote_loop
$after_file_quote:
$!
$   file_key = f$fao("!255AS",log_name)
$   read /err=add_the_file /key="''file_key'" file_file x
$!
$!  If its found, then update it
$!
$   if f$extract(0,1,x) then i$o = "1"
$   if f$extract(1,1,x) then a$o = "1"
$   if f$extract(2,1,x) then o$o = "1"
$   if f$extract(3,1,x) then r$o = "1"
$   if f$extract(4,1,x) then w$o = "1"
$   if f$extract(5,1,x) then u$o = "1"
$   if f$extract(6,1,x) then c$o = "1"
$!
$   x = i$o + a$o + o$o + r$o + w$o + u$o + c$o + file_key
$!
$   write/update/symbol file_file x
$!
$   goto after_verb
$!
$add_the_file:
$!
$   work_status = $status
$   if work_status .eq. %X000182B2
$   then    ! not found so add it
$       x = i$o + a$o + o$o + r$o + w$o + u$o + c$o + file_key
$       write/symbol file_file x
$   else    ! it is some unexpected error
$       goto err_exit_w_status
$   endif
$!
$!
$after_verb:
$!
$!
$!  Check for possible misspelled lexical function
$!              (not in valid_lexicals)
$!           possible truncated lexical function
$!              (4 chars (6 including "F$") required for uniqueness)
$!
$!  Check for possible misspelled/typed lexical functions.
$!  If we find "F$..." that doesn't match up with the leading
$!  characters in a valid lexical function, it is an error.
$!  If it matches but has less that 4 characters (6, include "F$)
$!  then that is also an error.
$!
$!  Check if the line contains a lexical function
$!  We must take into account that because the lexical function could
$!  be within a quoted string it could be in lower (or mixed) case.
$!  So we must check for both "F$" and "f$".
$   l = f$locate("F$",dcl_record)
$   if l .ge. f$length(dcl_record)
$   then
$       l = f$locate("f$",dcl_record)
$       if l .ge. f$length(dcl_record) then goto after_lexical
$   endif
$!
$!  Save the character that precedes the F$
$   if l .gt. 0
$   then
$       prior$char = f$extract(l-1,1,dcl_record)
$   else
$       prior$char = " "
$   endif
$!
$   work = f$extract(l,999,dcl_record)
$!
$lexical_loop:
$!
$   work1 = f$edit(f$extract(0,2,work),"UPCASE")     ! get the F$
$   l = 2
$!
$!  If what we now have is a "F$" preceded by a letter, a number or
$!  a "$" or "_", or """", then it isn't a lexical.
$!
$   if prior$char .ges. "0" .and. prior$char .les. "9" then goto lexical_next
$   if prior$char .ges. "a" .and. prior$char .les. "z" then goto lexical_next
$   if prior$char .ges. "A" .and. prior$char .les. "Z" then goto lexical_next
$   if prior$char .eqs. "$" then goto lexical_next
$   if prior$char .eqs. "_" then goto lexical_next
$   if prior$char .eqs. """" then goto lexical_next
$!
$lexical_loop_2:
$   char = f$edit(f$extract(l,1,work),"UPCASE")    ! get the next character
$   l = l + 1
$!  If the character is alphabetic, it is part of the lexical function name
$   if char .ges. "a" .and. char .les. "z" then goto lexical_char
$   if char .ges. "A" .and. char .les. "Z" then goto lexical_char
$!  If the character is not alphabetic, it is not part of the name
$   goto lexical_check     ! not a letter
$lexical_char:
$   work1 = work1 + char
$   goto lexical_loop_2
$!
$lexical_check:
$!
$!  Since it could be in lower or mixed case, upshift it
$   work1 = f$edit(work1,"UPCASE")
$!
$   if l .lt. 6     ! **TOO SHORT**
$   then
$       if work1 .nes. "F$FAO" .and. work1 .nes. "F$PID"
$       then
$           if .not. suppress_PTL then write err_file f$fao( -
                "!5UL  PTL-E  possible truncated lexical (!AS)", -
                saved_line,work1)
$       endif
$   endif
$!
$   if f$locate(work1,valid_lexicals) .eq. length_valid_lexicals
$   then
$       if .not. suppress_PML then write err_file f$fao( -
            "!5UL  PML-E  possible misspelled lexical (!AS)", -
            saved_line,work1)
$   endif
$!
$lexical_next:
$   work = f$extract(l-1,999,work)  ! get rid of what we just checked
$   l = f$locate("F$",work)         ! look for more
$   if l .ge. f$length(work) then goto after_lexical  ! no more
$!
$!  Save the character that precedes the F$
$   if l .gt. 0
$   then
$       prior$char = f$extract(l-1,1,work)
$   else
$       prior$char = " "
$   endif
$!
$   work = f$extract(l,999,work)
$!
$   goto lexical_loop               ! go do the next F$
$!
$!
$after_lexical:
$!
$!  Check for apparent numeric constants with string comparison,
$!  or apparent string constants with numeric comparison
$!
$!  Walk through the line looking for comparison operators
$!
$   l = 0
$wct_loop:
$   work = f$element(l," ",dcl_record)
$   if work .eqs. " " then got after_wct
$!
$!  Look for numeric comparison operators
$   if   work .eqs. ".EQ." -
    .or. work .eqs. ".GE." -
    .or. work .eqs. ".GT." -
    .or. work .eqs. ".LE." -
    .or. work .eqs. ".LT." -
    .or. work .eqs. ".NE."
$   then
$!
$       if l .eq. 0
$       then
$           if .not. suppress_MEC then write err_file f$fao( -
                "!5UL  MEC-S  missing expression for comparison", -
                saved_line)
$           l = l + 1
$           goto wct_loop
$       endif
$!
$       if f$element(l+1," ",dcl_record) .eqs. " "
$       then
$           if .not. suppress_MEC then write err_file f$fao( -
                "!5UL  MEC-S  missing expression for comparison", -
                saved_line)
$           goto after_wct
$       endif
$!
$!      Numeric comparison operators must not be preceded or followed
$!      by quoted strings.
$       if   ( (     (f$extract(0,1,f$element(l-1," ",dcl_record)) .eqs. quote ) -
               .and. (f$extract(0,2,f$element(l-1," ",dcl_record)) .nes. """," )  -
               .and. (f$extract(0,2,f$element(l-1," ",dcl_record)) .nes. """""") ) -
        .or.   (     (f$extract(0,1,f$element(l+1," ",dcl_record)) .eqs. quote ) -
               .and. (f$extract(0,2,f$element(l+1," ",dcl_record)) .nes. """""") ) )
$       then
$           if .not. suppress_WCT then write err_file f$fao( -
                "!5UL  WCT-E  wrong constant type for comparison", -
                saved_line)
$       endif
$   endif
$!
$!  Look for string comparison operators
$   if   work .eqs. ".EQS." -
    .or. work .eqs. ".GES." -
    .or. work .eqs. ".GTS." -
    .or. work .eqs. ".LES." -
    .or. work .eqs. ".LTS." -
    .or. work .eqs. ".NES."
$   then
$!
$       if l .eq. 0
$       then
$           if .not. suppress_MEC then write err_file f$fao( -
                "!5UL  MEC-S  missing expression for comparison", -
                saved_line)
$           l = l + 1
$           goto wct_loop
$       endif
$!
$       if f$element(l+1," ",dcl_record) .eqs. " "
$       then
$           if .not. suppress_MEC then write err_file f$fao( -
                "!5UL  MEC-S  missing expression for comparison", -
                saved_line)
$           goto after_wct
$       endif
$!
$!      String comparison operators must not be preceded or followed
$!      by numeric constants
$       work1 = f$extract(0,1,f$element(l-1," ",dcl_record))
$       work2 = f$extract(0,1,f$element(l+1," ",dcl_record))
$       if   (work1 .ges. "0" .and. work1 .les. "9") -
        .or. (work2 .ges. "0" .and. work2 .les. "9")
$       then
$           if .not. suppress_WCT then write err_file f$fao( -
                "!5UL  WCT-E  wrong constant type for comparison", -
                saved_line)
$       endif
$   endif
$!
$   l = l + 1
$!
$   goto wct_loop
$!
$after_wct:
$!
$! -----------------------------------
$!
$!  Check for unpaired (i.e., an odd number of) quotes (")
$!
$   l = 0
$count_quotes:
$   work = f$element(l,quote,dcl_record)
$   if work .eqs. quote then goto quotes_counted
$   l = l + 1
$   goto count_quotes
$!
$quotes_counted:
$   l = l - 1
$   if l .ne. l/2*2
$   then
$       if .not. suppress_UPQ then write err_file f$fao( -
            "!5UL  UPQ-S  unpaired quotation marks ("")", -
            saved_line)
$   endif
$!
$! (2)------------------------------------------------------------
$!
$!  Checking for properly paired double quotes has already been done.
$!  Checking for properly paired single quotes outside quoted strings
$!      is done later.
$!
$   work = ""   ! Blank "work" so we can build the output in it
$!
$!  If dcl_rec contains contractions, they will provide an incorrect
$!  possible error using single quote in quoted strings.
$!  So we'll remove any of the following contractions.
$!
$!  Contractions ending in "'s" are removed from this list
$!  because we check for possessives below.
$!
$!  (multiple statements to avoid "expression too complex")
$!
$   dcl_record = dcl_record -
        - "aren't" -
        - "can't" -
        - "couldn't" -
        - "didn't" -
        - "doesn't" -
        - "don't" -
        - "hadn't" -
        - "hasn't" -
        - "haven't" -
        - "he'd" -
        - "he'll" -
        - "I'd" -
        - "I'll" -
        - "I'm" -
        - "I've" -
        - "isn't" -
        - "she'd" -
        - "she'll"
$   dcl_record = dcl_record -
        - "shouldn't" -
        - "they'd" -
        - "they'll" -
        - "they're" -
        - "they've" -
        - "wasn't" -
        - "we'd" -
        - "we'll" -
        - "we're" -
        - "we've" -
        - "weren't" -
        - "won't" -
        - "wouldn't" -
        - "you'd" -
        - "you'll" -
        - "you're" -
        - "you've"
$!
$!  And they could be capitalized...
$   dcl_record = dcl_record -
        - "Aren't" -
        - "Can't" -
        - "Couldn't" -
        - "Didn't" -
        - "Doesn't" -
        - "Don't" -
        - "Hadn't" -
        - "Hasn't" -
        - "Haven't" -
        - "He'd" -
        - "He'll" -
        - "Isn't" -
        - "She'd" -
        - "She'll"
$   dcl_record = dcl_record -
        - "Shouldn't" -
        - "They'd" -
        - "They'll" -
        - "They're" -
        - "They've" -
        - "Wasn't" -
        - "We'd" -
        - "We'll" -
        - "We're" -
        - "We've" -
        - "Weren't" -
        - "Won't" -
        - "Wouldn't" -
        - "You'd" -
        - "You'll" -
        - "You're" -
        - "You've"
$!
$!  And they could be in all capitals...
$   dcl_record = dcl_record -
        - "AREN'T" -
        - "CAN'T" -
        - "COULDN'T" -
        - "DIDN'T" -
        - "DOESN'T" -
        - "DON'T" -
        - "HADN'T" -
        - "HASN'T" -
        - "HAVEN'T" -
        - "HE'D" -
        - "HE'LL" -
        - "ISN'T" -
        - "SHE'D" -
        - "SHE'LL"
$   dcl_record = dcl_record -
        - "SHOULDN'T" -
        - "THEY'D" -
        - "THEY'LL" -
        - "THEY'RE" -
        - "THEY'VE" -
        - "WASN'T" -
        - "WE'D" -
        - "WE'LL" -
        - "WE'RE" -
        - "WE'VE" -
        - "WEREN'T" -
        - "WON'T" -
        - "WOULDN'T" -
        - "YOU'D" -
        - "YOU'LL" -
        - "YOU'RE" -
        - "YOU'VE"
$!
$!  Also get rid of "'" and (') to avoid PSQ or PRQ errors
$!
$dsd_quote_remove:
$   if f$locate("""'""",dcl_record) .lt. f$length(dcl_record)
$   then
$       dcl_record = dcl_record - """'"""
$       goto dsd_quote_remove
$   endif
$!
$osc_quote_remove:
$   if f$locate("(')",dcl_record) .lt. f$length(dcl_record)
$   then
$       dcl_record = dcl_record - "(')"
$       goto osc_quote_remove
$   endif
$!
$!  And to eliminate most possessives, get rid of "%'s "
$!  where % is any non-blank.  (Note the trailing blank.)
$!
$pos_quote_remove1:
$   if  ( ( f$locate("'s ",dcl_record) .lt. f$length(dcl_record) ) -
    .and. ( f$extract(f$locate("'s ",dcl_record)-1,1,dcl_record) .gts. " " ) )
$   then
$       dcl_record = dcl_record - "'s "
$       goto pos_quote_remove1
$   endif
$!
$pos_quote_remove2:
$! DCL_CHECK COMMENT: PSQ O.K. in next line (2 times)
$   if  ( ( f$locate("'s""",dcl_record) .lt. f$length(dcl_record) ) -
    .and. ( f$locate("'s""",dcl_record) .eq. ( f$length(dcl_record) - 3 ) ) -
    .and. ( f$extract(f$locate("'s ",dcl_record)-1,1,dcl_record) .gts. " " ) )
$   then
$! DCL_CHECK COMMENT: PSQ O.K. in next line
$       dcl_record = dcl_record - "'s""" + """"
$       goto pos_quote_remove2
$   endif
$!
$!  At the start of the line we are NOT in a quoted string.
$!  (Continuation lines have already been concatenated.)
$!
$not_in_quote:
$!
$!  Everything before the first/next quote is not in a quoted string
$!
$   temp = f$element(0,quote,dcl_record)
$   if temp .eqs. quote then  goto end_check_quotes
$!
$!  Add what we've just got to WORK...
$   work = work + temp
$!
$!  .. and remove it from DCL_RECORD
$   dcl_record = dcl_record - temp
$!
$!  If what is left in DCL_RECORD starts with a quote,
$!  replace it with a placeholder
$   if f$extract(0,1,dcl_record) .eqs. quote
$   then
$       dcl_record = dcl_record - quote
$       work = work + "{*}"
$   endif
$!
$   i = 0   ! We'll use 0-based F$EXTRACT to search the quoted string
$!
$!in_quote:
$!
$!  The contents of quoted strings is NOT copied to "work".
$!  At the start of a quoted string we are NOT in symbol substitution
$!
$not_in_symbol_subs:
$!
$!  If we encounter "'s " (<single-quote><s><space>) [lower case s]
$!                     or (<single-quote><S><space>) [upper case S]
$!  in a quoted string, we'll take it as a possive and skip it
$!
$   if ( (f$extract(i,3,dcl_record) .eqs. "'s ") -
    .or.  (f$extract(i,3,dcl_record) .eqs. "'S ") )
$   then
$       i = i + 3
$       goto not_in_symbol_subs
$   endif
$!
$!  Symbol substitution starts with two single quotes ('')
$   if f$extract(i,2,dcl_record) .eqs. s2_quote
$   then
$       i = i + 2
$       goto in_symbol_subs
$   endif
$!
$!  Get the next character
$   char = f$extract(i,1,dcl_record)
$   i = i + 1
$!
$   if char .eqs. "" then goto end_check_quotes ! shouldn't happen, but...
$!
$!  If we encounter a single single-quote that is NOT terminating a
$!  symbol substitution, it could be a valid possessive or contraction, or
$!  it could be an error.
$!
$   if char .eqs. s_quote
$   then
$       if .not. suppress_PSQ then write err_file f$fao( -
            "!5UL  PSQ-W  possible error using single-quote (') in quoted string", -
            saved_line)
$       goto not_in_symbol_subs
$   endif
$!
$!  The first double quote not within symbol substitution ends
$!      the quoted string.
$   if char .eqs. quote
$   then
$!      When the quoted string ends, go back to the not_in_quote routine.
$!      First, reset what is in DCL_RECORD
$       dcl_record = f$extract(i,9999,dcl_record)
$       goto not_in_quote
$   endif
$!
$   goto not_in_symbol_subs
$!
$in_symbol_subs:
$!
$!  Get the next character
$   char = f$extract(i,1,dcl_record)
$   i = i + 1
$!
$!  If the line ends while still in symbol substitution, it is an error;
$!  (Since we keep going until we find a single-quote, we WILL get to line
$!  end if symbol substitution is not terminated.)
$!  output the error and exit the quote checking
$   if char .eqs. ""
$   then
$       if .not. suppress_PSQ then write err_file f$fao( -
            "!5UL  PSQ-W  possible error using single-quote (') in quoted string", -
            saved_line)
$       goto end_check_quotes
$   endif
$!
$!  Symbol substitution ends with one single quote (').
$   if f$extract(i,1,dcl_record) .eqs. s_quote
$   then
$       i = i + 1
$       goto not_in_symbol_subs
$   endif
$!
$!  Double quotes within symbol substitution are ignored.
$!
$   goto in_symbol_subs
$!
$!
$end_check_quotes:
$!
$!  "work" now contains DCL_RECORD with quoted strings removed.
$!  Put it back in DCL_RECORD
$!
$   dcl_record = work
$!
$!
$! (2)------------------------------------------------------------
$!
$!  Check for unpaired (i.e., an odd number of) single-quotes (').
$!  Since we have at this point removed any quoted strings, which could
$!  contain an odd number of single-quotes for contractions (e.g. "can't"),
$!  possessives (e.g. "Mary's") or symbol substitution (e.g. "''count'")
$!  any single-quotes left must be paired, 1-1, for symbol substitution
$!  (e.g. 'file_name')
$!  Since a symbol being used for substitution cannot contain a space,
$!  We will look at each blank separated element of the line.
$!  This will catch errors similar to
$!      $ rename 'old 'new -- s/b  $ rename 'old' 'new'
$!
$   j = 0
$s_quotes_loop:
$   work1 = f$element(j," ",dcl_record)
$   if work1 .eqs. " " then goto s_quotes_counted
$   j = j + 1
$!
$   l = 0
$count_s_quotes:
$   work = f$element(l,s_quote,work1)
$   if work .eqs. s_quote
$   then
$       l = l - 1
$!
$   if l .ne. l/2*2
$   then
$       if .not. suppress_PRQ then write err_file f$fao( -
            "!5UL  PRQ-E  probable error using single-quote (')", -
            saved_line)
$   endif
$!
$       goto s_quotes_loop
$   endif
$   l = l + 1
$   goto count_s_quotes
$!
$s_quotes_counted:
$!
$!  now write the intermediate work file before we
$!  mess with if/then/else/endif
$!
$!  Because the record can be "too big", we build it in a symbol...
$   temp_rec = f$fao("!5UL !AS",saved_line,dcl_record)
$!  ...and then use write/symbol to handle large records.
$   write /symbol work_file temp_rec
$!
$!  Unconditional GOTO and EXIT lines cast a "shadow" -- following lines
$!  are unreachable until a LABEL or ELSE is found.
$!
$   token = f$edit(f$element(0," ",dcl_record),"UPCASE")
$   If f$locate(":",token) .eq. (f$length(token)-1)
$   then    ! it is a label
$       token = f$edit(f$element(1," ",dcl_record),"UPCASE")
$   endif
$!
$   if token .eqs. "GOTO"
$   then
$       wrk = f$edit(dcl_record - "GOTO","TRIM,UPCASE")
$       if  ( (f$extract(0,1,wrk) .nes. "=") -
        .and. (f$extract(0,2,wrk) .nes. ":=") ) -
            then goto_shadow = saved_line
$   endif
$!
$   if token .eqs. "EXIT"
$   then
$       wrk = f$edit(dcl_record - "EXIT","TRIM,UPCASE")
$       if  ( (f$extract(0,1,wrk) .nes. "=") -
        .and. (f$extract(0,2,wrk) .nes. ":=") ) -
            then exit_shadow = saved_line
$   endif
$!
$!
$!  A single command can contain either IF, or both IF and THEN.
$!
$!  If it contains IF and THEN, then we are O.K. and only need
$!  to check for "=" between the IF and the THEN.
$!
$!  If it contains only IF, then there may not be an "=" on the line
$!  and the next statement must be THEN, and there must eventually be
$!  an ENDIF.  There may also be an ELSE between the THEN and the ENDIF.
$!
$!  IF statements may be nested, so we must track all this at levels.
$!
$if_then_else:
$!
$   token = f$edit(f$element(0," ",dcl_record),"UPCASE")
$   If f$locate(":",token) .eq. (f$length(token)-1)
$   then    ! it is a label
$       token = f$edit(f$element(1," ",dcl_record),"UPCASE")
$   endif
$!
$   if  ( (token .nes. "THEN") -
    .and. (f$extract(if_level,1,then_level) .eqs. "0") -
    .and. (if_level .gt. 0) )
$   then
$       then_level[if_level,1] := 1
$       if .not. suppress_TRH then write err_file f$fao( -
            "!5UL  TRH-S  THEN statement required here", -
            saved_line)
$   endif
$!
$   if token .eqs. "IF"
$   then
$       if f$locate(" THEN ",dcl_record) .lt. f$length(dcl_record)
$       then
$           if f$locate("=",dcl_record) .lt. f$locate(" THEN ",dcl_record)
$           then
$               if .not. suppress_EFB then write err_file f$fao( -
                    "!5UL  EFB-S  ""="" found between IF and THEN", -
                    saved_line)
$           endif
$       else
$!
$           if f$locate("=",dcl_record) .lt. f$length(dcl_record)
$           then
$               if .not. suppress_EFB then write err_file f$fao( -
                    "!5UL  EFB-S  ""="" found between IF and THEN", -
                    saved_line)
$           endif
$!
$           if if_level - sr_level .gt. 14
$           then
$               if .not. suppress_TML then write err_file f$fao( -
                    "!5UL  TML-S  too many levels of IF statements", -
                    saved_line)
$           endif
$           if_lines = f$fao("!UL/!AS",saved_line,if_lines)
$           if_level = if_level + 1
$           ifsr_level[if_level,1] := "I"   ! remember it's an IF
$       endif
$   endif
$!
$   if    (f$length(token) .ge. 4) -
    .and. (f$locate(token,"SUBROUTINE") .eq. 0)
$   then
$       if if_level .gt. 20
$       then
$           if .not. suppress_TMS then write err_file f$fao( -
                "!5UL  TMS-S  too many levels of IF and SUBROUTINE statements", -
                saved_line)
$       endif
$       if_lines = f$fao("!UL/!AS",saved_line,if_lines)
$       if_level = if_level + 1
$       sr_level = sr_level + 1
$       ifsr_level[if_level,1] := "S"   ! remember it's a SUBROUTINE
$       then_level[if_level,1] := 1     ! Don't allow THEN after SUBROUTINE
$       else_level[if_level,1] := 1     ! Don't allow ELSE after SUBROUTINE
$   endif
$!
$   if token .eqs. "THEN"
$   then
$       if f$extract(if_level,1,then_level) .eqs. "1" -
        .or. if_level .eq. 0
$       then
$           if .not. suppress_TNA then write err_file f$fao( -
                "!5UL  TNA-S  THEN statement not allowed here", -
                saved_line)
$       else
$           then_level[if_level,1] := 1
$       endif
$       dcl_record = dcl_record - "THEN"
$       if f$extract(0,1,dcl_record) .eqs. " " then -
            dcl_record = dcl_record - " "
$       goto if_then_else
$   endif
$!
$   if token .eqs. "ELSE"
$   then
$!      ELSE cancels goto_shadow and exit_shadow
$       goto_shadow = 0
$       exit_shadow = 0
$!
$       if f$extract(if_level,1,else_level) .eqs. "1" -
        .or. if_level .eq. 0
$       then
$           if .not. suppress_ENA then write err_file f$fao( -
                "!5UL  ENA-S  ELSE statement not allowed here", -
                saved_line)
$       else
$           else_level[if_level,1] := 1
$       endif
$       dcl_record = dcl_record - "ELSE"
$       if f$extract(0,1,dcl_record) .eqs. " " then -
            dcl_record = dcl_record - " "
$       goto if_then_else
$   endif
$!
$   if token .eqs. "ENDIF"
$   then
$!      ENDIF cancels goto_shadow and exit_shadow
$       goto_shadow = 0
$       exit_shadow = 0
$!
$       if if_level .eq. 0 -
        .or. f$extract(if_level,1,ifsr_level) .nes. "I"
$       then
$           if .not. suppress_DNA then write err_file f$fao( -
                "!5UL  DNA-S  ENDIF statement not allowed here", -
                saved_line)
$       else
$!
$!          Write record in if_file
$           if_start = f$element(0,"/",if_lines)
$           if_start_num = f$integer(if_start)
$           write if_file f$fao("!5UL!5ULI",if_start_num,saved_line)
$!
$!          Reset if-level info
$           then_level[if_level,1] := 0
$           else_level[if_level,1] := 0
$           ifsr_level[if_level,1] := 0
$           if_level = if_level - 1
$           if_lines = if_lines - if_start - "/"
$!
$       endif
$   endif
$!
$   if    (f$length(token) .ge. 4) -
    .and. (f$locate(token,"ENDSUBROUTINE") .eq. 0)
$   then
$!      ENDSUBROUTINE cancels goto_shadow and exit_shadow
$       goto_shadow = 0
$       exit_shadow = 0
$!
$       if if_level .eq. 0 -
        .or. f$extract(if_level,1,ifsr_level) .nes. "S"
$       then
$           if .not. suppress_RNA then write err_file f$fao( -
                "!5UL  RNA-S  ENDSUBROUTINE statement not allowed here", -
                saved_line)
$       else
$!
$!          Write record in if_file
$           if_start = f$element(0,"/",if_lines)
$           if_start_num = f$integer(if_start)
$           write if_file f$fao("!5UL!5ULS",if_start_num,saved_line)
$!
$!          Reset if-level info
$           then_level[if_level,1] := 0
$           else_level[if_level,1] := 0
$           ifsr_level[if_level,1] := 0
$           if_level = if_level - 1
$           sr_level = if_level - 1
$           if_lines = if_lines - if_start - "/"
$!
$       endif
$   endif
$!
$!
$!  Check for lines that are obscured by an EXIT or GOTO
$!
$   if exit_shadow .gt. 0 .and. saved_line .gt. exit_shadow
$   then
$       if .not. suppress_CRE then write err_file f$fao( -
            "!5UL  CRE-W  code cannot be reached due to EXIT at line !UL", -
            saved_line,exit_shadow)
$       exit_shadow = 0
$   endif
$!
$   if goto_shadow .gt. 0 .and. saved_line .gt. goto_shadow
$   then
$       if .not. suppress_CRG then write err_file f$fao( -
            "!5UL  CRG-W  code cannot be reached due to GOTO at line !UL", -
            saved_line,goto_shadow)
$       goto_shadow = 0
$   endif
$!
$   goto read_dcl1
$!
$end_dcl1_c:
$!
$   if .not. suppress_NCL then write err_file f$fao( -
            "!5UL  NCL-S  no continuation line at EOF", -
            line_number)
$end_dcl1:
$   work2 = 0
$end_dcl1_a:
$!
$   if if_level .gt. 0
$   then
$!      work = f$integer(f$element(if_level-1,"/",if_lines))
$       work = f$integer(f$element(work2,"/",if_lines))
$       if f$extract(if_level,1,ifsr_level) .eqs. "I"
$       then
$           if .not. suppress_INT then write err_file f$fao( -
                "!5UL  INT-S  IF statement not terminated", -
                work)
$       endif
$       if f$extract(if_level,1,ifsr_level) .eqs. "S"
$       then
$           if .not. suppress_SNT then write err_file f$fao( -
                "!5UL  SNT-S  SUBROUTINE statement not terminated", -
                work)
$       endif
$       if_level = if_level - 1
$       work2 = work2 + 1
$       goto end_dcl1_a
$   endif
$!
$   if in_deck
$   then
$       if .not. suppress_NED then write err_file f$fao( -
            "!5UL  NED-S  no ''d$w' for $DECK at line !UL", -
            saved_line,deck_line)
$   endif
$!
$!  Close the DCL file and the WORK file
$!
$   close work_file
$   close dcl_file
$!
$!  comment_lines already contains number of comment lines
$!  continuation_lines already contains number of continuation lines
$!  deck_lines already contains number of lines within $DECK/$EOD pairs
$!  Save number of code lines
$   total_lines = line_number
$   code_lines = total_lines - continuation_lines - deck_lines -
        - comment_lines - blank_lines
$!
$   Say "Starting Pass 2 -- ''f$time()' ..."
$!
$!  This pass checks labels referenced
$!
$!  LNF-S  label ""!AS"" not found
$!  LNR-I  label ""!AS"" not referenced (warning)
$!  RLI-S  referenced label ""!AS"" is in if-group at lines !UL-!UL
$!  RLS-W  referenced label ""!AS"" is in subroutine at lines !UL-!UL
$!  TLS-I  target label ""!AS"" provided by symbol substitution (warning)"
$!
$!      by CALL, GOTO and GOSUB commands, and
$!      by /ERROR and /END qualifiers.
$!
$!  Open the work file for read
$   open /read work_file sys$scratch:dcl$work_'pid'.tmp
$!
$   line_to_display = (line_disply_increment * 2)
$read_dcl2:
$!
$   read /end=end_dcl2 work_file dcl_record
$!
$!  The original line number was saved in the work file pass 1.
$!  Separate the line number and the "compressed" dcl record
$!
$   line_number = f$integer(f$extract(0,5,dcl_record))
$   saved_line = line_number
$   dcl_record = f$extract(6,(f$length(dcl_record)-5),dcl_record)
$!
$   if line_number .gt. line_to_display
$   then
$       say f$fao("...processing line number !UL...",line_to_display)
$       line_to_display = line_to_display + (line_disply_increment * 2)
$   endif
$!
$!
$!  Check for OPEN/READ/WRITE/CLOSE statements
$!  check entries in file_file and write errors
$!
$!  Labels are still there; we need to strip them
$!
$   verb_work = dcl_record
$   label = f$element(0," ",verb_work)
$   label = f$element(0,"/",label)
$   If f$locate(":",label) .eq. (f$length(label)-1)
$   then    ! it really is a label
$!      Remove the label from verb_work (":" and leading space removed)
$       verb_work = verb_work - label - " "
$   endif
$!
$!  Now labels are removed
$!  However, we can still have a DCL verb in a THEN statement/clause.
$!  We need to create a VERB_WORK variable, which is DCL_RECORD
$!  with any THEN and whatever precedes it stripped.
$!
$   t$l = f$locate("THEN",verb_work)
$   w$l = f$length(verb_work)
$   if t$l .ne. w$l
$   then
$       verb_work = f$extract(t$l+5,w$l,verb_work)
$   endif
$!
$   verb = f$element(0," ",verb_work)
$   verb = f$element(0,"/",verb)
$   verb_work = f$edit(verb_work - verb,"TRIM")
$!
$   if f$length(verb) .lt. 3 then goto scan_for_labels_used
$!
$!                          1     1     2
$!                1    6    1     7     3   (23 is length)
$   verb_list = "\OPEN\READ\WRITE\CLOSE\"
$   verb_loc = f$locate(verb,verb_list)
$   if verb_loc .eq. 23 then goto scan_for_labels_used
$!
$!  If verb_work starts with a "=", then this is a situation in which
$!  an I/O verb is also being used as a symbol.  Skip this.
$   if   ( (f$extract(0,1,verb_work) .eqs. "=") -
    .or.   (f$extract(0,2,verb_work) .eqs. ":=") ) -
    then goto scan_for_labels_used
$!
$!  Now parse out the logical name used to reference the file
$!
$!  We already removed the verb from verb_work.
$!  The logical will be at the start of the first, blank-delimited
$!  element of verb_work that does NOT start with "/"
$   log_num = 0
$file_log_loop2:
$   log_name = f$element(log_num," ",verb_work)
$!
$   if f$extract(0,1,log_name) .eqs. "/"
$   then    ! this is a qualifier, not the logical name
$!
$!      If the next element IS an "=" sign...
$       if f$element(log_num + 1," ",verb_work) .eqs. "="
$       then
$           log_num = log_num + 3
$           goto file_log_loop2
$       endif
$!
$!      If this element ends with an "=" sign...
$!      If the next element STARTS with an "=" sign...
$       if ( (f$extract(f$length(log_name)-1,1,log_name) .eqs. "=") -
        .or. (f$extract(0,1,f$element(log_num+1," ",verb_work)) .eqs. "=") )
$       then
$           log_num = log_num + 2
$           goto file_log_loop2
$       endif
$!
$!      Otherwise...
$       log_num = log_num + 1
$       goto file_log_loop2
$!
$   endif
$!
$   log_name = f$element(0,"/",log_name)     ! strip any qualifiers
$   log_name = f$element(0," ",log_name)      ! strip any other stuff
$!
$   if log_name .eqs. "SYS$OUTPUT" then goto scan_for_labels_used
$   if log_name .eqs. "SYS$INPUT" then goto scan_for_labels_used
$   if log_name .eqs. "SYS$PIPE" then goto scan_for_labels_used
$   if log_name .eqs. "SYS$COMMAND" then goto scan_for_labels_used
$   if log_name .eqs. "SYS$ERROR" then goto scan_for_labels_used
$   if log_name .eqs. "" then goto scan_for_labels_used  ! Already caught NLN
$!
$!  Read file_file
$!
$   file_key = f$fao("!255AS",log_name)
$!  Will abort on read error
$   read /key="''file_key'" file_file x
$!
$   i$o = f$extract(0,1,x)
$   a$o = f$extract(1,1,x)
$   o$o = f$extract(2,1,x)
$   r$o = f$extract(3,1,x)
$   w$o = f$extract(4,1,x)
$   u$o = f$extract(5,1,x)
$   c$o = f$extract(6,1,x)
$!
$   if verb_loc .eq. 1
$   then            ! OPEN
$!
$!    ONC-E  A file that is opened has no close statement
$       if .not. suppress_ONC .and. .not. c$o then write err_file f$fao( -
            "!5UL  ONC-E  A file that is OPENed has no CLOSE statement", -
            line_number)
$!
$!    INR-E  A file that is opened for read is not read
$       if .not. suppress_INR .and. i$o .and. .not. r$o -
            then write err_file f$fao( -
            "!5UL  INR-E  A file that is opened for read is not read", -
            line_number)
$!
$!    ANR-E  A file that is opened for append is not written
$       if .not. suppress_ANR .and. a$o .and. .not. w$o -
            then write err_file f$fao( -
            "!5UL  ANR-E  A file that is opened for append is not written", -
            line_number)
$!
$!    ONW-E  A file that is opened for write is not written
$       if .not. suppress_ONW .and. o$o .and. .not. w$o -
            then write err_file f$fao( -
            "!5UL  ONW-E  A file that is opened for write is not written", -
            line_number)
$!
$   endif
$!
$   if verb_loc .eq. 6
$   then            ! READ
$       if .not. suppress_RNR .and. .not. i$o then write err_file f$fao( -
            "!5UL  RNR-S  A file that is not opened for read is being read", -
            line_number)
$   endif
$!
$   if verb_loc .eq. 11
$   then            ! WRITE
$       v$l = f$length(verb_work)
$       u$l = f$locate("/UPD",verb_work)
$       if u$l .eq. v$l
$       then    ! not /UPDATE
$           if .not. suppress_WNW .and. .not. o$o .and. .not. a$o -
                then write err_file f$fao( -
  "!5UL  WNW-S  A file that is not opened for write or append is being written", -
                line_number)
$       else    !/Update
$           if  ( (.not. suppress_UNU) -
            .and. (.not. i$o .or. .not. o$o) ) -
                then write err_file f$fao( -
  "!5UL  UNU-S  A file that is not oppend for read and write is being updated", -
                line_number)
$       endif
$   endif
$!
$   if verb_loc .eq. 17
$   then            ! CLOSE
$       if .not. suppress_CNO .and. .not. i$o .and. .not. a$o .and. .not. o$o -
            then write err_file f$fao( -
            "!5UL  CNO-S  A file that is closed has no open statement", -
            line_number)
$   endif
$!
$!
$!  Now scan the line for "/END","/ERR[OR]","GOTO ","GOSUB " "CALL " -
$!  (Remember -- the line was UPCASEd in pass 1 -- and compressed)
$!
$scan_for_labels_used:
$!
$   length = f$length(dcl_record)
$!
$   if f$locate("/END",dcl_record) .lt. length
$   then
$       if verb_loc .eq. 6  ! READ
$       then
$!          set l to point to the first character of the label
$           l = f$locate("/END",dcl_record) + 4
$!          Increment l to the "="
$end_qual_loop:
$           if f$extract(l,1,dcl_record) .nes. "="
$           then
$               l = l + 1
$               if l .lt. length then goto end_qual_loop
$           endif
$!          increment one more for the "=" itself
$           l = l + 1
$!          Increment l past the space, if there is one
$           if f$extract(l,1,dcl_record) .eqs. " "
$           then
$               l = l + 1
$           endif
$           gosub check_for_label
$       endif
$!
$       if (verb_loc .eq. 1) .or. (verb_loc .eq.17) ! OPEN or CLOSE
$       then
$           if .not. suppress_OCE then write err_file f$fao( -
                "!5UL  OCE-I  OPEN or CLOSE statement with /END qualifier", -
            line_number)
$       endif
$   endif
$!
$   if  ( (f$locate("/ERR",dcl_record) .lt. length) -
    .and. ( ( verb_loc .eq. 1 ) -
    .or. ( verb_loc .eq. 6 ) -
    .or. ( verb_loc .eq. 11 ) -
    .or. ( verb_loc .eq. 17 ) ) )
$   then    ! found
$!      set l to point to the first character of the label
$       l = f$locate("/ERR",dcl_record) + 4
$!      Increment l to the "="
$err_qual_loop:
$       if f$extract(l,1,dcl_record) .nes. "="
$       then
$           l = l + 1
$           if l .lt. length then goto err_qual_loop
$       endif
$!      increment one more for the "=" itself
$       l = l + 1
$!      Increment l past the space, if there is one
$       if f$extract(l,1,dcl_record) .eqs. " "
$       then
$           l = l + 1
$       endif
$       gosub check_for_label
$   endif
$!
$   if f$locate("GOTO ",dcl_record) .lt. length
$   then    ! found
$!      if "GOTO" is not preceded by a space or a $, then it is not a command
$       l = f$locate("GOTO",dcl_record)
$       if (l .gt. 0) -
        .and. (f$extract(l-1,1,dcl_record) .nes. " ") -
        .and. (f$extract(l-1,1,dcl_record) .nes. "$") -
            then goto after_goto
$!      set l to point to the first character of the label
$       l = l + 4
$!      Increment l past any spaces
$goto_qual_loop:
$       if f$extract(l,1,dcl_record) .eqs. " "
$       then
$           l = l + 1
$           if l .lt. length then goto goto_qual_loop
$       endif
$       gosub check_for_label
$   endif
$after_goto:
$!
$   if f$locate("GOSUB ",dcl_record) .lt. length
$   then    ! found
$!      if "GOSUB" is not preceded by a space or a $, then it is not a command
$       l = f$locate("GOSUB",dcl_record)
$       if (l .gt. 0) -
        .and. (f$extract(l-1,1,dcl_record) .nes. " ") -
        .and. (f$extract(l-1,1,dcl_record) .nes. "$") -
            then goto after_gosub
$!      set l to point to the first character of the label
$       l = l + 5
$!      Increment l past any spaces
$gosub_qual_loop:
$       if f$extract(l,1,dcl_record) .eqs. " "
$       then
$           l = l + 1
$           if l .lt. length then goto gosub_qual_loop
$       endif
$       gosub check_for_label
$   endif
$after_gosub:
$!
$   if f$locate("CALL",dcl_record) .lt. length
$   then    ! found
$       l = f$locate("CALL",dcl_record)
$!      if "CALL" is not preceded by a space, then it is not a command
$       if (l .gt. 0) .and. (f$extract(l-1,1,dcl_record) .nes. " ") -
            then goto after_call
$!
$!      set l to point to the first character of the label
$       l = l + 4
$!
$!      if "CALL" is not followed by a space or a "/",
$!          then it is not a command
$       if  ( (f$extract(l,1,dcl_record) .nes. " ") -
        .and. (f$extract(l,1,dcl_record) .nes. "/") ) -
            then goto after_call
$!
$       call$call = 1   ! remember that it IS a "CALL"
$!
$!      Increment l past any spaces
$call_qual_loop:
$       if f$extract(l,1,dcl_record) .eqs. " "
$       then
$           l = l + 1
$           if l .lt. length then goto call_qual_loop
$       endif
$!
$!      Now check for /OUTPUT on the CALL
$       if f$extract(l,4,dcl_record) .eqs. "/OUT"
$       then
$           l = f$locate("=",dcl_record)
$           l = l + 1
$           if f$extract(l,1,dcl_record) .eqs. " " then l = l + 1
$call_out_loop:
$           if f$extract(l,1,dcl_record) .nes. " "
$           then
$               l = l + 1
$               if l .lt. length then goto call_out_loop
$           endif
$           l = l + 1
$       endif
$       gosub check_for_label
$!
$       call$call = 0  ! Assume it is NOT a "CALL"
$   endif
$after_call:
$!
$   goto read_dcl2
$!
$! =======================================================================
$check_for_label:
$!
$   labrefinsr = 0     ! Start with assumption label referenced in a subroutine
$   labfoundsr = 0     ! and not found in the same subroutine
$!
$!  At this point a l points to the first character of the label.
$!  it could be terminated by a space (" ") or slash ("/")
$   label = ""
$extract_label_loop:
$   x = f$extract(l,1,dcl_record)
$   if ( (x .eqs. " ") .or. (x .eqs. "/") .or. (x .eqs. "") ) then -
        goto now_have_label
$   label = label + x
$   l = l + 1
$   goto extract_label_loop
$!
$now_have_label:
$!  If it contains a "'" it is symbol substitution
$   if f$locate("'",label) .lt. f$length(label)
$   then
$       if .not. suppress_TLS then write err_file f$fao( -
    "!5UL  TLS-I  target label ""!AS"" provided by symbol substitution (warning)", -
            line_number,label)
$       return
$   endif
$! -----------------------------------------------------------------------
$!
$   if_rec_found = 0    ! assume no if-rec found
$!
$!  Check to see if it's in the label file
$   label_key = f$fao("!255AS",label)
$   read /err=no_such_label /key="''label_key'" label_file label_rec
$   lab_marked = 0
$!
$next_label:
$!  Extract the line number of the label
$   label_line = f$extract(1,5,label_rec)
$!
$!  Check if the label's line number is in an if-group
$!  If it is, check that the reference is in the same if-group
$!
$! N.B. -- Because the key in IF_FILE is in descending order, the
$!  /match=gt has the effect of finding the first record that is
$!  LESS THAN the /key value.  (i.e. "greater" really means "next")
$   read /err=endif_range -
        /key="''label_line'" /match=gt if_file if_rec
$   if_rec_found = 1
$!
$read_next_if:
$!  get the start and end of the range
$   if_start = f$extract(0,5,if_rec)
$   if_end = f$extract(5,5,if_rec)
$   if label_line .gt. if_end
$   then
$       if ( .not. lab_marked ) -
        .and. ( f$extract(0,1,label_rec) .nes. "D" )
$       then
$!          Mark the label as having been referenced
$           label_rec[0,1] := "1"
$           write/symbol/update label_file label_rec
$           lab_marked = 1
$       endif
$!
$!      goto endif_range
$!      Try again
$       read /err=endif_range if_file if_rec
$       if_rec_found = 1
$       goto read_next_if
$!
$   endif
$!
$   if_sr = f$extract(10,1,if_rec)
$!
$!  Is the label_line in the if range?
$!  Note: if the label_line is in multiple, nested if ranges, then the
$!  first one we find is the outermost one -- Honest!
$   if ( (label_line .gt. if_start) .and. (label_line .lt. if_end) )
$   then    ! this is the one
$       if ( (line_number .lt. if_start) .or. (line_number .gt. if_end) )
$       then    ! reference is not in the same if range with the label
$           if if_sr .eqs. "I"
$           then
$               if .not. suppress_RLI then write err_file f$fao( -
                    "!5UL  RLI-S  referenced label ""!AS"" is in if-group at lines !UL-!UL", -
                    line_number,label,f$integer(if_start),f$integer(if_end))
$           endif
$           if if_sr .eqs. "S"
$           then
$               if .not. suppress_RLS then write err_file f$fao( -
                    "!5UL  RLS-W  referenced label ""!AS"" is in subroutine at lines !UL-!UL", -
                    line_number,label,f$integer(if_start),f$integer(if_end))
$           endif
$       endif
$   else
$       if ( .not. lab_marked ) -
        .and. ( f$extract(0,1,label_rec) .nes. "D" )
$       then
$!          Mark the label as having been referenced
$           label_rec[0,1] := "1"
$           write/symbol/update label_file label_rec
$           lab_marked = 1
$       endif
$   endif
$!  Try again
$   read /err=endif_range if_file if_rec
$   if_rec_found = 1
$   goto read_next_if
$!
$endif_range:
$!
$! ........................................................................
$!  Now, if we are in a subroutine, we need to check that the
$!  target label is in the same subroutine
$!
$!  ... but not if this label was on a "CALL
$   if call$call
$   then
$       if ( .not. lab_marked ) -
        .and. ( f$extract(0,1,label_rec) .nes. "D" )
$       then
$!          Mark the label as having been referenced
$           label_rec[0,1] := "1"
$           write/symbol/update label_file label_rec
$           lab_marked = 1
$       endif
$!
$       goto after_lns
$   endif
$!
$!  Zero the sr_start and _end symbols
$   sr_start = 0
$   sr_end = 0
$!
$   read /err=endsr_range -
        /key="''line_number'" /match=gt if_file if_rec
$   if_rec_found = 1
$read_next_sr:
$!  get the start and end ONLY of a subroutine range
$   if_start = f$extract(0,5,if_rec)
$   if_end = f$extract(5,5,if_rec)
$   if label_line .gt. if_end then goto endsr_range
$   if_sr = f$extract(10,1,if_rec)
$!  Is the line in this range?
$   if (line_number .ge. if_start) .and. (line_number .lt. if_end)
$   then        ! We're in the range
$!                Is it a subroutine range?
$       if if_sr .eqs. "S"
$       then    ! It is a subroutine range
$           sr_start = if_start
$           sr_end   = if_end
$           labrefinsr = 1      ! Remember label is referneced in a subroutine
$       endif
$   endif
$!  Try again
$   read /err=endsr_range if_file if_rec
$   if_rec_found = 1
$   goto read_next_sr
$!
$endsr_range:
$!
$   if  ( (sr_end .gt. 0 ) .and. -
        ( (label_line .ge. sr_start) .and. (label_line .le. sr_end) ) )
$   then    ! we found the label in the same subroutine
$!
$       if (.not. lab_marked) .and. (.not. labfoundsr)
$       then
$!          Mark the label as having been referenced
$           label_rec[0,1] := "1"
$           write/symbol/update label_file label_rec
$           lab_marked = 1
$       endif
$       labfoundsr = 1
$   endif
$!
$!  Read the next label_file entry
$   read /err=after_lns  label_file label_rec
$   lab_marked = 0
$   if f$extract(6,255,label_rec) .eqs. label_key then goto next_label
$!
$after_lns:
$!
$   if labrefinsr .and. .not. labfoundsr
$   then            ! the target label is not in the same subroutine
$       if .not. suppress_LNS then write err_file f$fao( -
            "!5UL  LNS-S  referenced label ""!AS"" is not in this subroutine", -
            line_number,label)
$   endif
$!
$   if .not. lab_marked .and. ((.not. if_rec_found) .or. (.not. labfoundsr))
$   then
$!      Read label_file to re-establish a a current record
$       read /err=no_such_label /key="''label_key'" label_file label_rec
$!      Mark the label as having been referenced
$       label_rec[0,1] := "1"
$       write/symbol/update label_file label_rec
$       lab_marked = 1
$       return
$!
$   endif
$!
$   return
$! ----------------------------------------------------------------------
$!
$no_such_label:
$!
$   if .not. suppress_LNF then write err_file f$fao( -
        "!5UL  LNF-S  label ""!AS"" not found", -
        line_number,label)
$!
$   return
$! =========================================================================
$!
$end_dcl2:
$!
$   close work_file
$   close label_file
$   close file_file
$   close if_file
$!
$   open /read label_file sys$scratch:dcl$label_'pid'.idx
$read_label:
$   read/end=end_label label_file x
$!
$   dup_lab = f$extract(0,1,x)
$   if dup_lab .eqs. "1" then goto read_label
$!
$   if dup_lab .eqs. "0"
$   then
$       line_number = f$integer(f$extract(1,5,x))
$       label = f$edit(f$extract(6,2555,x),"TRIM")
$       if .not. suppress_LNR then write err_file f$fao( -
            "!5UL  LNR-I  label ""!AS"" not referenced (warning)", -
            line_number,label)
$       goto read_label
$   endif
$!
$   if dup_lab .eqs. "D"
$   then
$       line_number = f$integer(f$extract(1,5,x))
$       label = f$edit(f$extract(6,2555,x),"TRIM")
$       if .not. suppress_DL then write err_file f$fao( -
            "!5UL  DL--E  duplicate label ""!AS""", -
            line_number,label)
$       goto read_label
$   endif
$!
$   goto read_label
$!
$end_label:
$   close label_file
$!$   delete /nolog sys$scratch:dcl$label_'pid'.idx;*
$!
$!
$   Say "Starting Pass 3 -- ''f$time()' ..."
$!
$!  This pass searches for
$!
$!  ICF-W  invalid character found (#, %, ^ or &)
$!  ICO-S  invalid comparison operator", -
$!  LC--S  line contains END_IF, END IF, GO_TO, GO TO, GO_SUB or GO SUB", -
$!
$   saved_line = 0
$!
$!  delete any "leftover" files
$   if f$search("sys$scratch:dcl$inv_char_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$inv_char_'pid'.tmp;*
$   if f$search("sys$scratch:dcl$comp_op_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$comp_op_'pid'.tmp;*
$   if f$search("sys$scratch:dcl$comp_op1_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$comp_op1_'pid'.tmp;*
$   if f$search("sys$scratch:dcl$spell_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$spell_'pid'.tmp;*
$!
$!  Search for invalid characters --
$!      #, %, ^ and & are not valid in commands, symbols or expressions
$!      (At this point, all quoted strings have been removed)
$!
$   define /user sys$output nl:
$   define /user sys$error nl:
$   search sys$scratch:dcl$work_'pid'.tmp -
        /out=sys$scratch:dcl$inv_char_'pid'.tmp -
            "#", "%", "^", "&"
$   work_status = $status
$!  $status %X08D78053 indicates "No strings found"
$   if work_status .ne. %X08D78053
$   then
$       open search_file sys$scratch:dcl$inv_char_'pid'.tmp
$!
$read_search0:
$       read /end=end_search0 search_file dcl_record
$!
$!      %X and %O (HEX and OCTAL radix) are O.K.
$       if f$locate("%X",dcl_record) .lt. f$length(dcl_record) -
            then goto read_search0
$       if f$locate("%O",dcl_record) .lt. f$length(dcl_record) -
            then goto read_search0
$!
$!      The original line number was saved in the file we searched
$!      Separate the line number.
$       line_number = f$integer(f$extract(0,5,dcl_record))
$!
$!      "&" is usually O.K. in a PIPE statement; make it a warning.
$       if    f$locate("&",dcl_record) .lt. f$length(dcl_record) -
        .and. f$locate("PIPE",dcl_record) .lt. f$length(dcl_record)
$       then    ! make it a warning.
$           if .not. suppress_ICF then write err_file f$fao( -
                "!5UL  ICF-W  possible invalid character found (& in PIPE) (warning)", -
                line_number)
$           goto read_search0
$       endif
$!
$!      % and & may be used correctly (wild card and symbol substitution)
$!      so if they were found, make it a warning.
$!
$       if   f$locate("%",dcl_record) .lt. f$length(dcl_record) -
        .or. f$locate("&",dcl_record) .lt. f$length(dcl_record)
$       then    ! make it a warning.
$           if .not. suppress_ICF then write err_file f$fao( -
                "!5UL  ICF-W  possible invalid character found ( % or &) (warning)", -
                line_number)
$           goto read_search0
$       endif
$!
$!      ! Else not a warning
$       if .not. suppress_ICF then write err_file f$fao( -
            "!5UL  ICF-W  invalid character found (# or ^)", -
            line_number)
$       goto read_search0
$!
$end_search0:
$       close search_file
$   endif
$!
$!
$!  Search for invalid comparison operators
$!
$   define /user sys$output nl:
$   define /user sys$error nl:
$   search sys$scratch:dcl$work_'pid'.tmp -
        /out=sys$scratch:dcl$comp_op_'pid'.tmp -
            " .eq ", " eq. ", " eq ",  -
            " .ge ", " ge. ", " ge ",  -
            " .gt ", " gt. ", " gt ",  -
            " .le ", " le. ", " le ",  -
            " .lt ", " lt. ", " lt ",  -
            " .ne ", " ne. ", " ne ",  -
            " .or ", " or. ", " or ",  -
            " .not "," not. "," not ", -
            " .and "," and. "," and ", -
            " .eqs "," eqs. "," eqs ", -
            " .ges "," ges. "," ges ", -
            " .gts "," gts. "," gts ", -
            " .les "," les. "," les ", -
            " .lts "," lts. "," lts ", -
            " .nes "," nes. "," nes ", -
            " .new "," new. "," .new. ", -
            " .eas "," eas. "," .eas. ", -
            " .ea "," ea. "," .ea. ", -
            " .gs. "," .ls. "," .es. "," .ns. ", -
            ">=","=>","<=","=<"," _ "
$   work_status = $status
$!  $status %X08D78053 indicates "No strings found"
$   if work_status .ne. %X08D78053
$   then
$       open search_file sys$scratch:dcl$comp_op_'pid'.tmp
$!
$read_search1:
$       read /end=end_search1 search_file dcl_record
$!
$!      The original line number was saved in the file we searched
$!      Separate the line number.
$!
$       line_number = f$integer(f$extract(0,5,dcl_record))
$       if .not. suppress_ICO then write err_file f$fao( -
            "!5UL  ICO-S  invalid comparison operator", -
            line_number)
$       goto read_search1
$end_search1:
$       close search_file
$   endif
$!
$   if f$search("sys$scratch:dcl$comp_op_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$comp_op_'pid'.tmp;*
$!
$   define /user sys$output nl:
$   define /user sys$error nl:
$   search sys$scratch:dcl$work_'pid'.tmp " > "," < " -
        /out=sys$scratch:dcl$comp_op1_'pid'.tmp
$!
$   define /user sys$output nl:
$   define /user sys$error nl:
$   search sys$scratch:dcl$comp_op1_'pid'.tmp "PIP" /match=nor -
        /out=sys$scratch:dcl$comp_op_'pid'.tmp
$   if f$search("sys$scratch:dcl$comp_op1_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$comp_op1_'pid'.tmp;*
$!
$   open search_file sys$scratch:dcl$comp_op_'pid'.tmp
$read_search1a:
$   read /end=end_search1a search_file dcl_record
$   if f$locate("NO STRINGS MATCHED",(f$edit(dcl_record,"UPCASE"))) -
        .lt. f$length(dcl_record) -
        then goto end_search1a
$   line_number = f$integer(f$extract(0,5,dcl_record))
$   if .not. suppress_ICO then write err_file f$fao( -
        "!5UL  ICO-S  invalid comparison operator", -
           line_number)
$   goto read_search1a
$end_search1a:
$   close search_file
$   if f$search("sys$scratch:dcl$comp_op_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$comp_op_'pid'.tmp;*
$!
$   define /user sys$output nl:
$   define /user sys$error nl:
$   search sys$scratch:dcl$work_'pid'.tmp -
        /out=sys$scratch:dcl$spell_'pid'.tmp -
            " end_if"," end if", -
            " go_to"," go to", -
            " go_sub"," go sub"
$   work_status = $status
$!  $status %X08D78053 indicates "No strings found"
$   if work_status .eq. %X08D78053
$   then
$       spell_found = 0
$   else
$       spell_found = 1
$       open search_file sys$scratch:dcl$spell_'pid'.tmp
$!
$read_search2:
$       read /end=end_search2 search_file dcl_record
$!
$!      The original line number was saved in the file we searched
$!      Separate the line number.
$!
$       line_number = f$integer(f$extract(0,5,dcl_record))
$       if .not. suppress_LC then write err_file f$fao( -
        "!5UL  LC--S  line contains END_IF, END IF, GO_TO, GO TO, GO_SUB or GO SUB", -
            line_number)
$       goto read_search2
$end_search2:
$       close search_file
$   endif
$!
$!
$   close err_file
$!
$   sort /stable /key=(pos:1,size:5) -
        sys$scratch:dcl$error_'pid'.tmp -
        sys$scratch:dcl$error_'pid'.tmp
$!
$!  count lines in err_file
$   open /read err_file sys$scratch:dcl$error_'pid'.tmp
$   open /write err_out sys$scratch:dcl$error_'pid'.tmp
$   diag_count = 0
$   is_comment = 1
$   comment_line = 0
$   prior_blank = 1
$read_count:
$   read /end=end_count err_file err_rec
$   diag_count = diag_count + 1
$!
$!  set prior_comment
$   if is_comment
$   then
$       prior_comment = 1
$   endif
$!
$!  Check for DCL_COMMENT lines
$   if f$extract(7,6,err_rec) .eqs. "-CMNT-"
$   then
$       is_comment = 1
$   else
$       is_comment = 0
$   endif
$!
$!  if this is a comment and the prior line wasn't, output a blank line
$   if is_comment .and. (.not. prior_comment) .and. (.not. prior_blank)
$   then
$       write err_out ""
$       prior_blank = 1
$       prior_comment = 0
$   endif
$!
$!  get the line number
$   line_number = f$integer(f$extract(0,5,err_rec))
$!
$!  save the line number of a comment line
$   if is_comment
$   then
$       comment_line = comment_line + 1
$       if (line_number .ne. comment_line) .and. (.not. prior_blank)
$       then
$           write err_out ""
$           prior_blank = 1
$           prior_comment = 0
$       endif
$       comment_line = line_number
$   else ! check if it is a consecutive with a comment line
$       if prior_comment
$       then
$           if (line_number .ne. comment_line + 1) .and. (.not. prior_blank)
$           then
$               write err_out ""
$               prior_blank = 1
$               prior_comment = 0
$           endif
$       endif
$   endif
$   write err_out err_rec
$   prior_blank = 0
$   goto read_count
$end_count:
$   close err_file
$   close err_out
$   purge sys$scratch:dcl$error_'pid'.tmp
$!
$   dcl_end_time = f$time()
$   if f$file_ATTRIBUTES("sys$scratch:dcl$error_''pid'.tmp","eof") .gt. 0
$   then
$       if ( (p2 .nes. "") .and. (p2 .nes. "$") )
$       then
$           report$file = f$parse(p2,".LIS")
$           say ""
$           say "Creating errors listing in ''report$file'"
$           say "''dcl_end_time'"
$           say ""
$!          open the report file
$!          Attempt to close it in case it was left open
$           close/err=open_report rep_file
$open_report:
$           create 'report$file'    ! create gets file characteristics right
$           open /append rep_file 'report$file'
$           write rep_file -
    "-*- Charlie Hammond's unsupported DCL checker (Version ''dcl_ck_vers') -*-"
$           write rep_file "Checking file ''dcl$file'"
$           write rep_file "''dcl_ck_time'"
$           write rep_file ""
$           write rep_file "Checking for DCL_CHECK$ logicals..."
$           close rep_file
$!
$           if use_pipe then -
            pipe    sho log DCL_CHECK$* | -
                    sear sys$input DCL_CHECK$ | -
                    append sys$input 'report$file'
$!
$           open /append rep_file 'report$file'
$           write rep_file ""
$           write rep_file f$fao( -
    "Procedure contains:!7UL total lines",total_lines)
$           write rep_file f$fao( -
    "                   !7UL code lines (including !UL lines w/ comments)", -
                        code_lines, commented_code_lines)
$           write rep_file f$fao( -
    "                   !7UL additional continuation lines",continuation_lines)
$           write rep_file f$fao( -
    "                   !7UL lines w/i $DECK/$EOD pairs",deck_lines)
$           write rep_file f$fao( -
    "                   !7UL comment only lines",comment_lines)
$           write rep_file f$fao( -
    "                   !7UL blank lines",blank_lines)
$           write rep_file f$fao( -
    "                   !7UL diagnostics",diag_count)
$           write rep_file ""
$           write rep_file " LINE  CODE  --DIAGNOSTIC MESSAGE--"
$           write rep_file ""
$           close rep_file
$           append sys$scratch:dcl$error_'pid'.tmp,sys$input 'report$file'
$DECK

-*- END OF LISTING -*-

$EOD
$       else
$           say ""
$           say f$fao( -
    "Procedure contains:!7UL total lines",total_lines)
$           say f$fao( -
    "                   !7UL code lines (including !UL lines w/ comments)", -
                        code_lines, commented_code_lines)
$           say f$fao( -
    "                   !7UL additional continuation lines",continuation_lines)
$           say f$fao( -
    "                   !7UL lines w/i $DECK/$EOD pairs",deck_lines)
$           say f$fao( -
    "                   !7UL comment only lines",comment_lines)
$           say f$fao( -
    "                   !7UL blank lines",blank_lines)
$           say f$fao( -
    "                   !7UL diagnostics",diag_count)
$           say ""
$           say " LINE  CODE  --DIAGNOSTIC MESSAGE--"
$           say ""
$           type sys$scratch:dcl$error_'pid'.tmp
$           say ""
$           say "-*- END OF LISTING -*-   ''dcl_end_time'"
$           say ""
$       endif
$   else
$           say ""
$           say f$fao( -
    "Procedure contains:!7UL total lines",total_lines)
$           say f$fao( -
    "                   !7UL code lines (including !UL lines w/ comments)", -
                        code_lines, commented_code_lines)
$           say f$fao( -
    "                   !7UL additional continuation lines",continuation_lines)
$           say f$fao( -
    "                   !7UL lines w/i $DECK/$EOD pairs",deck_lines)
$           say f$fao( -
    "                   !7UL comment only lines",comment_lines)
$           say f$fao( -
    "                   !7UL blank lines",blank_lines)
$           say f$fao( -
    "                   !7UL diagnostics",diag_count)
$           say ""
$       say "-*- No errors found -*-   ''f$time()'"
$       if ( (p2 .nes. "") .and. (p2 .nes. "$") ) then -
            say "...listing file not created    ''dcl_end_time'"
$   endif
$!
$   say ""
$   set noon
$   define /user sys$output nl:
$   define /user sys$error nl:
$   elapsed_time = f$delta_time(dcl_ck_time,dcl_end_time)
$   delta_status = $status
$   set on
$   deassign /user sys$output
$   deassign /user sys$error
$   if delta_status .nes. "%X00030001"
$   then
$       if delta_status .eqs. "%X000381C0"
$       then
$!$           say f$fao -
$!    ("*** F$DELTA_TIME not implemented in this version of OpenVMS!!!/")
$       else
$           say f$fao ("!/!AS!/",f$message(delta_status))
$       endif
$   else
$       say f$fao("Elapsed Time: !AS!/",elapsed_time)
$   endif
$!
$   goto common_exit
$!
$!  ------------------------------------------------------------
$!  Exit routines
$!
$y_exit:        ! Ctrl_y exit routine
$!
$!  Display Ctrl_y message
$!
$   say "Exiting due to Ctrl_y entry"
$!
$   goto 1_exit
$!
$err_exit:      ! error/warning exit routine
$!
$   sav_status = $status
$err_exit_w_status:
$   say f$message(sav_status)
$!  Add %x10000000 to set the bit that suppresses display of the message.
$!  This prevents re-displaying the message when we EXIT SAV_STATUS.
$   if sav_status .lt. %x10000000 then sav_status = sav_status + %x10000000
$!
$   say f$fao -
    ("!/Error occured processing at or near source line !5UL",saved_line)
$!
$   goto common_exit
$!
$1_exit:        ! Go here to force exit with status 1 = success
$!                %SYSTEM-S-NORMAL, normal successful completion
$!
$!  Display success message, if desired
$!
$   say f$message(sav_status)
$!
$!  Note: success messages aren't displayed by EXIT SAV_STATUS.
$!  Don't need to use %x10000001.
$   sav_status = 1
$!
$   say f$fao -
    ("!/Error occured processing at or near source line !5UL",saved_line)
$!
$   goto common_exit
$!
$common_exit:   ! common exit
$!
$!  Disable control_y and error handling
$   on control_y then continue
$   on warning then continue
$!
$!  Cleanup code
$!
$!  Close any file left open...
$!
$   close/error=y_1 err_file
$y_1:
$   close/error=y_2 label_file
$y_2:
$   close/error=y_2a file_file
$y_2a:
$   close/error=y_3 work_file
$y_3:
$   close/error=y_4 dcl_file
$y_4:
$   close/error=y_5 rep_file
$y_5:
$   close/error=y_6 if_file
$y_6:
$!  ...
$!
$!  Deassign logicals
$!
$!  Delete temporary files
$!
$   if f$search("sys$scratch:dcl$error_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$error_'pid'.tmp;*
$   if f$search("sys$scratch:dcl$label_''pid'.idx") .nes. "" then -
        delete /nolog sys$scratch:dcl$label_'pid'.idx;*
$   if f$search("sys$scratch:dcl$file_''pid'.idx") .nes. "" then -
        delete /nolog sys$scratch:dcl$file_'pid'.idx;*
$   if f$search ("sys$scratch:dcl$work_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$work_'pid'.tmp;*
$   if f$search("sys$scratch:dcl$inv_char_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$inv_char_'pid'.tmp;*
$   if f$search("sys$scratch:dcl$comp_op_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$comp_op_'pid'.tmp;*
$   if f$search("sys$scratch:dcl$comp_op1_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$comp_op1_'pid'.tmp;*
$   if f$search("sys$scratch:dcl$spell_''pid'.tmp") .nes. "" then -
        delete /nolog sys$scratch:dcl$spell_'pid'.tmp;*
$   if f$search("sys$scratch:dcl$if_''pid'.idx") .nes. "" then -
        delete /nolog sys$scratch:dcl$if_'pid'.idx;*
$!
$!  ...
$!
$!  Any other cleanup required...
$!
$!  Restore message facility to original state
$!
$   set message 'sav_msg'
$!
$!  Exit with status
$!
$   exit sav_status