$ goto start $!*************************************************************************** $!* * $!* DCL_CHECK.COM * $!* * $!* Copyright 1995 Compaq Computer Corporation. * $!* * $!* COMPAQ Registered in U.S. Patent and Trademark Office. * $!* OpenVMS is a trademark of Compaq Information Technologies Group, L.P. * $!* in the United States and/or other countries. * $!* * $!* Confidential computer software. Valid license from Compaq 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. * $!* * $!* Compaq shall not be liable for technical or editorial errors or * $!* omissions contained herein. The information contained herein is * $!* subject to change without notice. * $!* * $!*************************************************************************** $! $! 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 does 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 direcory 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. $! $! SYS$SCRATCH is used for intermediate work files. $! $! Outputs: Listing of errors. $! $! $! MODIFICATION HISTORY $! $! 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 $! Improoved EFB detection ("=" found between IF and THEN) $! $! D2.1 13 Dec 1999 Charlie Hammond $! Improove 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 July 1999 Charlie Hammond $! Correct handling of continuation comment that starts $! with only a "!" rather than "$!" $! Correct handling of SRT and INT errors. $! (SUBROUTING/IF not terminated) $! "Beef up" a few help entries. $! $! A2.0 28 July 1999 Charlie Hammond $! Improove 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: $! $! Make sure DCL verbs aren't unexpected symbols. $! $ set = "set" $ set symbol /scope=(nolocal,noglobal) $! $! 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, everygody'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 exclaimation point and form-feed character () $ exclaim[0,8]=33 $ form_feed[0,8] = 12 $! $! $! ------------------------------------------------------------------ $! $ dcl_ck_vers = "V2.1" $ say "" $ say - "-*- Charlie Hammond's unsupported DCL checker (Version ''dcl_ck_vers') -*-" $! $! Set up symbols to indicate that we are suppressing diagnostice messages. $! This avoied repeatedly traslating the logicals. $! $ suppress_BL = f$trnlnm("DCL_CHECK$SUPPRESS_BL") $ suppress_CCN = f$trnlnm("DCL_CHECK$SUPPRESS_DDN") $ suppress_CLD = f$trnlnm("DCL_CHECK$SUPPRESS_CLD") $ suppress_CLS = f$trnlnm("DCL_CHECK$SUPPRESS_CLS") $ 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_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_LOD = f$trnlnm("DCL_CHECK$SUPPRESS_LOD") $ suppress_MEC = f$trnlnm("DCL_CHECK$SUPPRESS_MCO") $ suppress_NCL = f$trnlnm("DCL_CHECK$SUPPRESS_NCL") $ suppress_NED = f$trnlnm("DCL_CHECK$SUPPRESS_NED") $ suppress_NED = f$trnlnm("DCL_CHECK$SUPPRESS_NED") $ 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_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_UMP = f$trnlnm("DCL_CHECK$SUPPRESS_UMP") $ suppress_UPQ = f$trnlnm("DCL_CHECK$SUPPRESS_UPQ") $ suppress_WCT = f$trnlnm("DCL_CHECK$SUPPRESS_WCT") $! $get_help: $! $! Make certain that P2 exists $! $ if f$type(p2) .eqs. "" then p2 = "" $! $ if f$edit(p1,"UPCASE") .nes. "HELP" then goto get_filename $! $! 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 = "" $ goto help_end $! $help_end: $ say "" $ say "-*- Charlie Hammond's unsupported DCL checker (Version ''dcl_ck_vers') -*-" $! $! $! Get the name of the file to be checked $! $get_filename: $ if p1 .eqs. "" $ then $ 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 "" $ 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 $! $ if f$edit(p1,"UPCASE") .eqs. "HELP" then goto get_help $ if f$edit(p1,"UPCASE") .eqs. "EXIT" then goto common_exit $! $ dcl$file = f$parse(p1,".COM") $ if f$search(dcl$file) .eqs. "" $ then $ say "*** Cannot find ''dcl$file'" $ p1 = "" $ goto get_filename $ endif $! $ if p2 .nes. "" $ then $! $! Remove /OUT= if present $! $ p2 = f$edit(p2,"upcase,collapse") $ if f$extract(0,5,p2) .eqs. "/OUT=" then p2 = f$extract(5,255,p2) $! $ if f$parse(p2,".LIS") .eqs. "" $ then $ say "*** ""''p2'"" is not a valid report filename" $ p1 = "" $ p2 = "" $ goto get_filename $ endif $ endif $! $ dcl_ck_time = f$time() $ say "Checking file ''dcl$file'" $ 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 no 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 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 begining, with comments removed, with quoted strings $! removed, with $DECK/$DECK groups 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 do to preceding EXIT $ goto_shadow = 0 ! lines are not reachable do to preceding GOTO $! $ 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$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 $! $! Checks for $! $! BL blank line (warning) $! CCN Continuation character (""-"") not preceded by space (warning) $! CLD continuation line starts with ""$"" $! CLS comment line separates continuation line (warning) $! CRE code cannot be reached due to EXIT at line !UL $! CRG code cannot be reached due to GOTO at line !UL $! DFB $DECK found between $DECK and $EOD $! DL duplicate label ""!AS"" $! DNA ENDIF statement not allowed here $! EFB ""="" found between IF and THEN $! EFN $EOD found with no corresponding $DECK $! ENA ELSE statement not allowed here $! INT IF statement not terminated $! LDS Label ""!AS"" defined by symbol substitution (warning) $! LFF line contains only form-feed () $! LND line does not start with ""$"" $! LOD line contains only ""$"" (warning) $! MEC missing expression for comparsion $! NCL no continuation line at EOF $! NED no $EOD for $DECK at !UL $! PML possible misspelled lexical (!AS) $! PRQ probable error using single-quote (') $! PSQ possible error using single-quote (') in quoted string $! PTL possible truncated lexical (!AS) $! RNA ENDSUBROUTINE statement not allowed here $! SNT SUBROUTINE statement not terminated $! TML too many levels of IF statements $! TMS too many levels of IF and SUBROUTINE statements $! TNA THEN statement not allowed here $! TRH THEN statement required here $! UMP unmatched parentheses $! UPQ unpaired quotation marks ("") $! WCT wrong constant type for comparison $! $ line_disply_increment = 500 $ line_to_display = line_disply_increment - 1 $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_number) $ line_to_display = line_to_display + line_disply_increment $ 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 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 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 line contains only form-feed ()", - 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 $ t0 = f$element(0," ",dcl_record) $ t1 = f$element(1," ",dcl_record) $! $! Check for $DECK and $EOD -- dont' 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_NED then write err_file f$fao( - "!5UL NED no $EOD for $DECK at !UL", - saved_line,deck_line) $ if .not. suppress_DFB then write err_file f$fao( - "!5UL DFB $DECK found between $DECK and $EOD", - saved_line) $ else $ in_deck = 1 $ deck_line = 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 $! $ if (t0 .eqs. "$EOD") .or. ( (t0 .eqs. "$") .and. (t1 .eqs. "EOD") ) $ then $ if in_deck $ then $ in_deck = 0 $ deck_lines = deck_lines - 1 ! already counted but should not be $ else $ if .not. suppress_EFN then write err_file f$fao( - "!5UL EFN $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 $! exclaimation marks used for formating 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 $! exclaimation marks from the "''F$FA" to the second occurance 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 ! its 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 ! its a single double-quote -- copy and increment q_count $ work = work + quote $ q_count = q_count + 1 $! $ endif $! $ else ! just copy the char, except exclaimation 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 $ if f$extract(f$length(dcl_record)-1,1,dcl_record) .eqs. "-" $ then ! the line IS continued $ If 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 begining of the $! continuation line, this can result in keywords, qualifiers or $! parameters being incorrectly concatinated. $! DCLDIETing a comand procedure can cause thes condition because $! DCLDIET removes all space at the begining of the continuarion line. $! $ if .not. suppress_CCN then write err_file f$fao( - "!5UL CCN Continuation character (""-"") not preceded by space (warning)", - line_number) $ endif $! Remove the trailing "-" $ dcl_record = f$extract(0,f$length(dcl_record)-1,dcl_record) $read_continuation: $ read /end=end_dcl1_c dcl_file dcl_c_record $ line_number = line_number + 1 $ continuation_lines = continuation_lines + 1 ! count continuation lines $! $! Check if it is a comment only $ work = f$edit(dcl_c_record,"TRIM,COMPRESS") $ 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 comment line separates continuation line (warning)", - line_number) $ goto read_continuation $ endif $! $ 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" $ then $ if .not. suppress_CLD then write err_file f$fao( - "!5UL CLD 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 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 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 $! $ label = f$element(0," ",dcl_record) $ 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 $! $ 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 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 duplicate $ if .not. suppress_DL then write err_file f$fao( - "!5UL DL duplicate label ""!AS""", - saved_line,label) $ 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 possible miss-spelled lexical function $! (not in valid_lexicals) $! possible truncated lexical funciton $! (4 chars (6 including "F$") required for uniqueness) $! $! Check for possible miss-spelled/typed lexical fuctions. $! 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 charactres (6, include "F$) $! then that is also an error. $! $! Check if the line contains a lexical function $! We must take into accoun 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 preceeds 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$" preceeded by a letter, a number or $! a "$" 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 $! $lexical_loop_2: $ char = f$edit(f$extract(l,1,work),"UPCASE") ! get the next chare $ l = l + 1 $! If the character is alphabetic, it is part of the lexcial 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 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 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 preceeds 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 srting 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 missing expression for comparsion", - 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 missing expression for comparsion", - saved_line) $ goto after_wct $ endif $! $! Numeric comparison operators must not be preceeded 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 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 missing expression for comparsion", - 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 missing expression for comparsion", - saved_line) $ goto after_wct $ endif $! $! String comparison operators must not be preceeded 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 wrong constant type for comparison", - saved_line) $ endif $ endif $! $ l = l + 1 $! $ goto wct_loop $! $after_wct: $! $! $! Check for un-paired parens () $! $ op_cnt = 0 ! Open Parentheses count $ cp_cnt = 0 ! Close Parentheses count $! $ l = 0 $count_o_parens: $ work = f$element(l,"(",dcl_record) $ if work .eqs. "(" then goto o_parens_counted $ l = l + 1 $ goto count_o_parens $! $o_parens_counted: $ op_cnt = l - 1 $! $ l = 0 $count_c_parens: $ work = f$element(l,")",dcl_record) $ if work .eqs. ")" then goto c_parens_counted $ l = l + 1 $ goto count_c_parens $! $c_parens_counted: $ cp_cnt = l - 1 $! $ if op_cnt .ne. cp_cnt $ then $ if .not. suppress_UMP then write err_file f$fao( - "!5UL UMP unmatched parentheses", - saved_line) $ endif $! $! $! 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 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 quors in quoted strings. $! So we'll remove any of the following contractions. $! $! (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" - - "he's" - - "I'd" - - "I'll" - - "I'm" - - "I've" - - "isn't" - - "it's" - - "she'd" - - "she'll" $ dcl_record = dcl_record - - "she's" - - "shouldn't" - - "that's" - - "they'd" - - "they'll" - - "they're" - - "wasn't" - - "we'd" - - "we'll" - - "we're" - - "we've" - - "weren't" - - "what's" - - "who's" - - "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" - - "He's" - - "Isn't" - - "It's" - - "She'd" - - "She'll" $ dcl_record = dcl_record - - "She's" - - "Shouldn't" - - "That's" - - "They'd" - - "They'll" - - "They're" - - "Wasn't" - - "We'd" - - "We'll" - - "We're" - - "We've" - - "Weren't" - - "What's" - - "Who's" - - "Won't" - - "Wouldn't" - - "You'd" - - "You'll" - - "You're" - - "You've" $! $! $! A 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 $ work = work + temp $! $! Remove what we've already checked in DCL_RECORD (and a quote, too) $ dcl_record = dcl_record - temp - quote $! $ 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 subsitution $! $not_in_symbol_subs: $! $! 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 signel-quote that is NOT terminating a $! symbol substitution, it could be a valid possive 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 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 goint till we find a single-quotem 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 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. "cant'"), $! possives (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 substsitution cannont containa space, $! We will look at each blank seperated element of the line. $! This will catch errors simliar 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 $ goto s_quotes_loop $ endif $ l = l + 1 $ goto count_s_quotes $! $s_quotes_counted: $! $ if l .ne. l/2*2 $ then $ if .not. suppress_PRQ then write err_file f$fao( - "!5UL PRQ probable error using single-quote (')", - saved_line) $ endif $! $! $! 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 LABLE 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 goto_shadow = saved_line $ if token .eqs. "EXIT" then exit_shadow = saved_line $! $! $! 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 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 ""="" 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 ""="" 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 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$extract(0,4,token) .eqs. "SUBR" $ then $ if if_level .gt. 20 $ then $ if .not. suppress_TMS then write err_file f$fao( - "!5UL TMS 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 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 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 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$extract(0,4,token) .eqs. "ENDS" $ 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 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 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 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 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 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 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 no $EOD for $DECK at !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 nubmer of continuation lines $! deck_lines already contains number of lines within $DECK/$EOD pairs $! Save numer 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 label ""!AS"" not found $! LNR label ""!AS"" not referenced (warning) $! RLI referenced label ""!AS"" is in if-group at lines !UL-!UL $! RLS referenced label ""!AS"" is in subroutine at lines !UL-!UL $! TLS 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 - 1 $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)) $ dcl_record = f$extract(5,(f$length(dcl_record)-5),dcl_record) $! $ if line_number .gt. line_to_display $ then $ say f$fao("...processing line number !UL...",line_number) $ line_to_display = line_to_display + (line_disply_increment * 2) $ endif $! $! Now scan the line for "/END","/ERR[OR]","GOTO ","GOSUB " "CALL " - $! (Remember -- the line was UPCASEd in pass 1) $! $ rescan = 0 ! set to 1 to rescan rest of line for /END and /ERR $! because you can have BOTH of thes on the same command. $! $scan_for_labels_used: $! $ if f$locate("/END",dcl_record) .lt. f$length(dcl_record) $ then ! found $ rescan = 1 $ dcl_record = - f$extract(f$locate("/END",dcl_record),999,dcl_record) - "/END" $! Remove the rest of /end_OF_FILE, the "=" and any spaces $end_qual_loop: $ if f$extract(0,1,dcl_record) .nes. "=" $ then $ dcl_record = f$extract(1,999,dcl_record) $ goto end_qual_loop $ endif $ dcl_record = f$extract(1,999,dcl_record) $ if f$extract(0,1,dcl_record) .eqs. " " $ then $ dcl_record = f$extract(1,999,dcl_record) $ endif $ goto check_for_label $ endif $! $ if f$locate("/ERR",dcl_record) .lt. f$length(dcl_record) $ then ! found $ rescan = 1 $ dcl_record = - f$extract(f$locate("/ERR",dcl_record),999,dcl_record) - "/ERR" $! Remove the rest of /errOR, the "=" and any spaces $err_qual_loop: $ if f$extract(0,1,dcl_record) .nes. "=" $ then $ dcl_record = f$extract(1,999,dcl_record) $ goto err_qual_loop $ endif $ dcl_record = f$extract(1,999,dcl_record) $ if f$extract(0,1,dcl_record) .eqs. " " $ then $ dcl_record = f$extract(1,999,dcl_record) $ endif $ goto check_for_label $ endif $! $ if f$locate("GOTO ",dcl_record) .lt. f$length(dcl_record) $ then ! found $ dcl_record = - f$extract(f$locate("GOTO",dcl_record),999,dcl_record) - "GOTO " $goto_qual_loop: $! Remove the "=" and any spaces $ if f$extract(0,1,dcl_record) .eqs. " " $ then $ dcl_record = f$extract(1,999,dcl_record) $ goto goto_qual_loop $ endif $ goto check_for_label $ endif $! $ if f$locate("GOSUB ",dcl_record) .lt. f$length(dcl_record) $ then ! found $ dcl_record = - f$extract(f$locate("GOSUB",dcl_record),999,dcl_record) - "GOSUB " $gosub_qual_loop: $! Remove the any spaces $ if f$extract(0,1,dcl_record) .eqs. " " $ then $ dcl_record = f$extract(1,999,dcl_record) $ goto gosub_qual_loop $ endif $ goto check_for_label $ endif $! $ if f$locate("CALL ",dcl_record) .lt. f$length(dcl_record) $ then ! found $ dcl_record = - f$extract(f$locate("CALL",dcl_record),999,dcl_record) - "CALL " $call_qual_loop: $! Remove the any spaces $ if f$extract(0,1,dcl_record) .eqs. " " $ then $ dcl_record = f$extract(1,999,dcl_record) $ goto call_qual_loop $ endif $ goto check_for_label $ endif $! $ goto read_dcl2 $! $check_for_label: $! At this point a label is the first token on the line. $! it could be terminated by a space (" ") or slash ("/") $ label = "" $ l = 0 $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 target label ""!AS"" provided by symbol substitution (warning)", - line_number,label) $ if rescan then goto scan_for_labels_used $ goto read_dcl2 $ endif $! $! Check to see if its in the label file $ read /err=no_such_label /key="''f$fao("!255AS",label)'" label_file label_rec $! Extract the line number of the label $ label_line = f$extract(1,5,label_rec) $! Mark the label as having been referenced $ if f$extract(0,1,x) .nes. "!" $ then $ label_rec[0,1] := "1" $ write/symbol/update label_file label_rec $ endif $! $! 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 $read_next_if: $! get the start and end of the if range $ if_start = f$extract(0,5,if_rec) $ if_end = f$extract(5,5,if_rec) $ 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 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 referenced label ""!AS"" is in subroutine at lines !UL-!UL", - line_number,label,f$integer(if_start),f$integer(if_end)) $ endif $ endif $ else ! try again $ read /err=endif_range if_file if_rec $ goto read_next_if $ endif $! $endif_range: $! $ if rescan then goto scan_for_labels_used $ goto read_dcl2 $! $no_such_label: $! $ if .not. suppress_LNF then write err_file f$fao( - "!5UL LNF label ""!AS"" not found", - line_number,label) $ if rescan then goto scan_for_labels_used $ goto read_dcl2 $! $end_dcl2: $! $ close work_file $ close label_file $ close if_file $! $ open /read label_file sys$scratch:dcl$label_'pid'.idx $read_label: $ read/end=end_label label_file x $ if f$extract(0,1,x) .eqs. "1" then goto read_label $ 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 label ""!AS"" not referenced (warning)", - line_number,label) $ 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 invalied character found (#, %, ^ or &) $! ICO invalid comparison operator", - $! LC line contains END_IF, END IF, GO_TO, GO TO, GO_SUB or GO SUB", - $! $! delete any "left over" files 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$spell_''pid'.tmp") .nes. "" then - delete /nolog sys$scratch:dcl$spell_'pid'.tmp;* $! $! $! Search for invalid characters -- $! #, %, ^ and & are not valied 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)) $! $! % and & may be used correctly (wild card and sybol 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 invalid character found (#, %, ^ or &) (warning)", - line_number) $ else ! not a warning $ if .not. suppress_ICF then write err_file f$fao( - "!5UL ICF invalid character found (#, %, ^ or &)", - line_number) $ endif $ 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. ", - " .gs. "," .ls. "," .es. "," .ns. ", - ">","<",">=","=>","<=","=<"," _ " $ work_status = $status $! $status %X08D78053 indicates "No strings found" $ if work_status .eq. %X08D78053 $ then $ comp_op_found = 0 $ else $ comp_op_found = 1 $ 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 invalid comparison operator", - line_number) $ goto read_search1 $end_search1: $ close search_file $ endif $! $ 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 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 $! $ 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 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 "" $ write rep_file " LINE CODE --DIAGNOSTIC MESSAGE--" $ 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 "" $ say " LINE CODE --DIAGNOSTIC MESSAGE--" $ type sys$scratch:dcl$error_'pid'.tmp $ 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 "" $ say "-*- No errors found -*- ''f$time()'" $ if ( (p2 .nes. "") .and. (p2 .nes. "$") ) then - say "...listing file not created ''dcl_end_time'" $ endif $! $ goto common_exit $! $! ------------------------------------------------------------ $! Exit routines $! $y_exit: ! Ctrl_y exit routine $! $! Display Ctrl_y message $! $ write sys$output "Exiting due to Ctrl_y entry" $! $! Choose exactly ONE of the following $! $ goto 1_exit $! $! $err_exit: ! error/warning exit routine $! $ sav_status = $status $err_exit_w_status: $ write sys$output 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 $ goto common_exit $! $0_exit: ! Go here to exit with status 0 = warning $! %NONAME-W-NOMSG, Message number 00000000 $! $! Display warning message $! $ write sys$output f$message(sav_status) $! $! Use %x10000000 to set warning severity but not display %NONAME-W-NOMSG. $! The high order bit suppresses display of the message. $! This prevents re-displaying the message when we EXIT SAV_STATUS. $ sav_status = %x10000000 $ 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 $! $ write sys$output f$message(sav_status) $! $! Note: success messages aren't displayed by EXIT SAV_STATUS. $! Don't need to use %x10000001. $ sav_status = 1 $ goto common_exit $! $2_exit: ! Go here to force exit with status 2 = error $! %NONAME-E-NOMSG, Message number 00000002 $! $! Display error message $! $ write sys$output f$message(sav_status) $! $! Use %x10000002 to set warning severity but not display %NONAME-W-NOMSG. $! The high order bit suppresses display of the message. $! This prevents re-displaying the message when we EXIT SAV_STATUS. $ sav_status = %x10000002 $ goto common_exit $! $3_exit: ! Go here to force exit with status 3 = information $! %NONAME-I-NOMSG, Message number 00000003 $! $! Display infomrational message $! $ write sys$output f$message(sav_status) $! $! Note: success messages aren't displayed by EXIT SAV_STATUS. $! Don't need to use %x10000003. $ sav_status = 3 $ goto common_exit $! $4_exit: ! Go here to force exit with status 4 = fatal $! %NONAME-F-NOMSG, Message number 00000004 $! $! Display fatal error message $! $ write sys$output "%FAC-I-MSG " $! $! Use %x10000004 to set warning severity but not display %NONAME-W-NOMSG. $! The high order bit suppresses display of the message. $! This prevents re-displaying the message when we EXIT SAV_STATUS. $ sav_status = %x10000004 $ 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_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$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$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... $! $! $! Exit with status $! $ exit sav_status