COMPILATION LISTING OF SEGMENT hcom_parse_
	Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986
	Compiled at: Honeywell Bull, Phx. Az., Sys-M 
	Compiled on: 04/26/87  1556.1 mst Sun
	    Options: optimize map

        1 
        2 
        3 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
        4 	/*							*/
        5 	/* COMPILED OUTPUT OF SEGMENT  hcom_parse_.rd                  	*/
        6 	/* Compiled by:  reduction_compiler, Version 2.5 of Oct 21, 1985      */
        7 	/* Compiled on:  04/26/87  1556.1 mst Sun                             */
        8 	/*							*/
        9 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
       10 
       11 /* ***********************************************************
       12*   *                                                         *
       13*   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
       14*   *                                                         *
       15*   *********************************************************** */
       16 
       17 /* HISTORY COMMENTS:
       18*  1) change(85-09-03,LJAdams), approve(85-11-06,MCR7278),
       19*     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
       20*     Parses and validates the history comments.
       21*  2) change(86-04-17,LJAdams), approve(86-05-19,MCR7386),
       22*     audit(86-05-19,Gilcrease), install(86-06-05,MR12.0-1071):
       23*     Added error message parameter for validate programs.  Changed so
       24*     that only 1 error message is put out for all programs called.
       25*  3) change(86-08-28,LJAdams), approve(86-08-28,MCR7526),
       26*     audit(86-11-05,GDixon), install(86-11-12,MR12.0-1213):
       27*     error_msg was not getting initialized  which resulted in garbage being
       28*     displayed.  Set d.Scfix to True when first critical fix number is
       29*     encountered; thereby preventing addition of non-critical fix numbers.
       30*  4) change(87-03-26,LJAdams), approve(87-03-26,MCR7653),
       31*     audit(87-04-22,Gilcrease), install(87-04-26,MR12.1-1026):
       32*     If comment is greater than max length allowed put char value of
       33*     comment length in src_array_comment.err_msg.
       34*  5) change(87-03-30,LJAdams), approve(87-03-30,MCR7653),
       35*     audit(87-04-22,Gilcrease), install(87-04-26,MR12.1-1026):
       36*     Put in check for pre-b2 cmts must have null approve, null audit, and null
       37*     install fields present.
       38*                                                   END HISTORY COMMENTS */
       39 
       40 hcom_parse_:
       41   proc (ERROR_RETURN_LABEL, seg, cmt, path, Sprt_path, Pd, src_array_comment, code);
       42 
       43 dcl ERROR_RETURN_LABEL         label parameter,
       44     seg	                     char(*),
       45     cmt			 char(*),
       46     code			 fixed bin(35),
       47     path			 char(*),
       48     Sprt_path		 bit(1);
       49 
       50 /*++
       51*INCLUDE                        ERROR\
       52*
       53*BEGIN 
       54*
       55*           / <decimal-integer> ) change ( <date> , <change_pers> ) /
       56*                               [src_array_comment.comment_no = token.Nvalue]
       57*			 LEX(4)
       58*			 [src_array_comment.change_dt = date_out] 
       59*			 LEX(2)
       60*			 [src_array_comment.change_person = person]
       61*			 LEX(2)
       62*                               / punct \
       63*
       64*2          / <decimal-integer> ) change ( <date> , <change_pers> <any-token> /
       65*                               LEX(7)
       66*			 MY_ERROR(19) / RETURN \
       67*3          / <decimal-integer> ) change ( <date> , <any-token> /
       68*                               LEX(6)
       69*			 MY_ERROR(3) / RETURN \
       70*4          / <decimal-integer> ) change ( <any-token> /
       71*	                     LEX(4)
       72*	                     MY_ERROR(2) / RETURN \
       73*5          / <any-token> )     / MY_ERROR(1) / RETURN \
       74*6	 / <any-token>	 / MY_ERROR(4) / RETURN \
       75*7	 / <no-token>	 / MY_ERROR(5) / RETURN \
       76*
       77*punct 	 / :		 / LEX
       78*			 set_text 
       79*			 / RETURN \
       80*9          / ,		 / LEX
       81*			 / opt \
       82*10         / <any-token>       / MY_ERROR(6) /RETURN \
       83*11         / <no-token>        / MY_ERROR(7) /RETURN \
       84*
       85*opt        / approve (         / 
       86*			 / opt_arg \
       87*13	 / audit (           /
       88*                               / opt_arg \
       89*14	 / install (         /
       90*                               / opt_arg \
       91*15         / <any-token> (     / MY_ERROR(16) /RETURN\
       92*16         / <any-token>       / MY_ERROR(17) /RETURN \
       93*17         / <no-token>        / MY_ERROR(18) /RETURN \
       94*
       95*opt_arg	 / approve ()        /
       96*                               [src_array_comment.approve_dt = "^"]
       97*			 [src_array_comment.approve_value = ""]
       98*                               [null_approve = True]
       99*			 LEX(3)
      100*			 / punct \
      101*	 \" The reduction above allows comments created prior to existence of
      102*	 \" hcom command to appear to have a nonempty approve field, even
      103*	 \" those no date or approval value is known/specified.  The ^ date
      104*	 \" value makes comments with such a field match the approve comment
      105*	 \" specifier.
      106*19	 / approve ( <date> , <apv_id> ) /
      107*			 LEX(2)
      108*			 [src_array_comment.approve_dt = date_out]
      109*			 LEX(2)
      110*			 [src_array_comment.approve_value = ident] 
      111*                               LEX(2)
      112*                               / punct \  
      113*20         / audit ()          /
      114*                               [src_array_comment.audit_dt = "^"]
      115*			 [src_array_comment.audit_person = ""]
      116*			 [null_audit = True]
      117*			 LEX(3)
      118*			 / punct \
      119*	 \" Allow pre-hcom comments with unknown audit fields to appear
      120*	 \" to be audited.
      121*21         / audit ( <date> , <audit_pers> ) /
      122*			 LEX(2)
      123*			 [src_array_comment.audit_dt = date_out]
      124*			 LEX(2)
      125*			 [src_array_comment.audit_person = person] 
      126*			 LEX(2)
      127*                               / punct \  
      128*22         / install ()        /
      129*                               [src_array_comment.install_dt = "^"]
      130*			 [src_array_comment.install_id = ""]
      131*			 [null_install = True]
      132*			 LEX(3)
      133*			 / punct \
      134*	 \" Allow pre-hcom comments with unknown install fields to appear
      135*	 \" to be installed.
      136*23         / install ( <date> , <install_id> ) /
      137*			 LEX(2)
      138*			 [src_array_comment.install_dt = date_out]
      139*			 LEX(2)
      140*			 [src_array_comment.install_id = ident] 
      141*			 LEX(2)
      142*                               / punct \  
      143*24         / approve ( <date> , <apv_id> <any-token> /
      144*                               LEX(5)
      145*			 MY_ERROR(19) / RETURN \
      146*25         / approve ( <date> , <any-token> /
      147*                               LEX(4)
      148*			 MY_ERROR(11) / RETURN \
      149*26         / approve ( <any-token> /
      150*                               LEX(2)
      151*                               MY_ERROR(10) / RETURN \
      152*27         / approve <any-token> /
      153*                               LEX
      154*                               MY_ERROR(6) / RETURN \
      155*28         / audit ( <date> , <audit_pers> <any-token> /
      156*                               LEX(5)
      157*			 MY_ERROR(19) / RETURN \
      158*29         / audit ( <date> , <any-token> /
      159*                               LEX(4)
      160*			 MY_ERROR(13) / RETURN \
      161*30         / audit ( <any-token> /
      162*                               LEX(2)
      163*			 MY_ERROR(12) / RETURN \
      164*31         / audit <any-token> /
      165*                               LEX
      166*                               MY_ERROR(6) / RETURN \
      167*32         / install ( <date> , <install_id> <any-token> /
      168*                               LEX(5)
      169*                               MY_ERROR(19) / RETURN \			 
      170*33         / install ( <date> , <any-token> /
      171*                               LEX(4)
      172*                               MY_ERROR(15) / RETURN \			 
      173*34         / install ( <any-token> /
      174*                               LEX(2)
      175*			 MY_ERROR(14) / RETURN \
      176*35         / install <any-token> /
      177*                               LEX
      178*                               MY_ERROR(6) / RETURN \
      179*36         / <any-token>	 / MY_ERROR(8) / RETURN \
      180*37	 / <no-token>	 / MY_ERROR(9) / RETURN \
      181*++*/
      182 
      183 /* close set of reductions   */
      184 
  1     1 /*  START OF:	hcom_data.incl.pl1		  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  1     2 
  1     3 	
  1     4 /****^  HISTORY COMMENTS:
  1     5*  1) change(85-10-02,LJAdams), approve(85-11-06,MCR7278),
  1     6*     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
  1     7*     Provides data structure for the history comment
  1     8*     programs.
  1     9*  2) change(86-04-17,LJAdams), approve(86-04-17,MCR7386),
  1    10*     audit(86-06-05,Gilcrease), install(86-06-05,MR12.0-1071):
  1    11*     Added d.ag.ctl.fill to indicate if summary is to be filled or not.
  1    12*     Added fill bit to src_array to indicate to fill/not fill comment.
  1    13*  3) change(86-04-30,LJAdams), approve(86-05-05,MCR7386),
  1    14*     audit(86-06-05,Gilcrease), install(86-06-05,MR12.0-1071):
  1    15*     Added parameter to d.ag.vdt to contain error message.
  1    16*  4) change(86-05-05,LJAdams), approve(86-05-05,MCR7386),
  1    17*     audit(86-06-05,Gilcrease), install(86-06-05,MR12.0-1071):
  1    18*     Added switch to indicate if a critical fix number had been found while
  1    19*     parsing.
  1    20*                                                   END HISTORY COMMENTS */
  1    21 
  1    22 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  1    23 	/*									*/
  1    24 	/* This include file contains the arguments needed for processing history comments.	*/
  1    25 	/*									*/
  1    26 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  1    27 
  1    28 
  1    29 dcl 	1 d			aligned based(Pd),
  1    30 	  2 ag,
  1    31 	    3 op,
  1    32 	      4 name		fixed bin,
  1    33 	      4 type		bit(1),		/* 0 = NO_MODIFY, 1 = MODIFY			*/
  1    34 	    3 vdt			entry (char(*) var, char(*) var, char(*) var, bit(1), char(*) var,
  1    35 				   char(*) var, char(100) var) variable,
  1    36 						/* = nothing for -nvdt			*/
  1    37 	    3 ctl,
  1    38 	      4 errors		bit(1) unal,
  1    39 	      4 fill                  bit(1) unal,
  1    40 	      4 renumber		bit(1) unal,
  1    41 	      4 mbz		bit(33) unal,
  1    42 	    3 source,
  1    43 	      4 path		char(202) unal,
  1    44 	      4 dir		char(168) unal,
  1    45 	      4 ent		char(32) unal,
  1    46 	      4 ent_type		fixed bin(35),	/*  0 = NONSTAR,  1 = STAR,   2 = STARSTAR	*/
  1    47 	      4 comp		char(32) unal,
  1    48 	    3 orig		like d.source,
  1    49 	    3 input,
  1    50 	      4 select,
  1    51 	        5 sm		fixed bin(2),
  1    52 	        5 apv		fixed bin(2),
  1    53 	        5 aud		fixed bin(2),
  1    54 	        5 in		fixed bin(2),	/* 0 = NOxxx,      1 = CLEARxxx		*/
  1    55 						/* 2 = OPERANDxxx, 3 = INPUTxxx		*/
  1    56 	      4 value                like src_array.comments,
  1    57 	    3 output,
  1    58 	     (4 cdt,
  1    59 	      4 cpi,
  1    60 	      4 apvdt,
  1    61 	      4 apvi,
  1    62 	      4 auddt,
  1    63 	      4 audpi,
  1    64 	      4 indt,
  1    65 	      4 ini,
  1    66 	      4 sm)		bit(1) unal,
  1    67 	      4 mbz		bit(27) unal,
  1    68 	  2 com_spec,
  1    69 	    3 selected		unal,
  1    70 	      4 all		bit(1),
  1    71 	      4 old		bit(1),
  1    72 	      4 new		bit(1),
  1    73 	      4 cpt		bit(1),
  1    74 	      4 icpt		bit(1),
  1    75 	      4 apv		bit(1),
  1    76 	      4 unapv		bit(1),
  1    77 	      4 aud		bit(1),
  1    78 	      4 unaud		bit(1),
  1    79 	      4 in		bit(1),
  1    80 	      4 unin		bit(1),
  1    81                 4 mbz		bit(25),
  1    82 	    3 matched		unaligned like d.com_spec.selected,
  1    83 	    3 Nrange		fixed bin,
  1    84 	    3 range (10),
  1    85 	      4 from,
  1    86 	        5 set		fixed bin(2),	/* 0 = UNSET, 1 = SET,  2 = LAST		*/
  1    87 	        5 no		fixed bin,
  1    88 	        5 op		fixed bin(2),	/* 0 = UNSET, 1 = PLUS  2 = MINUS		*/
  1    89 	        5 addend		fixed bin,
  1    90 	        5 result		fixed bin,
  1    91 	      4 to		like d.com_spec.range.from,
  1    92 	      4 matched		fixed bin(1),
  1    93 
  1    94 	  2 field_array (9)		fixed bin,
  1    95 	  2 check_error$fatal	entry options(variable) variable,
  1    96             2 set_return_arg            entry (char(*)) variable,
  1    97             2 add_to_return_arg	entry (char(*)) variable,
  1    98 	  2 add_to_return_arg_var     entry (char(*) var) variable,
  1    99             2 Saf                       bit(1),		/* switch to indicate active function		*/
  1   100 
  1   101 	  2 Scfix			bit(1),		/* switch to indicate critical fix input	*/
  1   102 	  2 Scfix_found               bit(1),
  1   103 	  2 Ssite                     bit(1),             /* switch to indicate site			*/
  1   104 	  2 seg_arch,				/* info for seg or achive used by 		*/
  1   105 	    3 dir			char(168) unal,	/* hcom_process_path_			*/
  1   106 	    3 ent			char(32) unal,
  1   107 	    3 comp		char(32) unal,
  1   108 	    3 comp_type		fixed bin(35),      /* -1 = NOCOMP, 0 = NONSTAR			*/
  1   109 						/*  1 = STAR,   2 = STARSTAR			*/
  1   110 	    3 Pseg		ptr,
  1   111 	    3 Lseg		fixed bin(21),
  1   112 	    3 Lsegbc		fixed bin(24),
  1   113 
  1   114 	  2 seg,					/* info for specific seg or archive component	*/
  1   115 	    3 dir			char(168) unal,	/* used by hcom_process_seg_.			*/
  1   116 	    3 ent			char(32) unal,
  1   117 	    3 comp		char(32) unal,
  1   118 	    3 Pseg		ptr,
  1   119 	    3 Lseg_in		fixed bin(21),
  1   120 	    3 Lseg_out		fixed bin(21),
  1   121 	    3 ec_version		fixed bin,	/* if type is 3 (an exec_com), this will be its	*/
  1   122 						/* version, as obtained from get_ec_version_	*/
  1   123               3 type                    fixed bin,	/* the language type of the entry		*/
  1   124 	    3 text_pos                fixed bin(21),	/* this will be the char pos of the first	*/
  1   125 						/* non-version char in an exec_com		*/
  1   126 	    3 cmt_bgn                 char(8) var,	/* comment begin character(s)			*/
  1   127               3 cmt_end                 char(8) var,	/* comment end character(s)			*/
  1   128 	    3 Pbox		ptr,
  1   129 	    3 Loldbox		fixed bin(21),
  1   130 	    3 Lnewbox		fixed bin(21),
  1   131 	  2 orig_seg		like d.seg,	/* info for original seg/comp used by		*/
  1   132 						/* hcom_process_seg_			*/
  1   133 
  1   134 	  2 temp_seg,
  1   135 	    3 Pcomp_info		ptr,
  1   136 	    3 Pformed_string	ptr,
  1   137 	    3 Porig_array		ptr,
  1   138 	    3 Pout_string		ptr,
  1   139 	    3 Presult		ptr,
  1   140 	    3 Psort_copy		ptr,
  1   141 	    3 Psrc_array		ptr,
  1   142 	temp_seg_array (7)		ptr aligned based (addr(d.temp_seg)),
  1   143 
  1   144 	Pd              		ptr;
  1   145 
  1   146 dcl	CALLER			char(15) int static options(constant) init("history_comment"),
  1   147 
  1   148          (NOTSET			init(0),		/* values for d.ag.op.name			*/
  1   149 	ADD			init(1),
  1   150 	ADD_FIELD			init(2),
  1   151 	CHECK			init(3),
  1   152           COMPARE			init(4),
  1   153 	DISPLAY			init(5),
  1   154 	EXISTS			init(6),
  1   155 	FORMAT			init(7),
  1   156 	GET			init(8),
  1   157 	INSTALL			init(9),
  1   158 	REPLACE_FIELD		init(10)) fixed bin int static options(constant),
  1   159          (MODIFY			init("1"b),	/* values for d.ag.op.type			*/
  1   160 	NO_MODIFY			init("0"b)) bit(1) int static options(constant),
  1   161          (CLEARxxx			init(1),		/* values for d.ag.input.select		*/
  1   162 	INPUTxxx			init(3),
  1   163 	NOxxx			init(0),
  1   164 	OPERANDxxx		init(2)) fixed bin(2) int static options(constant),
  1   165          (NOCOMP			init(-1),		/* values for d.ag.ent_type, and 		*/
  1   166 	NONSTAR			init(0),		/*   d.seg_arch.comp_type			*/
  1   167 	STAR			init(1),
  1   168 	STARSTAR		          init(2)) fixed bin(35) int static options(constant),
  1   169 	ALL			bit(36) aligned int static options(constant) init("1"b),
  1   170 						/* value comparable to string(d.com_spec.selected)*/
  1   171          (LAST			init(2),		/* values for d.ag.com_spec.range.set		*/
  1   172 	SET			init(1),
  1   173 	UNSET			init(0)) fixed bin(2) int static options(constant),
  1   174          (MINUS			init(2),		/* values for d.ag.com_spec.range.op		*/
  1   175 	PLUS			init(1)) fixed bin(2) int static options(constant);
  1   176 	
  1   177 dcl	oper (10,2)         	char(16) varying int static options(constant) init (
  1   178                                "add",            "~",      /*  1 Operations */
  1   179 			 "add_field",      "af",     /*  2 */
  1   180 			 "check",          "ck",     /*  3 */
  1   181                                "compare",        "cmp",    /*  4 */
  1   182 			 "display",        "ds",     /*  5 */
  1   183 			 "exists",         "~",      /*  6 */
  1   184 			 "format",         "fmt",    /*  7 */
  1   185 			 "get",	         "~",      /*  8 */
  1   186 			 "install",        "~",      /*  9 */
  1   187 			 "replace_field",  "rpf");   /* 10 */
  1   188 
  1   189 dcl	1 src_array		based(Psrc_array) aligned,
  1   190 	  2 Ncoms			fixed bin,
  1   191 	  2 comments (0 refer (src_array.Ncoms)),
  1   192 	    3 change_dt		char(8),
  1   193 	    3 seqno		pic "9999",
  1   194 	    3 fill		bit(1),
  1   195 	    3 selected		bit(1),
  1   196 	    3 Ieq			fixed bin,
  1   197 	    3 comment_no		fixed bin,
  1   198 	    3 change_person		char(24) varying,
  1   199 	    3 approve_dt		char(8),
  1   200 	    3 approve_value		char(24) varying,
  1   201 	    3 audit_dt		char(8),
  1   202 	    3 audit_person		char(24) varying,
  1   203 	    3 install_dt		char(8),
  1   204 	    3 install_id		char(24) varying,
  1   205 	    3 summary		char(2000) varying,
  1   206 	    3 err_msg (5)		char(80) varying;
  1   207 	
  1   208 
  1   209 dcl	Psrc_array		ptr;
  1   210 
  1   211 /*  END OF:	hcom_data.incl.pl1		  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
      185 
      186 
      187 dcl 1 src_array_comment   aligned like src_array.comments;
      188 
      189 dcl 1 error_control_table (19) internal static options (constant),
      190       2 severity               fixed bin (17) unal init ((19) 3),
      191       2 Soutput_stmt	 bit(1) unal init ((19) (1) "1"b),
      192       2 message		 char(80) varying init (
      193       /* ERROR 1*/             "The history comment number (^a) is not a decimal number.",
      194       /* ERROR 2*/             "The history comment contains an invalid date (^a).",
      195       /* ERROR 3*/             "The history comment contains an invalid person id (^a).",
      196       /* ERROR 4*/             "The history comment contains an incorrect line.",
      197       /* ERROR 5*/             "The history comment is empty.",
      198       /* ERROR 6*/             "The history comment contains invalid punctuation (^a).",
      199       /* ERROR 7*/		 "The history comment contains no punctuation",
      200       /* ERROR 8*/		 "The history comment contains an invalid option (^a).",
      201       /* ERROR 9*/		 "The history comment ends improperly before the summary.",
      202       /* ERROR10*/             "The approve date (^a) is invalid.",
      203       /* ERROR11*/		 "The approve value (^a) is invalid.",
      204       /* ERROR12*/		 "The audit date (^a) is invalid.",
      205       /* ERROR13*/		 "The audit person (^a) is invalid.",
      206       /* ERROR14*/		 "The install date (^a) is invalid.",
      207       /* ERROR15*/		 "The install id (^a) is invalid.",
      208       /* ERROR16*/             "The history comment has an invalid option name (^a).",
      209       /* ERROR17*/             "The history comment is missing left parenthesis.",
      210       /* ERROR18*/             "The history comment ends with invalid punctuation (^a).",
      211       /* ERROR19*/             "The history comment is missing right parenthesis"),
      212       2 brief_message	 char(4) varying init((19) (1) " ");
      213   
      214 dcl 1 cond_info                aligned like condition_info;
      215 
      216 dcl com_err_	           entry() options(variable);
      217 
      218 dcl error_table_$bigarg	 fixed bin(35) ext static;
      219 dcl error_table_$improper_data_format
      220 			 fixed bin(35) ext static;
      221 
      222 dcl find_condition_info_	 entry (ptr, ptr, fixed bin(35));
      223 
      224 dcl hcom_cfix_validate_	 entry (char(*) var, char(*) var, char(*) var, bit(1),
      225                                              char(*) var, char(*) var, char(100) var);
      226 
      227 dcl hcom_site_validate_	 entry (char(*) var, char(*) var, char(*) var, bit(1) aligned,
      228 				     char(*) var, char(*) var, char(100) var);
      229 
      230 dcl hcom_default_validate_	 entry (char(*) var, char(*) var, char(*) var, bit(1) aligned,
      231 				     char(*) var, char(*) var, char(100) var);
      232 
      233 dcl lex_string_$init_lex_delims
      234                                entry (char(*), char(*), char(*), char(*), char(*), bit(*),
      235 				     char(*) var, char(*) var, char(*) var, char(*) var);
      236 
      237 dcl lex_string_$lex		 entry (ptr, fixed bin(21), fixed bin(21), ptr, bit(*), char(*),
      238                                              char(*), char(*), char(*), char(*), char(*) var, char(*) var,
      239 			               char(*) var, char(*) var, ptr, ptr, fixed bin(35));
      240 
      241 dcl LEXDLM                     char(128) varying internal static,
      242     LEXCTL		 char(128) varying internal static;
      243 
      244 dcl convert_date_to_binary_	 entry (char(*), fixed bin(71), fixed bin(35)),
      245     date_time_$format	 entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var),
      246     ioa_			 entry() options(variable),
      247     pathname_$component	 entry (char(*), char(*), char(*)) returns(char(194)),
      248     translator_temp_$get_segment 
      249                                entry (char(*), ptr, fixed bin(35)),
      250 
      251     translator_temp_$release_all_segments 
      252                                entry (ptr, fixed bin(35));
      253 
      254 dcl error_table_$translation_failed 
      255 			fixed bin(35) ext static;
      256 dcl (addr,
      257      addcharno,
      258      charno,
      259      char,
      260      dimension,
      261      index,
      262      length,
      263      maxlength,
      264      null,
      265      reverse,
      266      substr,
      267      verify)          	 builtin;
      268 
      269 dcl  proc_ptr		 ptr,
      270      Ccode		 fixed bin(35);
      271 
      272 dcl  BREAKS                    char(9) varying int static options(constant) init ("	 (),:
      273 ");
      274      /* break characters consist of HT,VT,SP,RP,LP,CM,CLN,NL,NP  */  
      275 dcl IGBREAKS                   char(5) varying int static options(constant) init("	 
      276 ");
      277      /* ignore break characters consist of HT,VT,NP,SP,NL    */
      278 
      279 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      280 
      281 
      282 dcl APstmt                     ptr,
      283     APtoken		 ptr;
      284 
      285 dcl Lignore		 fixed bin(21);
      286 
      287 dcl (cleanup, command_question)  condition;
      288 
      289 dcl True			 bit(1) internal static options (constant) init("1"b),
      290     False			 bit(1) internal static options (constant) init("0"b);
      291 
      292 dcl (null_approve,
      293      null_audit,
      294      null_install)               bit (1);
      295 
      296 dcl valid			 bit(1),
      297     Serrors		 bit(1);
      298 
      299 dcl error_msg                  char(100) varying;
      300 
      301 Serrors = False;
      302 error_msg = "";
      303 
      304 null_approve, null_audit, null_install = False;
      305 
      306 if ^d.ag.ctl.errors then
      307    MIN_PRINT_SEVERITY = 4;
      308 
      309 proc_ptr = null;
      310 on cleanup
      311   call JANITOR();
      312   
      313 Lignore = charno(addr(cmt)) - charno(addr(seg));
      314 
      315 call translator_temp_$get_segment (CALLER, proc_ptr, code);
      316 if code ^= 0 then 
      317   call JANITOR;
      318 
      319 	/* BREAKS consist of HT VT SP RP LP CM NL NP                */
      320 	/* IGBREAKS to ignore consist of HT VT NP SP NL             */
      321 
      322 call lex_string_$init_lex_delims ("","","","","","11"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL);
      323 
      324 call lex_string_$lex (addr(seg), length(cmt)+Lignore, Lignore, proc_ptr, "0000"b,"","","","","",BREAKS,
      325   IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, code);
      326 
      327 Pthis_token = APtoken;
      328 
      329 call SEMANTIC_ANALYSIS ();
      330 
      331 if Serrors then 
      332   if d.ag.ctl.errors then
      333      call ioa_("^/^a",cmt);
      334 
      335 if MERROR_SEVERITY > 0 then
      336   if code = 0 then
      337     code = error_table_$translation_failed;
      338 call JANITOR;
      339 return;
      340 
      341 JANITOR:
      342   proc;
      343   if proc_ptr ^= null then
      344     call translator_temp_$release_all_segments (proc_ptr, Ccode);
      345   proc_ptr = null;
      346   
      347   if Serrors then
      348      goto ERROR_RETURN_LABEL;
      349 
      350 end JANITOR;
      351 
      352 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      353 
      354 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      355 
      356 
      357 /* RELATIVE SYNTAX FUNCTIONS  */
      358 
      359 dcl clock_time			fixed bin(71),
      360       date_out			char(8) aligned;
      361 
      362 date:
      363   proc () returns(bit(1) aligned);
      364 
      365   dcl code			fixed bin(35);
      366 
      367   call convert_date_to_binary_(token_value,clock_time,code);
      368   if code ^= 0 then
      369      return(False);
      370 
      371   date_out = date_time_$format("^yc-^my-^dm",clock_time,"","");
      372   return(code=0);
      373   
      374 end date;
      375 
      376 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      377 
      378   dcl person			char(24) var,
      379       ident			char(24) var;
      380 
      381 
      382 audit_pers:
      383   proc() returns(bit(1) aligned);
      384   
      385   on command_question
      386      begin;
      387         call set_command_question;
      388         end;
      389 
      390   if d.ag.op.name = REPLACE_FIELD then			/* dont validate fields being replaced		*/
      391      if d.ag.input.select.aud = OPERANDxxx |
      392         d.ag.input.select.aud = INPUTxxx then do;
      393         person = token_value;
      394         return("1"b);
      395         end;
      396 
      397   call d.ag.vdt ((CALLER), AUDIT_FIELD_NAME, (token_value), valid, person, "",error_msg);
      398 
      399   return(valid);
      400   
      401 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      402 
      403 change_pers:
      404   entry() returns(bit(1) aligned);
      405   
      406   on command_question
      407      begin;
      408         call set_command_question;
      409         end;
      410   call d.ag.vdt ((CALLER), AUTHOR_FIELD_NAME, (token_value), valid, person, "", error_msg);
      411 
      412   return(valid);
      413 
      414 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      415 
      416 apv_id:
      417   entry() returns(bit(1) aligned);
      418 
      419   if d.ag.op.name = REPLACE_FIELD then		/* dont validate fields being replaced		*/
      420         if d.ag.input.select.apv = OPERANDxxx |
      421            d.ag.input.select.apv = INPUTxxx then do;
      422            ident = token_value;
      423            return("1"b);
      424 	 end;
      425 
      426   if index(token_value,"fix_") > 0 then do;
      427      Scfix_found = True;
      428      d.Scfix_found = True;
      429      end;
      430 
      431   on command_question
      432      begin;
      433      call set_command_question;
      434      end;
      435   
      436   if Scfix_found then
      437      d.ag.vdt = hcom_cfix_validate_;
      438   else if d.Ssite then
      439      d.ag.vdt = hcom_site_validate_;
      440   else
      441      d.ag.vdt = hcom_default_validate_;
      442 
      443   call d.ag.vdt ((CALLER), APPROVAL_FIELD_NAME, (token_value), valid, ident, "", error_msg);
      444 
      445   return(valid);
      446     
      447 
      448 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      449 
      450 install_id:
      451   entry() returns(bit(1) aligned);
      452   
      453   if d.ag.op.name = REPLACE_FIELD then			/* dont validate fields being replaced		*/
      454      if d.ag.input.select.in = OPERANDxxx |
      455         d.ag.input.select.in = INPUTxxx then do;
      456         ident = token_value;
      457         return ("1"b);
      458         end;
      459 
      460   if Scfix_found then do;
      461      call hcom_cfix_validate_((CALLER), INSTALL_FIELD_NAME, (token_value), valid, ident, "", error_msg);
      462      return(valid);
      463      end;
      464 
      465   on command_question
      466      begin;
      467      call set_command_question;
      468      end;
      469 
      470   call d.ag.vdt ((CALLER), INSTALL_FIELD_NAME, (token_value), valid, ident, "", error_msg);
      471   
      472   return(valid);
      473 
      474 
      475 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      476 set_command_question:
      477   proc;
      478 
      479 dcl answer		 char(command_question_info.answer_lth)
      480 			 based(command_question_info.answer_ptr);
      481 
      482   revert command_question;
      483   cond_info.version = condition_info_version_1;
      484   call find_condition_info_ (null, addr(cond_info), code);
      485   cq_info_ptr = cond_info.info_ptr;
      486   if command_question_info.yes_or_no_sw & 
      487      command_question_info.max_answer_lth >= length("yes") then do;
      488      command_question_info.preset_sw = True;
      489      command_question_info.question_sw = False;
      490      command_question_info.answer_sw = False;
      491      command_question_info.answer_lth = length("yes");
      492      answer = "yes";
      493      end;
      494 end set_command_question;
      495 
      496 RETURN_FALSE:
      497   
      498   return(False);
      499 
      500 end audit_pers;
      501 
      502 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      503 
      504 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      505 
      506 
      507 /* ACTION ROUTINES */
      508 
      509 MY_ERROR:
      510   proc(err_no);
      511 
      512   dcl err_no			fixed bin;
      513 
      514   Serrors = True;
      515 
      516   if ^Sprt_path then do;
      517      if d.ag.ctl.errors then
      518         call ioa_("^a",path);
      519      Sprt_path = True;
      520      end;
      521   
      522   if d.Saf then
      523      call d.set_return_arg ("false");
      524 
      525   if code = error_table_$bigarg then
      526      call com_err_ (code, CALLER,
      527      "^a^/^3xComment ^d is longer than ^d characters.",
      528      pathname_$component(seg.dir,seg.ent,seg.comp),src_array_comment.comment_no,maxlength(d.ag.input.summary));
      529 
      530   call ERROR(err_no);
      531   if error_msg ^= "" then
      532      call ioa_("^3x^a",error_msg);
      533 
      534   return;
      535   
      536 end MY_ERROR;
      537 
      538 
      539 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      540 
      541 
      542 set_text:
      543   proc;
      544   dcl text                     char(Ltext) based(Ptext),
      545       Ptext		 ptr,
      546       Ltext		 fixed bin(21),
      547       text_arr (Ltext)         char(1) based(Ptext),
      548       Ptext_line		 ptr,
      549       Ltext_line		 fixed bin(21),
      550       text_line		 char(Ltext_line) based(Ptext_line),
      551       i			 fixed bin(21),
      552       Iline		 fixed bin(21),
      553       HT_SP_NL_VT              char(4) int static options(constant) init("	 
      554 "),
      555       HT_SP_VT                 char(3) int static options(constant) init("	 "),
      556       SPACES                   char(5) int static options(constant) init("     "),
      557       NL			 char(1) int static options(constant) init("
      558 ");
      559   
      560   
      561   if null_approve & null_audit & ^null_install then do;	/* check to be sure old cmts are properly	*/
      562 						/* formatted.				*/
      563      src_array_comment.err_msg(1) =  char(error_table_$improper_data_format);
      564      return;
      565      end;
      566             
      567   Ptext = (addr(cmt));				/* determine if there is any leading wt space	*/
      568   Ltext = charno(addr(token_value)) - charno(addr(cmt));
      569   i = verify(reverse(text),HT_SP_VT);
      570   Ltext = Ltext - i;
      571 
      572   Ptext = addcharno (addr(text_arr(Ltext)), length(NL)+1);	/* charno is offset 0			*/
      573   
      574   Ltext = length(cmt) - (charno(Ptext) - charno(addr(cmt)));
      575   
      576   if Ltext > maxlength(d.ag.input.summary) then do;
      577      src_array_comment.err_msg(1) = char(error_table_$bigarg);
      578      src_array_comment.err_msg(2) =  char(Ltext);
      579      Ltext = maxlength(d.ag.input.summary);
      580      end;
      581 
      582   do while(Ltext > 0 & verify(text,HT_SP_NL_VT) ^= 0);
      583      Iline = index(text,NL);
      584      if Iline = 0 then do;
      585         Ptext_line = Ptext;
      586         Ltext_line = length(text);
      587         Ltext = 0;
      588         end;
      589      else do;
      590         Ptext_line = Ptext;
      591         Ltext_line = Iline;
      592         if Ltext > Iline then
      593 	 Ptext = addr(text_arr(Iline+1));
      594         Ltext = Ltext - Iline;
      595         end;
      596 
      597      if verify(text_line,HT_SP_NL_VT) = 0 then		/* nothing but white space			*/
      598         src_array_comment.summary = src_array_comment.summary || text_line;
      599      else if substr(text_line,1,5) = SPACES then
      600 						/* hcom_process_seg_ indents every line but the	*/
      601 						/* first five spaces.			*/
      602         src_array_comment.summary = src_array_comment.summary || substr(text_line,6);
      603      else	do;					/* if not using hcom to format spacing may differ */
      604         i = verify(text_line," ");
      605         src_array_comment.summary = src_array_comment.summary || substr(text_line,i);
      606         end;
      607      end;
      608 
      609 end set_text;
      610 
      611 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
  2     1 /* BEGIN INCLUDE FILE condition_info_header.incl.pl1 BIM 1981 */
  2     2 /* format: style2 */
  2     3 
  2     4      declare condition_info_header_ptr
  2     5 			      pointer;
  2     6      declare 1 condition_info_header
  2     7 			      aligned based (condition_info_header_ptr),
  2     8 	     2 length	      fixed bin,		/* length in words of this structure */
  2     9 	     2 version	      fixed bin,		/* version number of this structure */
  2    10 	     2 action_flags	      aligned,		/* tell handler how to proceed */
  2    11 	       3 cant_restart     bit (1) unaligned,	/* caller doesn't ever want to be returned to */
  2    12 	       3 default_restart  bit (1) unaligned,	/* caller can be returned to with no further action */
  2    13 	       3 quiet_restart    bit (1) unaligned,	/* return, and print no message */
  2    14 	       3 support_signal   bit (1) unaligned,	/* treat this signal as if the signalling procedure had the support bit set */
  2    15 						/* if the signalling procedure had the support bit set, do the same for its caller */
  2    16 	       3 pad	      bit (32) unaligned,
  2    17 	     2 info_string	      char (256) varying,	/* may contain printable message */
  2    18 	     2 status_code	      fixed bin (35);	/* if^=0, code interpretable by com_err_ */
  2    19 
  2    20 /* END INCLUDE FILE condition_info_header.incl.pl1 */
      612 
      613 
  3     1 /* BEGIN INCLUDE FILE ... condition_info.incl.pl1 */
  3     2 
  3     3 /* Structure for find_condition_info_.
  3     4*
  3     5*   Written 1-Mar-79 by M. N. Davidoff.
  3     6**/
  3     7 
  3     8 /* automatic */
  3     9 
  3    10      declare condition_info_ptr     pointer;
  3    11 
  3    12 /* based */
  3    13 
  3    14      declare 1 condition_info	      aligned based (condition_info_ptr),
  3    15 	     2 mc_ptr	      pointer,		/* pointer to machine conditions at fault time */
  3    16 	     2 version	      fixed binary,		/* Must be 1 */
  3    17 	     2 condition_name     char (32) varying,	/* name of condition */
  3    18 	     2 info_ptr	      pointer,		/* pointer to the condition data structure */
  3    19 	     2 wc_ptr	      pointer,		/* pointer to wall crossing machine conditions */
  3    20 	     2 loc_ptr	      pointer,		/* pointer to location where condition occured */
  3    21 	     2 flags	      unaligned,
  3    22 	       3 crawlout	      bit (1),		/* on if condition occured in lower ring */
  3    23 	       3 pad1	      bit (35),
  3    24 	     2 pad2	      bit (36),
  3    25 	     2 user_loc_ptr	      pointer,		/* ptr to most recent nonsupport loc before condition occurred */
  3    26 	     2 pad3	      (4) bit (36);
  3    27 
  3    28 /* internal static */
  3    29 
  3    30      declare condition_info_version_1
  3    31 			      fixed binary internal static options (constant) initial (1);
  3    32 
  3    33 /* END INCLUDE FILE ... condition_info.incl.pl1 */
      614 
      615 
  4     1 /* BEGIN INCLUDE FILE:  command_question_info.incl.pl1 */
  4     2 
  4     3 /*	Last modified: 11/02/78 W. Olin Sibert to change to version 5 and make compatible with query_info */
  4     4 /* Added explanation_ptr & explanation_len (Version 6) 05/13/81 S. Herbst */
  4     5 /* switched to condition_info_header June 1981 B. Margulies */
  4     6 
  4     7 /* This include file depends on condition_info_header.incl.pl1 */
  4     8 /* It must be included as well */
  4     9 /* Added interpret_cp_escape, literal_sw, prompt_after_explanation 12/16/82 S. Herbst */
  4    10 /* Changed ("" max_)(question answer)_lth declarations to fixed bin (21) 02/08/84 S. Herbst */
  4    11 
  4    12 
  4    13 dcl 1 command_question_info based (cq_info_ptr) aligned,
  4    14     2 header aligned like condition_info_header,
  4    15     2 query_code fixed bin (35),			/* extra information supplied by caller */
  4    16     2 switches aligned,                                     /* various bit switches */
  4    17       3 question_sw bit (1) unaligned,			/* should command_query_ print the question? */
  4    18       3 yes_or_no_sw bit (1) unaligned,			/* must question be answered yes or no? */
  4    19       3 preset_sw bit (1) unaligned,			/* is handler supplying a canned answer? */
  4    20       3 answer_sw bit (1) unaligned,			/* should canned answer be printed? */
  4    21       3 allow_cp_escape bit (1) unaligned,                  /* whether to allow answers to begin with ".." */
  4    22       3 suppress_spacing bit (1) unaligned,                 /* whether to print extra newline and spaces */
  4    23       3 interpret_cp_escape bit (1) unaligned,		/* whether to treat ".." as a cp escape */
  4    24       3 literal_sw bit (1) unaligned,			/* ON => don't strip whitespace or handle ".." */
  4    25       3 prompt_after_explanation bit (1) unaligned,	/* ON => repeat question after explanation */
  4    26       3 mbz bit (27) unaligned,
  4    27     2 name_ptr pointer,				/* ptr to caller's name */
  4    28     2 name_lth fixed bin,				/* length of caller's name */
  4    29     2 question_ptr pointer,				/* ptr to quetion being asked */
  4    30     2 question_lth fixed bin (21),			/* lentgh of question */
  4    31     2 max_question_lth fixed bin (21),			/* max question lth in case handler alters question */
  4    32     2 answer_ptr pointer,				/* pointer to space to return answer in */
  4    33     2 answer_lth fixed bin (21),			/* length of returned answer */
  4    34     2 max_answer_lth fixed bin (21),			/* max space in answer space */
  4    35     2 question_iocbp ptr,				/* IO switch to ask (write) question on */
  4    36     2 answer_iocbp ptr,				/* IO switch to read the answer from */
  4    37     2 repeat_time fixed bin (71),			/* repeat question every N seconds if no answer */
  4    38     2 explanation_ptr ptr,				/* ptr to string to print if user answers "?" */
  4    39     2 explanation_len fixed bin (21);			/* length of explanation string */
  4    40 						/* if N < 30 no repeat will occur */
  4    41 
  4    42 dcl  cq_info_ptr pointer;
  4    43 
  4    44 dcl  cq_info_version_7 fixed bin internal static options (constant) init (7);
  4    45 
  4    46 /* END INCLUDE FILE:  command_question_info.incl.pl1 */
      616 
      617 
      618 
      619 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
      620 
  5     1 /* BEGIN INCLUDE FILE ... hcom_field_names.incl.pl1 */
  5     2 
  5     3 
  5     4 /****^  HISTORY COMMENTS:
  5     5*  1) change(85-09-20,LJAdams), approve(85-11-06,MCR7278),
  5     6*     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
  5     7*     Created September 1985.
  5     8*                                                   END HISTORY COMMENTS */
  5     9 
  5    10 declare   AUTHOR_FIELD_NAME char (24) varying internal static options (constant) init ("author");
  5    11 declare   APPROVAL_FIELD_NAME char (24) varying internal static options (constant) init ("approval");
  5    12 declare   AUDIT_FIELD_NAME char (24) varying internal static options (constant) init ("audit");
  5    13 declare   INSTALL_FIELD_NAME char (24) varying internal static options (constant) init ("install");
  5    14 
  5    15 /* END INCLUDE FILE ... hcom_field_names.incl.pl1 */
      621 
      622 
      623 
      624 
      625      dcl	TRACING			bit(1) aligned int static init("0"b);
      626 
      627 
  6     1 	/* START OF:	rdc_start_.incl.pl1		  *  *  *  *  *  *  */
  6     2 
  6     3 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  6     4 	/*							*/
  6     5 	/* N__a_m_e:  rdc_start_.incl.pl1					*/
  6     6 	/*							*/
  6     7 	/*      This include segment is used by compilers generated by the	*/
  6     8 	/* reduction_compiler.  Such compilers include a SEMANTIC_ANALYSIS	*/
  6     9 	/* subroutine generated by the reduction_compiler.  This subroutine	*/
  6    10 	/* compares a chain of input tokens with token requirements		*/
  6    11 	/* specified in reductions.  This include segment declares the 	*/
  6    12 	/* structure of the input tokens (which are generated by lex_string_),*/
  6    13 	/* defines the beginning of the SEMANTIC_ANALYSIS procedure, and	*/
  6    14 	/* declares Pthis_token, a global pointer variable which points to	*/
  6    15 	/* the "current" token being referenced by SEMANTIC_ANALYSIS.	*/
  6    16 	/*							*/
  6    17 	/* S__t_a_t_u_s							*/
  6    18 	/*							*/
  6    19 	/* 0) Created:  April, 1974 by G. C. Dixon			*/
  6    20 	/*							*/
  6    21 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  6    22 
  6    23      dcl	Pthis_token		ptr;		/* ptr to the "current" token being acted upon.	*/
  6    24 
  7     1 	/*  START OF:	lex_descriptors_.incl.pl1	  *  *  *  *  *  *  */
  7     2 	
  7     3 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  7     4 	/*							*/
  7     5 	/* Name:  lex_descriptors_.incl.pl1				*/
  7     6 	/*							*/
  7     7 	/*      This include segment defines the structure of the token	*/
  7     8 	/* descriptor, statement descriptor, and comment descriptor created	*/
  7     9 	/* by the lex_string_ program.				*/
  7    10 	/*							*/
  7    11 	/* Status:						*/
  7    12 	/*							*/
  7    13 	/* 0) Created:  Dec, 1973 by G. C. Dixon			*/
  7    14 	/*							*/
  7    15 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  7    16 	
  7    17 	
  7    18 	
  7    19 	
  7    20      dcl	
  7    21 	1 comment			aligned based (Pcomment),
  7    22 						/* descriptor for a comment.			*/
  7    23 	  2 group1		unaligned,
  7    24 	    3 version		fixed bin(17),	/* comment descriptor version.		*/
  7    25 	    3 size		fixed bin(17),	/* comment descriptor size (in words).		*/
  7    26 	  2 Pnext			ptr unal,		/* ptr to next comment descriptor.		*/
  7    27 	  2 Plast			ptr unal,		/* ptr to last comment descriptor.		*/
  7    28 	  2 Pvalue		ptr unal,		/* ptr to comment.				*/
  7    29 	  2 Lvalue		fixed bin(18),	/* length of comment.			*/
  7    30 	  2 group2		unaligned,
  7    31 	    3 line_no		fixed bin(17),	/* line no of line containing comment.		*/
  7    32 	    3 S,					/* switches:				*/
  7    33 	      4 before_stmt		bit(1),		/* comment is before 1st token of stmt.		*/
  7    34 	      4 contiguous		bit(1),		/* no tokens between this and last comment.	*/
  7    35 	      4 pad		bit(16),
  7    36 	comment_value		char(comment.Lvalue) based (comment.Pvalue),
  7    37 						/* body of comment.				*/
  7    38 	Pcomment			ptr;		/* ptr to comment descriptor.			*/
  7    39 	
  7    40      dcl	
  7    41 	1 stmt			aligned based (Pstmt),
  7    42 						/* descriptor for a statement.		*/
  7    43 	  2 group1		unaligned,
  7    44 	    3 version		fixed bin(17),	/* statement descriptor version.		*/
  7    45 	    3 size		fixed bin(17),	/* statement descriptor size (in words).	*/
  7    46 	  2 Pnext			ptr unal,		/* ptr to next statement descriptor.		*/
  7    47 	  2 Plast			ptr unal,		/* ptr to last statement descriptor.		*/
  7    48 	  2 Pvalue		ptr unal,		/* ptr to statement.			*/
  7    49 	  2 Lvalue		fixed bin(18),	/* length of statement.			*/
  7    50 	  2 Pfirst_token		ptr unal,		/* ptr to 1st token of statement.		*/
  7    51 	  2 Plast_token		ptr unal,		/* ptr to last token of statement.		*/
  7    52 	  2 Pcomments		ptr unal,		/* ptr to comments in statement.		*/
  7    53 	  2 Puser			ptr unal,		/* user-defined ptr.			*/
  7    54 	  2 group2		unaligned,
  7    55 	    3 Ntokens		fixed bin(17),	/* number of tokens in statement.		*/
  7    56 	    3 line_no		fixed bin(17),	/* line no of line on which statement begins.	*/
  7    57 	    3 Istmt_in_line		fixed bin(17),	/* number of stmts in line containing this stmt.	*/
  7    58 						/* (the number includes this stmt.)		*/
  7    59 	    3 semant_type		fixed bin(17),	/* semantic type of the statement.		*/
  7    60 	    3 S,					/* switches:				*/
  7    61 	      4 error_in_stmt	bit(1),		/* stmt contains a syntactic error.		*/
  7    62 	      4 output_in_err_msg	bit(1),		/* stmt has been output in previous error message.*/
  7    63 	      4 pad		bit(34),
  7    64 	stmt_value		char(stmt.Lvalue) based (stmt.Pvalue),
  7    65 						/* text of the statement.			*/
  7    66 	Pstmt			ptr;		/* ptr to a stmt descriptor. 			*/
  7    67 	
  7    68      dcl	
  7    69 	1 token			aligned based (Ptoken),
  7    70 						/* descriptor for a token.			*/
  7    71 	  2 group1		unaligned,
  7    72 	    3 version		fixed bin(17),	/* token descriptor version.			*/
  7    73 	    3 size		fixed bin(17),	/* token descriptor size (in words).		*/
  7    74 	  2 Pnext			ptr unal,		/* ptr to next token descriptor.		*/
  7    75 	  2 Plast			ptr unal,		/* ptr to last token descriptor.		*/
  7    76 	  2 Pvalue		ptr unal,		/* ptr to token.				*/
  7    77 	  2 Lvalue		fixed bin(18),	/* length of token.				*/
  7    78 	  2 Pstmt			ptr unal,		/* ptr to descriptor of stmt containing token.	*/
  7    79 	  2 Psemant		ptr unal,		/* ptr to descriptor(s) of token's semantic value.*/
  7    80 	  2 group2		unaligned,
  7    81 	    3 Itoken_in_stmt	fixed bin(17),	/* position of token within its statement.	*/
  7    82 	    3 line_no		fixed bin(17),	/* line number of the line containing the token.	*/
  7    83 	    3 Nvalue		fixed bin(35),	/* numeric value of decimal-integer tokens.	*/
  7    84 	    3 S,					/* switches:				*/
  7    85 	      4 end_of_stmt		bit(1),		/* token is an end-of-stmt token.		*/
  7    86 	      4 quoted_string	bit(1),		/* token is a quoted string.			*/
  7    87 	      4 quotes_in_string	bit(1),		/* on if quote-close delimiters appear in quoted	*/
  7    88 						/* string (as doubled quotes on input.)		*/
  7    89 	      4 quotes_doubled	bit(1),		/* on if quotes in the string are doubled after	*/
  7    90 						/* string has been lexed into a token.		*/
  7    91 	      4 pad2		bit(32),
  7    92 	token_value		char(token.Lvalue) based (token.Pvalue),
  7    93 						/* value of the token.			*/
  7    94 	Ptoken			ptr;		/* ptr to a token descriptor.			*/
  7    95 
  7    96 	/*  END OF:	lex_descriptors_.incl.pl1	  *  *  *  *  *  *  */
  6    25 
  6    26 
  6    27 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  6    28 
  6    29 
  6    30 SEMANTIC_ANALYSIS:	procedure;			/* procedure which analyzes the syntax and	*/
  6    31 						/* semantics of the tokens in the input list.	*/
  6    32 
  6    33      dcl						/*	automatic variables			*/
  6    34 	LTOKEN_REQD_VALUE		fixed bin(18),	/* length of a token requirement.		*/
  6    35 	NRED			fixed bin,	/* number of the reduction tokens are being	*/
  6    36 						/* compared to.				*/
  6    37 	PRED			ptr,		/* ptr to the reduction tokens are being	*/
  6    38 						/* compared to.				*/
  6    39 	PTOKEN_REQD		ptr,		/* ptr to token requirement descriptor associated	*/
  6    40 						/* with reduction tokens are being compared to.	*/
  6    41 	PTOKEN_REQD_VALUE		ptr,		/* ptr to a token requirement.		*/
  6    42 	STOKEN_FCN		bit(1) aligned,	/* return value from a relative syntax function.	*/
  6    43 	CODE			fixed bin(35),	/* an error code.				*/
  6    44 	I			fixed bin,	/* a do-group index.			*/
  6    45 	NUMBER			fixed bin(35);	/* fixed binary representation of a decimal 	*/
  6    46 						/* number character string.			*/
  6    47 
  6    48      dcl						/*	based variables			*/
  6    49 	1 RED			aligned based (PRED),
  6    50 						/* descriptor for reduction tokens are being 	*/
  6    51 						/* compared to.				*/
  6    52 	  2 TOKEN_REQD		unaligned,
  6    53 	    3 IFIRST		fixed bin(17) unal,	/* index of first token requirement.		*/
  6    54 	    3 ILAST		fixed bin(17) unal,	/* index of last  token requirement associated	*/
  6    55 						/* with this reduction.			*/
  6    56 	1 TOKEN_REQD		aligned based (PTOKEN_REQD),
  6    57 						/* a token requirement descriptor.		*/
  6    58 	  2 FORM			fixed bin(17) unal,	/* form of the token requirement:		*/
  6    59 						/*  -1 = relative token requirement function;	*/
  6    60 						/*       TYPE = index of the particular token	*/
  6    61 						/*	      function in the token_fcn array.	*/
  6    62 						/*   0 = built-in token requirement function;	*/
  6    63 						/*       TYPE = as defined below.		*/
  6    64 						/*  >0 = absolute token requirement:		*/
  6    65 						/*       FORM = index(TOKEN_STRINGS,TOKEN_REQD);	*/
  6    66 						/*       TYPE = length(TOKEN_REQD);		*/
  6    67 	  2 TYPE			fixed bin(17) unal,	/* TYPE of built-in token requirement function:	*/
  6    68 						/*   1 = compile test to see if input token 	*/
  6    69 						/*       chain is exhausted (<no-token>).	*/
  6    70 						/*   2 = compile test for any token value	*/
  6    71 						/*       (<any-token>).			*/
  6    72 						/*   3 = compile test for a PL/I identifier	*/
  6    73 						/*       (<name>) of 32 or fewer characters.	*/
  6    74 						/*   4 = compile test for token which is a	*/
  6    75 						/*       <decimal-integer>.			*/
  6    76 						/*   5 = compile test for token which is a single	*/
  6    77 						/*       backspace character (<BS>).		*/
  6    78 						/*   6 = compile test for a token which is a	*/
  6    79 						/*       <quoted-string>.			*/
  6    80 
  6    81 	1 TOKEN_REQD_STRING		aligned based (PTOKEN_REQD),
  6    82 						/* overlay for an absolute token requirement	*/
  6    83 						/* descriptor.				*/
  6    84 	  2 I			fixed bin(17) unal,	/* index into list of token strings of the	*/
  6    85 						/* absolute token string assoc w/ descriptor.	*/
  6    86 	  2 L			fixed bin(17) unal,	/* length of the absolute token string.		*/
  6    87 	TOKEN_REQD_VALUE		char(LTOKEN_REQD_VALUE) based (PTOKEN_REQD_VALUE);
  6    88 						/* absolute token string which token is reqd	*/
  6    89 						/* to match in order for tokens which are	*/
  6    90 						/* "current" on the list to match the reduction.	*/
  6    91 
  6    92      dcl						/*	builtin functions			*/
  6    93          (addr, max, null, search, substr, verify)
  6    94 				builtin;
  6    95 
  6    96      dcl						/*	entries				*/
  6    97 	cv_dec_check_		entry (char(*), fixed bin(35)) returns (fixed bin(35));
  6    98 
  6    99      dcl						/*	static variables			*/
  6   100 	BACKSPACE			char(1) aligned int static init ("");
  6   101 
  6   102 	/* END OF:	rdc_start_.incl.pl1		  *  *  *  *  *  *  */
      628 
      629 
      630      dcl	DIRECTION			fixed bin init(+1);	/* direction in which tokens compared.		*/
      631 
      632 
      633      dcl	1 REDUCTION (37)		unaligned based (addr (REDUCTIONS)),
      634 						/* object reductions.			*/
      635 	  2 TOKEN_REQD,
      636 	    3 IFIRST		fixed bin(17),	/* index of first required token.		*/
      637 	    3 ILAST		fixed bin(17),	/* index of last required token.		*/
      638 
      639 	REDUCTIONS  (74)		fixed bin(17) unaligned internal static options(constant) initial (
      640 	         1,     8,	/*     1/  <decimal-integer> ) change ( <date> , <change_pers> )                */
      641 	         9,    16,	/*     2/  <decimal-integer> ) change ( <date> , <change_pers> <any-token>      */
      642 	        17,    23,	/*     3/  <decimal-integer> ) change ( <date> , <any-token>                    */
      643 	        24,    28,	/*     4/  <decimal-integer> ) change ( <any-token>                             */
      644 	        29,    30,	/*     5/  <any-token> )                                                        */
      645 	        16,    16,	/*     6/  <any-token>                                                          */
      646 	        31,    31,	/*     7/  <no-token>                                                           */
      647 	        32,    32,	/*     8/  :                                                                    */
      648 	         6,     6,	/*     9/  ,                                                                    */
      649 	        16,    16,	/*    10/  <any-token>                                                          */
      650 	        31,    31,	/*    11/  <no-token>                                                           */
      651 	        33,    34,	/*    12/  approve (                                                            */
      652 	        35,    36,	/*    13/  audit (                                                              */
      653 	        37,    38,	/*    14/  install (                                                            */
      654 	        39,    40,	/*    15/  <any-token> (                                                        */
      655 	        16,    16,	/*    16/  <any-token>                                                          */
      656 	        31,    31,	/*    17/  <no-token>                                                           */
      657 	        41,    43,	/*    18/  approve ( )                                                          */
      658 	        44,    49,	/*    19/  approve ( <date> , <apv_id> )                                        */
      659 	        50,    52,	/*    20/  audit ( )                                                            */
      660 	        53,    58,	/*    21/  audit ( <date> , <audit_pers> )                                      */
      661 	        59,    61,	/*    22/  install ( )                                                          */
      662 	        62,    67,	/*    23/  install ( <date> , <install_id> )                                    */
      663 	        68,    73,	/*    24/  approve ( <date> , <apv_id> <any-token>                              */
      664 	        74,    78,	/*    25/  approve ( <date> , <any-token>                                       */
      665 	        79,    81,	/*    26/  approve ( <any-token>                                                */
      666 	        82,    83,	/*    27/  approve <any-token>                                                  */
      667 	        84,    89,	/*    28/  audit ( <date> , <audit_pers> <any-token>                            */
      668 	        90,    94,	/*    29/  audit ( <date> , <any-token>                                         */
      669 	        95,    97,	/*    30/  audit ( <any-token>                                                  */
      670 	        98,    99,	/*    31/  audit <any-token>                                                    */
      671 	       100,   105,	/*    32/  install ( <date> , <install_id> <any-token>                          */
      672 	       106,   110,	/*    33/  install ( <date> , <any-token>                                       */
      673 	        37,    39,	/*    34/  install ( <any-token>                                                */
      674 	       111,   112,	/*    35/  install <any-token>                                                  */
      675 	        16,    16,	/*    36/  <any-token>                                                          */
      676 	        31,    31);	/*    37/  <no-token>                                                           */
      677 
      678      dcl	1 TOKEN_REQUIREMENT (112)	unaligned based (addr (TOKEN_REQUIREMENTS)),
      679 						/* object token requirements.			*/
      680 	  2 FORM			fixed bin(17),	/* form of the token requirement:		*/
      681 						/*  -1 = relative token requirement function;	*/
      682 						/*       TYPE = index of the particular token	*/
      683 						/*	      function in the token_fcn array.	*/
      684 						/*   0 = built-in token requirement function;	*/
      685 						/*       TYPE = as defined below.		*/
      686 						/*  >0 = absolute token requirement:		*/
      687 						/*       FORM = index(TOKEN_STRINGS,TOKEN_REQD);	*/
      688 						/*       TYPE = length(TOKEN_REQD);		*/
      689 	  2 TYPE			fixed bin(17) unal,	/* type of the built-in token requirement	*/
      690 						/* function:				*/
      691 						/*   1 = compile test to see if input token 	*/
      692 						/*       chain is exhausted (<no-token>).	*/
      693 						/*   2 = compile test for any token value	*/
      694 						/*       (<any-token>).			*/
      695 						/*   3 = compile test for a PL/I identifier	*/
      696 						/*       (<name>) of 32 or fewer characters.	*/
      697 						/*   4 = compile test for token which is a	*/
      698 						/*       <decimal-integer>.			*/
      699 						/*   5 = compile test for token which is a single	*/
      700 						/*       backspace character (<BS>).		*/
      701 						/*   6 = compile test for a token which is a	*/
      702 						/*       <quoted-string>.			*/
      703 
      704 	TOKEN_REQUIREMENTS  (224)	fixed bin(17) unaligned internal static options(constant) initial (
      705 	         0,    4,       1,    1,       2,    6,       8,    1,      -1,    1,       9,    1,      -1,    2,   
      706 	         1,    1,       0,    4,       1,    1,       2,    6,       8,    1,      -1,    1,       9,    1,   
      707 	        -1,    2,       0,    2,       0,    4,       1,    1,       2,    6,       8,    1,      -1,    1,   
      708 	         9,    1,       0,    2,       0,    4,       1,    1,       2,    6,       8,    1,       0,    2,   
      709 	         0,    2,       1,    1,       0,    1,      10,    1,      11,    7,       8,    1,      18,    5,   
      710 	         8,    1,      23,    7,       8,    1,       0,    2,       8,    1,      11,    7,       8,    1,   
      711 	         1,    1,      11,    7,       8,    1,      -1,    1,       9,    1,      -1,    3,       1,    1,   
      712 	        18,    5,       8,    1,       1,    1,      18,    5,       8,    1,      -1,    1,       9,    1,   
      713 	        -1,    4,       1,    1,      23,    7,       8,    1,       1,    1,      23,    7,       8,    1,   
      714 	        -1,    1,       9,    1,      -1,    5,       1,    1,      11,    7,       8,    1,      -1,    1,   
      715 	         9,    1,      -1,    3,       0,    2,      11,    7,       8,    1,      -1,    1,       9,    1,   
      716 	         0,    2,      11,    7,       8,    1,       0,    2,      11,    7,       0,    2,      18,    5,   
      717 	         8,    1,      -1,    1,       9,    1,      -1,    4,       0,    2,      18,    5,       8,    1,   
      718 	        -1,    1,       9,    1,       0,    2,      18,    5,       8,    1,       0,    2,      18,    5,   
      719 	         0,    2,      23,    7,       8,    1,      -1,    1,       9,    1,      -1,    5,       0,    2,   
      720 	        23,    7,       8,    1,      -1,    1,       9,    1,       0,    2,      23,    7,       0,    2);
      721 
      722 
      723      dcl	TOKEN_STRINGS		char(29) aligned based (addr (TOKEN_STRING_ARRAYS)),
      724 						/* object token values.			*/
      725 	TOKEN_STRING_ARRAYS (1)	char(100) aligned internal static options(constant) initial (
      726 	     ")change(,:approveauditinstall");
      727 
      728 	/* START OF:	rdc_end_.incl.pl1		  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  8     2 
  8     3 
  8     4 /****^  HISTORY COMMENTS:
  8     5*  1) change(86-02-14,GWMay), approve(), audit(), install():
  8     6*     old history comments:
  8     7*      0) Created: April, 1974 by G. C. Dixon
  8     8*      1) Modified: Feb, 1975  by G. C. Dixon
  8     9*         a) support for Version 2.0 of reduction_compiler.
  8    10*      2) Modified: Feb, 1981  by G. C. Dixon
  8    11*         a) support for Version  2.2 of reduction_compiler
  8    12*      3) Modified: Aug, 1983  by G. C. Dixon - support for Version 2.3 of
  8    13*                        reductions command.
  8    14*  2) change(86-03-04,GDixon), approve(86-03-04,MCR7362), audit(86-03-17,GWMay),
  8    15*     install(86-03-17,MR12.0-1032):
  8    16*     Changed how the PUSH DOWN LANGUAGE (SPDL) definition of <no-token> is
  8    17*     implemented to avoid references through a null pointer.  The two
  8    18*     accepted uses are:
  8    19*     
  8    20*        / <no-token>               / ... / ... \
  8    21*                    A
  8    22*                    |
  8    23*           Pthis_token (points to top of push down stack)
  8    24*     
  8    25*     which checks to see if the push down stack is totally exhausted (ie,
  8    26*     Ptoken = null); and:
  8    27*     
  8    28*        / SPEC1 ... SPECN <no-token>         / ... / ... \
  8    29*                           A
  8    30*                           |
  8    31*                 Pthis_token (points to top of push down stack)
  8    32*     
  8    33*     which checks to see whether SPECN is topmost on the push down stack
  8    34*     AND is the final token in the input list.
  8    35*                                                   END HISTORY COMMENTS */
  8    36 
  8    37 
  8    38 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  8    39 	/*									*/
  8    40 	/* NAME:  rdc_end_.incl.pl1							*/
  8    41 	/*									*/
  8    42 	/*      This include segment is used by compilers generated by the reduction_compiler.	*/
  8    43 	/* Such compilers include a SEMANTIC_ANALYSIS subroutine generated by the		*/
  8    44 	/* reduction_compiler.  This subroutine compares a chain of input tokens with token	*/
  8    45 	/* requirements specified in reductions.  The code in this include segment performs the	*/
  8    46 	/* actual comparisons.  This code is the middle part of the SEMANTIC_ANALYSIS procedure.	*/
  8    47 	/*									*/
  8    48 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  8    49 
  8    50 	TRACING = TRACING;				/* Kludge to prevent pl1 from making TRACING	*/
  8    51 						/*   options(constant) because it is never set.	*/
  8    52 	NRED = 1;
  8    53 	go to RD_TEST_REDUCTION;
  8    54 
  8    55 RD_NEXT_REDUCTION:
  8    56 	NRED = NRED + 1;
  8    57 
  8    58 RD_TEST_REDUCTION:
  8    59 	PRED = addr(REDUCTION(NRED));
  8    60 	Ptoken = Pthis_token;
  8    61 
  8    62 	do I = RED.TOKEN_REQD.IFIRST to RED.TOKEN_REQD.ILAST by DIRECTION;
  8    63 	     PTOKEN_REQD = addr(TOKEN_REQUIREMENT(I));
  8    64 	     if Ptoken = null then do;
  8    65 		if TOKEN_REQD.FORM = 0 then		/* No more tokens.  Only matches <no-token> spec.	*/
  8    66 		     if TOKEN_REQD.TYPE = 1 then
  8    67 			go to RD_TEST_TOKEN(1);
  8    68 		go to RD_NEXT_REDUCTION;
  8    69 		end;
  8    70 	     if TOKEN_REQD.FORM = 0 then do;		/* built-in syntax function.			*/
  8    71 		go to RD_TEST_TOKEN(TOKEN_REQD.TYPE);
  8    72 
  8    73 RD_TEST_TOKEN(1):   if SPDL then			/* <no-token>				*/
  8    74 						/* In push-down-language, there are 2 		*/
  8    75 						/*   interpretations of <no-token>.		*/
  8    76 		     if      RED.TOKEN_REQD.IFIRST = RED.TOKEN_REQD.ILAST &
  8    77 			   Ptoken = null then	/* When <no-token> is only spec, the spec asks 	*/
  8    78 			go to RD_MATCH_NO_TOKEN;	/* "Is push down stack empty (all input gone)?"   */
  8    79 		     else if RED.TOKEN_REQD.IFIRST^= RED.TOKEN_REQD.ILAST &
  8    80 			   RED.TOKEN_REQD.IFIRST = I &
  8    81 			   token.Pnext = null then	/* For SPEC1 ... SPECN <no-token>, the spec asks  */
  8    82 			go to RD_MATCH_NO_TOKEN;	/* "Are the topmost tokens on stack SPEC1 - SPECN,*/
  8    83 						/*  and is SPECN the final input token?"	*/
  8    84 		     else go to RD_NEXT_REDUCTION;	/* Those are the only two defs allowed in push	*/
  8    85 						/* down language mode for <no-token>.		*/
  8    86 		else if Ptoken = null then
  8    87 		     go to RD_MATCH_NO_TOKEN;
  8    88 		go to RD_NEXT_REDUCTION;
  8    89 
  8    90 RD_TEST_TOKEN(2):	go to RD_MATCH;			/* <any-token>				*/
  8    91 
  8    92 RD_TEST_TOKEN(3):	if token.Lvalue > 0 &		/* <name>					*/
  8    93 		   token.Lvalue <= 32 & ^token.S.quoted_string then
  8    94 		     if search(substr(token_value,1,1),"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
  8    95 		     > 0 then
  8    96 			if verify(token_value,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_$")
  8    97 			= 0 then
  8    98 			     go to RD_MATCH;
  8    99 		go to RD_NEXT_REDUCTION;
  8   100 
  8   101 RD_TEST_TOKEN(4):					/* <decimal-integer>			*/
  8   102 		if token.Nvalue ^= 0 then		/* token already determined to be a number.	*/
  8   103 		     go to RD_MATCH;
  8   104 		if token.S.quoted_string then
  8   105 		     go to RD_NEXT_REDUCTION;
  8   106 		NUMBER = cv_dec_check_ (token_value, CODE);
  8   107 		if CODE = 0 then do;
  8   108 		     token.Nvalue = NUMBER;
  8   109 		     go to RD_MATCH;
  8   110 		     end;
  8   111 		go to RD_NEXT_REDUCTION;
  8   112 
  8   113 RD_TEST_TOKEN(5):	if token.Lvalue = 1 then		/* <BS>					*/
  8   114 		     if token_value = BACKSPACE & ^token.S.quoted_string then
  8   115 			go to RD_MATCH;
  8   116 		go to RD_NEXT_REDUCTION;
  8   117 
  8   118 RD_TEST_TOKEN(6):	if token.S.quoted_string then		/* <quoted-string>				*/
  8   119 		     go to RD_MATCH;
  8   120 		go to RD_NEXT_REDUCTION;
  8   121 		end;
  8   122 
  8   123 	     else if TOKEN_REQD.FORM > 0 then do;	/* absolute syntax specification.		*/
  8   124 		if token.S.quoted_string then
  8   125 		     go to RD_NEXT_REDUCTION;
  8   126 		PTOKEN_REQD_VALUE = addr(substr(TOKEN_STRINGS,TOKEN_REQD_STRING.I));
  8   127 		LTOKEN_REQD_VALUE = TOKEN_REQD_STRING.L;
  8   128 		if token_value = TOKEN_REQD_VALUE then
  8   129 		     go to RD_MATCH;
  8   130 		go to RD_NEXT_REDUCTION;
  8   131 		end;
  8   132 
  8   133 	/* END OF:	rdc_end_.incl.pl1		  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
      728 
      729 
      730 	     else do;				/* relative syntax function.			*/
      731 		go to RD_TOKEN_FCN(TOKEN_REQD.TYPE);
      732 
      733 RD_TOKEN_FCN(1):	STOKEN_FCN = date();
      734 		go to RD_TEST_RESULT;
      735 RD_TOKEN_FCN(2):	STOKEN_FCN = change_pers();
      736 		go to RD_TEST_RESULT;
      737 RD_TOKEN_FCN(3):	STOKEN_FCN = apv_id();
      738 		go to RD_TEST_RESULT;
      739 RD_TOKEN_FCN(4):	STOKEN_FCN = audit_pers();
      740 		go to RD_TEST_RESULT;
      741 RD_TOKEN_FCN(5):	STOKEN_FCN = install_id();
      742 		go to RD_TEST_RESULT;
      743 
      744 RD_TEST_RESULT:	if STOKEN_FCN then go to RD_MATCH;
      745 		else go to RD_NEXT_REDUCTION;
      746 		end;
      747 
      748 RD_MATCH:      Ptoken = token.Pnext;
      749 RD_MATCH_NO_TOKEN:
      750 	     end;
      751 	Ptoken = Pthis_token;
      752 	go to RD_ACTION(NRED);
      753 
      754 
      755 RD_ACTION(1):					/* /					*/
      756 						     src_array_comment.comment_no = token.Nvalue;
      757 	call 					     LEX ( 4 );
      758 						     src_array_comment.change_dt = date_out;
      759 	call 					     LEX ( 2 );
      760 						     src_array_comment.change_person = person;
      761 	call 					     LEX ( 2 );
      762 	NRED = 8;
      763 	go to RD_TEST_REDUCTION;			/* / punct \                           		*/
      764 
      765 RD_ACTION(2):					/* /					*/
      766 	call 					     LEX ( 7 );
      767 	call 					     MY_ERROR ( 19 );
      768 	return;					/* / RETURN	\			*/
      769 
      770 RD_ACTION(3):					/* /					*/
      771 	call 					     LEX ( 6 );
      772 	call 					     MY_ERROR ( 3 );
      773 	return;					/* / RETURN	\			*/
      774 
      775 RD_ACTION(4):					/* /					*/
      776 	call 					     LEX ( 4 );
      777 	call 					     MY_ERROR ( 2 );
      778 	return;					/* / RETURN	\			*/
      779 
      780 RD_ACTION(5):					/* /					*/
      781 	call 					     MY_ERROR ( 1 );
      782 	return;					/* / RETURN	\			*/
      783 
      784 RD_ACTION(6):					/* /					*/
      785 	call 					     MY_ERROR ( 4 );
      786 	return;					/* / RETURN	\			*/
      787 
      788 RD_ACTION(7):					/* /					*/
      789 	call 					     MY_ERROR ( 5 );
      790 	return;					/* / RETURN	\			*/
      791 
      792 RD_ACTION(8):					/* /					*/
      793 	Ptoken, Pthis_token = Pthis_token -> token.Pnext;	/*   LEX					*/
      794 	call					     set_text();
      795 	return;					/* / RETURN	\			*/
      796 
      797 RD_ACTION(9):					/* /					*/
      798 	Ptoken, Pthis_token = Pthis_token -> token.Pnext;	/*   LEX					*/
      799 	NRED = 12;
      800 	go to RD_TEST_REDUCTION;			/* / opt \                             		*/
      801 
      802 RD_ACTION(10):					/* /					*/
      803 	call 					     MY_ERROR ( 6 );
      804 	return;					/* / RETURN	\			*/
      805 
      806 RD_ACTION(11):					/* /					*/
      807 	call 					     MY_ERROR ( 7 );
      808 	return;					/* / RETURN	\			*/
      809 
      810 RD_ACTION(12):					/* /					*/
      811 	NRED = 18;
      812 	go to RD_TEST_REDUCTION;			/* / opt_arg \                         		*/
      813 
      814 RD_ACTION(13):					/* /					*/
      815 	NRED = 18;
      816 	go to RD_TEST_REDUCTION;			/* / opt_arg \                         		*/
      817 
      818 RD_ACTION(14):					/* /					*/
      819 	NRED = 18;
      820 	go to RD_TEST_REDUCTION;			/* / opt_arg \                         		*/
      821 
      822 RD_ACTION(15):					/* /					*/
      823 	call 					     MY_ERROR ( 16 );
      824 	return;					/* / RETURN	\			*/
      825 
      826 RD_ACTION(16):					/* /					*/
      827 	call 					     MY_ERROR ( 17 );
      828 	return;					/* / RETURN	\			*/
      829 
      830 RD_ACTION(17):					/* /					*/
      831 	call 					     MY_ERROR ( 18 );
      832 	return;					/* / RETURN	\			*/
      833 
      834 RD_ACTION(18):					/* /					*/
      835 						     src_array_comment.approve_dt = "^";
      836 						     src_array_comment.approve_value = "";
      837 						     null_approve = True;
      838 	call 					     LEX ( 3 );
      839 	NRED = 8;
      840 	go to RD_TEST_REDUCTION;			/* / punct \                           		*/
      841 
      842 RD_ACTION(19):					/* /					*/
      843 	call 					     LEX ( 2 );
      844 						     src_array_comment.approve_dt = date_out;
      845 	call 					     LEX ( 2 );
      846 						     src_array_comment.approve_value = ident;
      847 	call 					     LEX ( 2 );
      848 	NRED = 8;
      849 	go to RD_TEST_REDUCTION;			/* / punct \                           		*/
      850 
      851 RD_ACTION(20):					/* /					*/
      852 						     src_array_comment.audit_dt = "^";
      853 						     src_array_comment.audit_person = "";
      854 						     null_audit = True;
      855 	call 					     LEX ( 3 );
      856 	NRED = 8;
      857 	go to RD_TEST_REDUCTION;			/* / punct \                           		*/
      858 
      859 RD_ACTION(21):					/* /					*/
      860 	call 					     LEX ( 2 );
      861 						     src_array_comment.audit_dt = date_out;
      862 	call 					     LEX ( 2 );
      863 						     src_array_comment.audit_person = person;
      864 	call 					     LEX ( 2 );
      865 	NRED = 8;
      866 	go to RD_TEST_REDUCTION;			/* / punct \                           		*/
      867 
      868 RD_ACTION(22):					/* /					*/
      869 						     src_array_comment.install_dt = "^";
      870 						     src_array_comment.install_id = "";
      871 						     null_install = True;
      872 	call 					     LEX ( 3 );
      873 	NRED = 8;
      874 	go to RD_TEST_REDUCTION;			/* / punct \                           		*/
      875 
      876 RD_ACTION(23):					/* /					*/
      877 	call 					     LEX ( 2 );
      878 						     src_array_comment.install_dt = date_out;
      879 	call 					     LEX ( 2 );
      880 						     src_array_comment.install_id = ident;
      881 	call 					     LEX ( 2 );
      882 	NRED = 8;
      883 	go to RD_TEST_REDUCTION;			/* / punct \                           		*/
      884 
      885 RD_ACTION(24):					/* /					*/
      886 	call 					     LEX ( 5 );
      887 	call 					     MY_ERROR ( 19 );
      888 	return;					/* / RETURN	\			*/
      889 
      890 RD_ACTION(25):					/* /					*/
      891 	call 					     LEX ( 4 );
      892 	call 					     MY_ERROR ( 11 );
      893 	return;					/* / RETURN	\			*/
      894 
      895 RD_ACTION(26):					/* /					*/
      896 	call 					     LEX ( 2 );
      897 	call 					     MY_ERROR ( 10 );
      898 	return;					/* / RETURN	\			*/
      899 
      900 RD_ACTION(27):					/* /					*/
      901 	Ptoken, Pthis_token = Pthis_token -> token.Pnext;	/*   LEX					*/
      902 	call 					     MY_ERROR ( 6 );
      903 	return;					/* / RETURN	\			*/
      904 
      905 RD_ACTION(28):					/* /					*/
      906 	call 					     LEX ( 5 );
      907 	call 					     MY_ERROR ( 19 );
      908 	return;					/* / RETURN	\			*/
      909 
      910 RD_ACTION(29):					/* /					*/
      911 	call 					     LEX ( 4 );
      912 	call 					     MY_ERROR ( 13 );
      913 	return;					/* / RETURN	\			*/
      914 
      915 RD_ACTION(30):					/* /					*/
      916 	call 					     LEX ( 2 );
      917 	call 					     MY_ERROR ( 12 );
      918 	return;					/* / RETURN	\			*/
      919 
      920 RD_ACTION(31):					/* /					*/
      921 	Ptoken, Pthis_token = Pthis_token -> token.Pnext;	/*   LEX					*/
      922 	call 					     MY_ERROR ( 6 );
      923 	return;					/* / RETURN	\			*/
      924 
      925 RD_ACTION(32):					/* /					*/
      926 	call 					     LEX ( 5 );
      927 	call 					     MY_ERROR ( 19 );
      928 	return;					/* / RETURN	\			*/
      929 
      930 RD_ACTION(33):					/* /					*/
      931 	call 					     LEX ( 4 );
      932 	call 					     MY_ERROR ( 15 );
      933 	return;					/* / RETURN	\			*/
      934 
      935 RD_ACTION(34):					/* /					*/
      936 	call 					     LEX ( 2 );
      937 	call 					     MY_ERROR ( 14 );
      938 	return;					/* / RETURN	\			*/
      939 
      940 RD_ACTION(35):					/* /					*/
      941 	Ptoken, Pthis_token = Pthis_token -> token.Pnext;	/*   LEX					*/
      942 	call 					     MY_ERROR ( 6 );
      943 	return;					/* / RETURN	\			*/
      944 
      945 RD_ACTION(36):					/* /					*/
      946 	call 					     MY_ERROR ( 8 );
      947 	return;					/* / RETURN	\			*/
      948 
      949 RD_ACTION(37):					/* /					*/
      950 	call 					     MY_ERROR ( 9 );
      951 	return;					/* / RETURN	\			*/
      952 
      953 
      954 	end SEMANTIC_ANALYSIS;
      955 
      956 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
      957 
      958      dcl	SPDL			bit(1) aligned init ("0"b);
      959 						/* off: This compiler parses a non-PUSH DOWN	*/
      960 						/*      LANGUAGE.				*/
      961 	/* START OF:	rdc_lex_.incl.pl1			  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
  9     2 
  9     3 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  9     4 	/*									*/
  9     5 	/* N__a_m_e:  rdc_lex_.incl.pl1							*/
  9     6 	/*									*/
  9     7 	/*      This include segment is used by compilers generated by the reduction_compiler.	*/
  9     8 	/* It contains the LEX subroutine which is used to manipulate the pointer to the	*/
  9     9 	/* "current" token, Pthis_token.						*/
  9    10 	/*									*/
  9    11 	/* E__n_t_r_y:  LEX								*/
  9    12 	/*									*/
  9    13 	/*      This entry makes the |_nth|-next (or -preceding) token the "current" token, where	*/
  9    14 	/* _n is its positive (or negative) input argument.				*/
  9    15 	/*									*/
  9    16 	/* U__s_a_g_e									*/
  9    17 	/*									*/
  9    18 	/*      call LEX(n);							*/
  9    19 	/*									*/
  9    20 	/* 1) n   is the number of the token to be made the "current" token, relative to the	*/
  9    21 	/*        token identified by Pthis_token (the present "current" token).  If n is	*/
  9    22 	/*        positive, the nth token following the "current" token made "current".  If n	*/
  9    23 	/*        is negative, the nth token preceding the "current" token is made "current".	*/
  9    24 	/*									*/
  9    25 	/* S__t_a_t_u_s									*/
  9    26 	/*									*/
  9    27 	/* 0) Created by:  G. C. Dixon  in  February, 1975				*/
  9    28 	/*									*/
  9    29 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
  9    30 
  9    31 LEX:	procedure (n);
  9    32 
  9    33      dcl	n			fixed bin,
  9    34 	i			fixed bin;
  9    35 
  9    36 	Ptoken = Pthis_token;			/* do everything relative to "current" token.	*/
  9    37 	if Ptoken = null then return;			/* can't lex if token list exhausted.		*/
  9    38 	if n >= 0 then do;				/* new "current" token will follow present one.	*/
  9    39 	     do i = 1 to n while (token.Pnext ^= null);	/* find new "current" token, taking care not to	*/
  9    40 		Ptoken = token.Pnext;		/*   run off end of token list.		*/
  9    41 		end;
  9    42 	     if ^SPDL then if i <= n then Ptoken = null;	/* if not in 'PUSH DOWN LANGUAGE' mode, allow	*/
  9    43 						/*   running off end of token list.		*/
  9    44 	     end;
  9    45 	else					/* new "current" token precedes present one.	*/
  9    46 	     do i = -1 to n by -1 while (token.Plast ^= null);
  9    47 		Ptoken = token.Plast;
  9    48 		end;
  9    49 	Pthis_token = Ptoken;			/* simple wasn't it.			*/
  9    50 
  9    51 	end LEX;
  9    52 
  9    53 /* END OF:	rdc_lex_.incl.pl1			  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
      961 
      962 
      963 		/* START OF:	rdc_error_.incl.pl1		  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
 10     2 
 10     3      dcl	MERROR_SEVERITY		fixed bin init (0),	/* Severity of highest-severity error.		*/
 10     4 	SERROR_CONTROL		bit(2) init ("00"b),/* Global switches control error message format.	*/
 10     5 	SERROR_PRINTED (dimension (error_control_table,1))
 10     6 				bit(1) unaligned init ((dimension (error_control_table,1))(1)"0"b),
 10     7 						/* Array bit is on if corresponding error message	*/
 10     8 						/* in error_control_table has already been printed*/
 10     9 	MIN_PRINT_SEVERITY		fixed bin init (0), /* Mimimum severity message that will be printed	*/
 10    10 	PRINT_SEVERITY_CONTROL	bit(2) init ("11"b);/* Action if severity < MIN_PRINT_SEVERITY	*/
 10    11 
 10    12 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 10    13 	/*									*/
 10    14 	/* N__a_m_e:  rdc_error_.incl.pl1							*/
 10    15 	/*									*/
 10    16 	/*      This include segment is used by compilers generated by the reduction_compiler.	*/
 10    17 	/* It defines a procedure which the compilers can use to print error messages.  	*/
 10    18 	/*									*/
 10    19 	/* E__n_t_r_y:  ERROR								*/
 10    20 	/*									*/
 10    21 	/*      Given an error number, this procedure prints a corresponding error message.	*/
 10    22 	/* The message is stored in a compiler-defined error_control_table, along with an integer	*/
 10    23 	/* which specifies the severity level of the error, and a switch which specifies whether	*/
 10    24 	/* the source statement in which the error occurred (if any) should be printed after the	*/
 10    25 	/* error message.  The printing of the error message may be supressed for all messages	*/
 10    26 	/* having a severity less than a specified (MIN_PRINT_SEVERITY) value.  The ERROR	*/
 10    27 	/*  procedure calls the lex_error_ subroutine to perform the formatting and printing of	*/
 10    28 	/*  the error message.							*/
 10    29 	/*									*/
 10    30 	/* U__s_a_g_e									*/
 10    31 	/*									*/
 10    32 	/*      call ERROR (error_number);						*/
 10    33 	/*									*/
 10    34 	/* 1) error_number	is the index of one of the structures in the error_control_table	*/
 10    35 	/*		which defines the error message to be printed.			*/
 10    36 	/*									*/
 10    37 	/* N__o_t_e_s									*/
 10    38 	/*									*/
 10    39 	/*      The format of the error_control_table is shown below.			*/
 10    40 	/*									*/
 10    41 	/*   dcl	1 error_control_table (2)	aligned internal static,			*/
 10    42 	/*	  2 severity		fixed bin(17) unaligned init (2,3),		*/
 10    43 	/*	  2 Soutput_stmt		bit(1) unaligned initial ("0"b,"1"b),		*/
 10    44 	/*	  2 message		char(252) varying initial (			*/
 10    45 	/*		"The reduction source segment does not contain any reductions.",	*/
 10    46 	/*		"Reduction label  '^a'  is invalid."),				*/
 10    47 	/*	  2 brief_message		char(100) varying initial (			*/
 10    48 	/*		"", "'^a'");						*/
 10    49 	/*									*/
 10    50 	/* error_control_table is an array of structures, with one array element per error.	*/
 10    51 	/* Each structure contains: a severity level for the error; a switch which specifies	*/
 10    52 	/* whether the source statement being processed should be output after the error message;	*/
 10    53 	/* the long form of the error message text;  and the brief form of the error message text.*/
 10    54 	/* The dimension of the error_control_table array of structures, and the lengths of	*/
 10    55 	/* message (long message) and brief_message (brief message), are compiler-defined.	*/
 10    56 	/* structures and the lengths of the message and brief_message are compiler-defined.	*/
 10    57 	/* The only requirement is that the messages be 256 characters or less in length.	*/
 10    58 	/* (Remember that the longest character string which can be used in an initial attribute	*/
 10    59 	/* is 254 characters in length.)						*/
 10    60 	/*									*/
 10    61 	/*      The severity number causes the error message to be preceded by a herald which	*/
 10    62 	/* includes one of the following prefixes:					*/
 10    63 	/*									*/
 10    64 	/*       _s_e_v  _p_r_e_f_i_x 		  _e_x_p_l_a_n_a_t_i_o_n				*/
 10    65 	/*	0 = COMMENT		- this is a comment.			*/
 10    66 	/*	1 = WARNING		- a possible error has been detected.  The	*/
 10    67 	/*				  compiler will still generate an object segment.	*/
 10    68 	/*	2 = ERROR			- a probable error has been detected.  The	*/
 10    69 	/*				  compiler will still generate an object segment.	*/
 10    70 	/*	3 = FATAL ERROR		- an error has been detected which is so severe 	*/
 10    71 	/*				  that no object segment will be generated.	*/
 10    72 	/*	4 = TRANSLATOR ERROR	- an error has been detected in the operation of	*/
 10    73 	/*				  the compiler or translator.  No object segment	*/
 10    74 	/*				  will be generated.			*/
 10    75 	/*									*/
 10    76 	/* Full error messages are of the form:						*/
 10    77 	/*									*/
 10    78 	/*	_p_r_e_f_i_x _e_r_r_o_r__n_u_m_b_e_r, SEVERITY _s_e_v_e_r_i_t_y IN STATEMENT _n OF LINE _m		*/
 10    79 	/*	_t_e_x_t__o_f__e_r_r_o_r__m_e_s_s_a_g_e						*/
 10    80 	/*	SOURCE:								*/
 10    81 	/*	_s_o_u_r_c_e__s_t_a_t_e_m_e_n_t							*/
 10    82 	/*									*/
 10    83 	/* If only one statement appears in line _m, then "STATEMENT _n OF" is omitted.		*/
 10    84 	/* If the source statement has been printed in a previous error message, it is omitted.	*/
 10    85 	/*									*/
 10    86 	/*      The reduction compiler declares a bit string, SERROR_CONTROL, which controls the	*/
 10    87 	/* text of an error message.  The compiler may set this bit string, as shown below.	*/
 10    88 	/*									*/
 10    89 	/*   SERROR_CONTROL		_m_e_a_n_i_n_g						*/
 10    90 	/*	"00"b		the first time a particular error occurs, the long message	*/
 10    91 	/*			is printed; the brief message is used in subsequent	*/
 10    92 	/*			occurrences of that error.				*/
 10    93 	/*        "10"b or "11"b	the long error message is always used.			*/
 10    94 	/*	"01"b		the brief error message is always used.			*/
 10    95 	/* The initial value of SERROR_CONTROL is "00"b.					*/
 10    96 	/*									*/
 10    97 	/*      The reduction_compiler creates a declaration for SERROR_PRINTED, an array	*/
 10    98 	/* of switches (one per error).  The switch corresponding to a particular error is	*/
 10    99 	/* turned on whenever the error message is printed.  This allows lex_error_ to detect	*/
 10   100 	/* subsequent occurrences of that same error.					*/
 10   101 	/*									*/
 10   102 	/*      The reduction_compiler creates MERROR_SEVERITY, a fixed bin(17) integer		*/
 10   103 	/* in which the severity of the highest-severity error encountered is maintained.	*/
 10   104 	/* The compiler may reference this integer.					*/
 10   105 	/*									*/
 10   106 	/*      The reduction_compiler creates MIN_PRINT_SEVERITY, a fixed bin (17) integer	*/
 10   107 	/* which controls the printing of error messages by the ERROR procedure.		*/
 10   108 	/* Errors having a severity less than MIN_PRINT_SEVERITY will not cause lex_error_ to be	*/
 10   109 	/* and no error will be printed.  The behaviour of the ERROR procedure for such errors	*/
 10   110 	/* is controlled by the value of PRINT_SEVERITY_CONTROL, described below.		*/
 10   111 	/* The compiler may set the value of MIN_PRINT_SEVERITY; its initial value is 0.	*/
 10   112 
 10   113 	/*									*/
 10   114 	/*      The reduction_compiler declares a bit string, PRINT_SEVERITY_CONTROL, which 	*/
 10   115 	/* controls the updating of MERROR_SEVERITY and SERROR_PRINTED when the severity of an	*/
 10   116 	/* error is less than MIN_PRINT_SEVERITY.  In such cases, the lex_error_ procedure is not	*/
 10   117 	/* invoked, and the ERROR procedure must update these values as though lex_error_ were	*/
 10   118 	/* called.  The compiler may set this bit string, as shown below.			*/
 10   119 	/*									*/
 10   120 	/* PRINT_SEVERITY_CONTROL	_m_e_a_n_i_n_g						*/
 10   121 	/*	"00"b		update neither SERROR_PRINTED nor MERROR_SEVERITY.	*/
 10   122 	/*	"01"b		update SERROR_PRINTED to reflect the error.		*/
 10   123 	/*	"10"b		update MERROR_SEVERITY to reflect the error severity.	*/
 10   124 	/*	"11"b		update SERROR_PRINTED and MERROR_SEVERITY appropriately.	*/
 10   125 	/*The initial value of PRINT_SEVERITY_CONTROL is "11"b.				*/
 10   126 	/*									*/
 10   127 	/*      The ERROR procedure is simple to use, but it does limit the flexibility of the	*/
 10   128 	/* error message.  A compiler action routine can output more flexible error messages	*/
 10   129 	/* by calling lex_error_ directly.  See lex_error_ documentation for more details.	*/
 10   130 	/*									*/
 10   131 	/* S__t_a_t_u_s									*/
 10   132 	/*									*/
 10   133 	/* 0) Created:  April, 1974 by G. C. Dixon					*/
 10   134 	/* 1) Modified: April, 1982 by E. N. Kittlitz.  Added MIN_PRINT_SEVERITY, 		*/
 10   135 	/*		PRINT_SEVERITY_CONTROL.					*/
 10   136 	/*									*/
 10   137 	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
 10   138 
 10   139 ERROR:	procedure (Nerror);
 10   140 
 10   141      dcl	Nerror			fixed bin;	/* Number of the error which was detected. (In)	*/
 10   142 
 10   143      dcl	Pstmt			ptr,
 10   144 	1 erring_token		aligned based (Perring_token) like token,
 10   145 	Perring_token		ptr,
 10   146 	erring_token_value		char(erring_token.Lvalue) based (erring_token.Pvalue);
 10   147 
 10   148      dcl 	(max, null)		builtin;
 10   149 
 10   150      dcl	lex_error_		entry options (variable);
 10   151 
 10   152 
 10   153 	if error_control_table.severity(Nerror) < MIN_PRINT_SEVERITY then do; /* don't print		*/
 10   154 	     if PRINT_SEVERITY_CONTROL & "1"b then	/* update MERROR_SEVERITY			*/
 10   155 		MERROR_SEVERITY = max (MERROR_SEVERITY, error_control_table.severity(Nerror));
 10   156 	     if PRINT_SEVERITY_CONTROL & "01"b then	/* update SERROR_PRINTED			*/
 10   157 		SERROR_PRINTED(Nerror) = "1"b;
 10   158 	     return;
 10   159 	end;
 10   160 	Perring_token = Pthis_token;			/* address the current erring_token.		*/
 10   161 	if error_control_table.Soutput_stmt(Nerror) then
 10   162 	     if Perring_token = null then
 10   163 		Pstmt = null;
 10   164 	     else
 10   165 		Pstmt = erring_token.Pstmt;		/* address the statement descriptor.		*/
 10   166 	else
 10   167 	     Pstmt = null;
 10   168 	if Perring_token = null then
 10   169 	     call lex_error_ (Nerror, SERROR_PRINTED(Nerror), (error_control_table.severity(Nerror)),
 10   170 		MERROR_SEVERITY, Pstmt, Perring_token, SERROR_CONTROL, (error_control_table.message(Nerror)),
 10   171 		(error_control_table.brief_message(Nerror)));
 10   172 	else
 10   173 	     call lex_error_ (Nerror, SERROR_PRINTED(Nerror), (error_control_table.severity(Nerror)),
 10   174 		MERROR_SEVERITY, Pstmt, Perring_token, SERROR_CONTROL, (error_control_table.message(Nerror)),
 10   175 		(error_control_table.brief_message(Nerror)), erring_token_value, erring_token_value, erring_token_value);
 10   176 
 10   177 	end ERROR;
 10   178 
 10   179 	/* END OF:	rdc_error_.incl.pl1		  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
      963 
      964 
      965 	end hcom_parse_;
	SOURCE FILES USED IN THIS COMPILATION.

LINE      NUMBER  DATE MODIFIED     NAME			PATHNAME
             0    04/26/87  1556.1  hcom_parse_.pl1                   >spec>install>1026>hcom_parse_.pl1
185          1    06/05/86  1155.4  hcom_data.incl.pl1                >ldd>include>hcom_data.incl.pl1
612          2    03/24/82  1347.2  condition_info_header.incl.pl1    >ldd>include>condition_info_header.incl.pl1
614          3    06/28/79  1204.8  condition_info.incl.pl1           >ldd>include>condition_info.incl.pl1
616          4    02/27/84  1141.9  command_question_info.incl.pl1    >ldd>include>command_question_info.incl.pl1
621          5    02/19/86  1535.3  hcom_field_names.incl.pl1         >ldd>include>hcom_field_names.incl.pl1
628          6    04/18/75  1242.4  rdc_start_.incl.pl1               >ldd>include>rdc_start_.incl.pl1
6-25         7    04/18/75  1242.4  lex_descriptors_.incl.pl1         >ldd>include>lex_descriptors_.incl.pl1
728          8    03/17/86  1534.3  rdc_end_.incl.pl1                 >ldd>include>rdc_end_.incl.pl1
961          9    04/18/75  1242.4  rdc_lex_.incl.pl1                 >ldd>include>rdc_lex_.incl.pl1
963         10    08/15/83  1511.7  rdc_error_.incl.pl1               >ldd>include>rdc_error_.incl.pl1
	NAMES DECLARED IN THIS COMPILATION.

IDENTIFIER	     OFFSET    LOC STORAGE CLASS   DATA TYPE		ATTRIBUTES AND REFERENCES
								(* indicates a set context)

NAMES DECLARED BY DECLARE STATEMENT.
APPROVAL_FIELD_NAME             001270 constant        varying char(24)         initial dcl 5-11 set ref 443*
APstmt                          000136 automatic       pointer                  dcl 282 set ref 324*
APtoken                         000140 automatic       pointer                  dcl 282 set ref 324* 327
AUDIT_FIELD_NAME                001261 constant        varying char(24)         initial dcl 5-12 set ref 397*
AUTHOR_FIELD_NAME               001277 constant        varying char(24)         initial dcl 5-10 set ref 410*
BACKSPACE                       006472 constant        char(1)                  initial dcl 6-99 ref 8-113
BREAKS                          001311 constant        varying char(9)          initial dcl 272 set ref 322* 324*
CALLER                          001315 constant        char(15)                 initial unaligned dcl 1-146 set ref 315* 397 410 443
                                                                                  461 470 525*
CODE                            000335 automatic       fixed bin(35,0)          dcl 6-33 set ref 8-106* 8-107
Ccode                           000134 automatic       fixed bin(35,0)          dcl 269 set ref 343*
DIRECTION                       000340 automatic       fixed bin(17,0)          initial dcl 630 set ref 8-62 630*
ERROR_RETURN_LABEL                     parameter       label variable           dcl 43 ref 40 347
FORM                                   based           fixed bin(17,0)          level 2 packed unaligned dcl 6-48 ref 8-65 8-70
                                                                                  8-123
False                                  constant        bit(1)                   initial unaligned dcl 289 ref 301 304 368 489 490
                                                                                  496
HT_SP_NL_VT                     001251 constant        char(4)                  initial unaligned dcl 544 ref 582 597
HT_SP_VT                        001250 constant        char(3)                  initial unaligned dcl 544 ref 569
I                                      based           fixed bin(17,0)          level 2 in structure "TOKEN_REQD_STRING" packed
                                                                                  unaligned dcl 6-48 in procedure
                                                                                  "SEMANTIC_ANALYSIS" ref 8-126
I                               000336 automatic       fixed bin(17,0)          dcl 6-33 in procedure "SEMANTIC_ANALYSIS" set ref
                                                                                  8-62* 8-63 8-79*
IFIRST                                 based           fixed bin(17,0)          level 3 packed unaligned dcl 6-48 ref 8-62 8-73 8-79
                                                                                  8-79
IGBREAKS                        001306 constant        varying char(5)          initial dcl 275 set ref 322* 324*
ILAST                     0(18)        based           fixed bin(17,0)          level 3 packed unaligned dcl 6-48 ref 8-62 8-73 8-79
INPUTxxx                               constant        fixed bin(2,0)           initial dcl 1-146 ref 390 419 453
INSTALL_FIELD_NAME              001252 constant        varying char(24)         initial dcl 5-13 set ref 461* 470*
Iline                           000314 automatic       fixed bin(21,0)          dcl 544 set ref 583* 584 591 592 592 594
L                         0(18)        based           fixed bin(17,0)          level 2 packed unaligned dcl 6-48 ref 8-127
LEXCTL                          000051 internal static varying char(128)        dcl 241 set ref 322* 324*
LEXDLM                          000010 internal static varying char(128)        dcl 241 set ref 322* 324*
LTOKEN_REQD_VALUE               000324 automatic       fixed bin(18,0)          dcl 6-33 set ref 8-127* 8-128
Lignore                         000142 automatic       fixed bin(21,0)          dcl 285 set ref 313* 324 324*
Ltext                           000306 automatic       fixed bin(21,0)          dcl 544 set ref 568* 569 570* 570 572 574* 576 578
                                                                                  579* 582 582 583 586 587* 592 594* 594
Ltext_line                      000312 automatic       fixed bin(21,0)          dcl 544 set ref 586* 591* 597 597 599 599 604 605
Lvalue                    4            based           fixed bin(18,0)          level 2 in structure "token" dcl 7-68 in procedure
                                                                                  "hcom_parse_" ref 367 367 393 397 410 422 426 443
                                                                                  456 461 470 568 8-92 8-92 8-92 8-92 8-106 8-106
                                                                                  8-113 8-113 8-128
Lvalue                    4            based           fixed bin(18,0)          level 2 in structure "erring_token" dcl 10-143
                                                                                  in procedure "ERROR" ref 10-172 10-172 10-172
                                                                                  10-172 10-172 10-172
MERROR_SEVERITY                 000243 automatic       fixed bin(17,0)          initial dcl 10-3 set ref 335 10-3* 10-154* 10-154
                                                                                  10-168* 10-172*
MIN_PRINT_SEVERITY              000245 automatic       fixed bin(17,0)          initial dcl 10-3 set ref 306* 10-3* 10-153
NL                                     constant        char(1)                  initial unaligned dcl 544 ref 572 583
NRED                            000325 automatic       fixed bin(17,0)          dcl 6-33 set ref 8-52* 8-55* 8-55 8-58 752 762* 799*
                                                                                  810* 814* 818* 839* 848* 856* 865* 873* 882*
NUMBER                          000337 automatic       fixed bin(35,0)          dcl 6-33 set ref 8-106* 8-108
Nerror                                 parameter       fixed bin(17,0)          dcl 10-141 set ref 10-139 10-153 10-154 10-156
                                                                                  10-161 10-168* 10-168 10-168 10-168 10-168 10-172*
                                                                                  10-172 10-172 10-172 10-172
Nvalue                   10            based           fixed bin(35,0)          level 3 packed unaligned dcl 7-68 set ref 8-101
                                                                                  8-108* 755
OPERANDxxx                             constant        fixed bin(2,0)           initial dcl 1-146 ref 390 419 453
PRED                            000326 automatic       pointer                  dcl 6-33 set ref 8-58* 8-62 8-62 8-73 8-73 8-79 8-79
                                                                                  8-79
PRINT_SEVERITY_CONTROL          000246 automatic       bit(2)                   initial unaligned dcl 10-3 set ref 10-3* 10-154
                                                                                  10-156
PTOKEN_REQD                     000330 automatic       pointer                  dcl 6-33 set ref 8-63* 8-65 8-65 8-70 8-71 8-123
                                                                                  8-126 8-127 731
PTOKEN_REQD_VALUE               000332 automatic       pointer                  dcl 6-33 set ref 8-126* 8-128
Pd                                     parameter       pointer                  dcl 1-29 ref 40 306 331 390 390 390 397 410 419 419
                                                                                  419 427 428 436 436 438 438 440 443 453 453 453
                                                                                  460 470 517 522 522 525 525 525 525 525 525 525
                                                                                  525 576 579
Perring_token                   000406 automatic       pointer                  dcl 10-143 set ref 10-160* 10-161 10-164 10-168
                                                                                  10-168* 10-172* 10-172 10-172 10-172 10-172 10-172
                                                                                  10-172 10-172 10-172 10-172
Plast                     2            based           pointer                  level 2 packed unaligned dcl 7-68 ref 9-45 9-47
Pnext                     1            based           pointer                  level 2 packed unaligned dcl 7-68 ref 8-79 748 792
                                                                                  797 900 920 940 9-39 9-40
Pstmt                           000404 automatic       pointer                  dcl 10-143 in procedure "ERROR" set ref 10-161*
                                                                                  10-164* 10-166* 10-168* 10-172*
Pstmt                     5            based           pointer                  level 2 in structure "erring_token" packed unaligned
                                                                                  dcl 10-143 in procedure "ERROR" ref 10-164
Ptext                           000304 automatic       pointer                  dcl 544 set ref 567* 569 572* 572 574 582 583 585
                                                                                  586 590 592* 592
Ptext_line                      000310 automatic       pointer                  dcl 544 set ref 585* 590* 597 597 599 599 604 605
Pthis_token                     000236 automatic       pointer                  dcl 6-23 set ref 327* 8-60 751 792 792* 797 797* 900
                                                                                  900* 920 920* 940 940* 9-36 9-49* 10-160
Ptoken                          000240 automatic       pointer                  dcl 7-68 set ref 367 367 367 393 393 397 397 410 410
                                                                                  422 422 426 426 443 443 456 456 461 461 470 470
                                                                                  568 568 8-60* 8-64 8-73 8-79 8-86 8-92 8-92 8-92
                                                                                  8-92 8-92 8-92 8-92 8-101 8-104 8-106 8-106 8-106
                                                                                  8-108 8-113 8-113 8-113 8-113 8-118 8-124 8-128
                                                                                  8-128 748* 748 751* 755 792* 797* 900* 920* 940*
                                                                                  9-36* 9-37 9-39 9-40* 9-40 9-42* 9-45 9-47* 9-47
                                                                                  9-49
Pvalue                    3            based           pointer                  level 2 in structure "token" packed unaligned
                                                                                  dcl 7-68 in procedure "hcom_parse_" ref 367 393
                                                                                  397 410 422 426 443 456 461 470 568 8-92 8-92
                                                                                  8-106 8-113 8-128
Pvalue                    3            based           pointer                  level 2 in structure "erring_token" packed unaligned
                                                                                  dcl 10-143 in procedure "ERROR" ref 10-172 10-172
                                                                                  10-172
RED                                    based           structure                level 1 dcl 6-48
REDUCTION                              based           structure                array level 1 packed unaligned dcl 633 set ref 8-58
REDUCTIONS                      001201 constant        fixed bin(17,0)          initial array unaligned dcl 633 set ref 8-58
REPLACE_FIELD                          constant        fixed bin(17,0)          initial dcl 1-146 ref 390 419 453
S                        11            based           structure                level 3 packed unaligned dcl 7-68
SERROR_CONTROL                  000244 automatic       bit(2)                   initial unaligned dcl 10-3 set ref 10-3* 10-168*
                                                                                  10-172*
SERROR_PRINTED                  000245 automatic       bit(1)                   initial array unaligned dcl 10-3 set ref 10-3*
                                                                                  10-156* 10-168* 10-172*
SPACES                          001246 constant        char(5)                  initial unaligned dcl 544 ref 599
SPDL                            000242 automatic       bit(1)                   initial dcl 958 set ref 958* 8-73 9-42
STOKEN_FCN                      000334 automatic       bit(1)                   dcl 6-33 set ref 733* 735* 737* 739* 741* 744
Saf                    1772            based           bit(1)                   level 2 dcl 1-29 ref 522
Scfix_found            1774            based           bit(1)                   level 2 dcl 1-29 set ref 427* 428* 436 460
Serrors                         000156 automatic       bit(1)                   unaligned dcl 296 set ref 301* 331 347 514*
Soutput_stmt              0(18) 000000 constant        bit(1)                   initial array level 2 packed unaligned dcl 189 ref
                                                                                  10-161
Sprt_path                              parameter       bit(1)                   unaligned dcl 43 set ref 40 516 519*
Ssite                  1775            based           bit(1)                   level 2 dcl 1-29 ref 438
TOKEN_REQD                             based           structure                level 1 dcl 6-48 in procedure "SEMANTIC_ANALYSIS"
TOKEN_REQD                             based           structure                level 2 in structure "RED" packed unaligned dcl 6-48
                                                                                  in procedure "SEMANTIC_ANALYSIS"
TOKEN_REQD_STRING                      based           structure                level 1 dcl 6-48
TOKEN_REQD_VALUE                       based           char                     unaligned dcl 6-48 ref 8-128
TOKEN_REQUIREMENT                      based           structure                array level 1 packed unaligned dcl 678 set ref 8-63
TOKEN_REQUIREMENTS              001021 constant        fixed bin(17,0)          initial array unaligned dcl 678 set ref 8-63
TOKEN_STRINGS                          based           char(29)                 dcl 723 set ref 8-126
TOKEN_STRING_ARRAYS             000770 constant        char(100)                initial array dcl 723 set ref 8-126
TRACING                         000112 internal static bit(1)                   initial dcl 625 set ref 8-50* 8-50
TYPE                      0(18)        based           fixed bin(17,0)          level 2 packed unaligned dcl 6-48 ref 8-65 8-71 731
True                                   constant        bit(1)                   initial unaligned dcl 289 ref 427 428 488 514 519
                                                                                  837 854 871
addcharno                                              builtin function         dcl 256 ref 572
addr                                                   builtin function         dcl 256 in procedure "hcom_parse_" ref 313 313 324
                                                                                  324 484 484 567 568 568 572 574 592
addr                                                   builtin function         dcl 6-92 in procedure "SEMANTIC_ANALYSIS" ref 8-58
                                                                                  8-58 8-63 8-63 8-126 8-126
ag                                     based           structure                level 2 dcl 1-29
answer                                 based           char                     unaligned dcl 479 set ref 492*
answer_lth              122            based           fixed bin(21,0)          level 2 dcl 4-13 set ref 491* 492
answer_ptr              120            based           pointer                  level 2 dcl 4-13 ref 492
answer_sw               106(03)        based           bit(1)                   level 3 packed unaligned dcl 4-13 set ref 490*
approve_dt               16            parameter       char(8)                  level 2 dcl 187 set ref 834* 844*
approve_value            20            parameter       varying char(24)         level 2 dcl 187 set ref 836* 846*
apv                     344            based           fixed bin(2,0)           level 5 dcl 1-29 ref 419 419
aud                     345            based           fixed bin(2,0)           level 5 dcl 1-29 ref 390 390
audit_dt                 27            parameter       char(8)                  level 2 dcl 187 set ref 851* 861*
audit_person             31            parameter       varying char(24)         level 2 dcl 187 set ref 853* 863*
brief_message            26     000000 constant        varying char(4)          initial array level 2 dcl 189 ref 10-168 10-172
change_dt                              parameter       char(8)                  level 2 dcl 187 set ref 758*
change_person             7            parameter       varying char(24)         level 2 dcl 187 set ref 760*
char                                                   builtin function         dcl 256 ref 563 577 578
charno                                                 builtin function         dcl 256 ref 313 313 568 568 574 574
cleanup                         000144 stack reference condition                dcl 287 ref 310
clock_time                      000212 automatic       fixed bin(71,0)          dcl 359 set ref 367* 371*
cmt                                    parameter       char                     unaligned dcl 43 set ref 40 313 324 331* 567 568 574
                                                                                  574
code                            000266 automatic       fixed bin(35,0)          dcl 365 in procedure "date" set ref 367* 368 372
code                                   parameter       fixed bin(35,0)          dcl 43 in procedure "hcom_parse_" set ref 40 315*
                                                                                  316 324* 335 335* 484* 525 525*
com_err_                        000114 constant        entry                    external dcl 216 ref 525
com_spec               1557            based           structure                level 2 dcl 1-29
command_question                000000 stack reference condition                dcl 287 ref 385 406 431 465 482
command_question_info                  based           structure                level 1 dcl 4-13
comment_no                6            parameter       fixed bin(17,0)          level 2 dcl 187 set ref 525* 755*
comments                  1            based           structure                array level 2 dcl 1-189
comp                   2160            based           char(32)                 level 3 packed unaligned dcl 1-29 set ref 525* 525*
cond_info                       000100 automatic       structure                level 1 dcl 214 set ref 484 484
condition_info                         based           structure                level 1 dcl 3-14
condition_info_header                  based           structure                level 1 dcl 2-6
condition_info_version_1               constant        fixed bin(17,0)          initial dcl 3-30 ref 483
convert_date_to_binary_         000136 constant        entry                    external dcl 244 ref 367
cq_info_ptr                     000234 automatic       pointer                  dcl 4-42 set ref 485* 486 486 488 489 490 491 492
                                                                                  492
ctl                       6            based           structure                level 3 dcl 1-29
cv_dec_check_                   000154 constant        entry                    external dcl 6-96 ref 8-106
d                                      based           structure                level 1 dcl 1-29
date_out                        000214 automatic       char(8)                  dcl 359 set ref 371* 758 844 861 878
date_time_$format               000140 constant        entry                    external dcl 244 ref 371
dimension                                              builtin function         dcl 256 ref 10-3 10-3
dir                    2076            based           char(168)                level 3 packed unaligned dcl 1-29 set ref 525* 525*
ent                    2150            based           char(32)                 level 3 packed unaligned dcl 1-29 set ref 525* 525*
err_msg                1036            parameter       varying char(80)         array level 2 dcl 187 set ref 563* 577* 578*
err_no                                 parameter       fixed bin(17,0)          dcl 512 set ref 509 530*
erring_token                           based           structure                level 1 dcl 10-143
erring_token_value                     based           char                     unaligned dcl 10-143 set ref 10-172* 10-172* 10-172*
error_control_table             000000 constant        structure                array level 1 unaligned dcl 189 ref 10-3 10-3
error_msg                       000157 automatic       varying char(100)        dcl 299 set ref 302* 397* 410* 443* 461* 470* 531
                                                                                  531*
error_table_$bigarg             000116 external static fixed bin(35,0)          dcl 218 ref 525 577
error_table_$improper_data_format
                                000120 external static fixed bin(35,0)          dcl 219 ref 563
error_table_$translation_failed 000152 external static fixed bin(35,0)          dcl 254 ref 335
errors                    6            based           bit(1)                   level 4 packed unaligned dcl 1-29 ref 306 331 517
find_condition_info_            000122 constant        entry                    external dcl 222 ref 484
from                   1562            based           structure                array level 4 dcl 1-29
group2                    7            based           structure                level 2 packed unaligned dcl 7-68
hcom_cfix_validate_             000124 constant        entry                    external dcl 224 ref 436 461
hcom_default_validate_          000130 constant        entry                    external dcl 230 ref 440
hcom_site_validate_             000126 constant        entry                    external dcl 227 ref 438
i                               000372 automatic       fixed bin(17,0)          dcl 9-33 in procedure "LEX" set ref 9-39* 9-42 9-45*
i                               000313 automatic       fixed bin(21,0)          dcl 544 in procedure "set_text" set ref 569* 570
                                                                                  604* 605
ident                           000225 automatic       varying char(24)         dcl 378 set ref 422* 443* 456* 461* 470* 846 880
in                      346            based           fixed bin(2,0)           level 5 dcl 1-29 ref 453 453
index                                                  builtin function         dcl 256 ref 426 583
info_ptr                 14     000100 automatic       pointer                  level 2 dcl 214 set ref 485
input                   343            based           structure                level 3 dcl 1-29
install_dt               40            parameter       char(8)                  level 2 dcl 187 set ref 868* 878*
install_id               42            parameter       varying char(24)         level 2 dcl 187 set ref 870* 880*
ioa_                            000142 constant        entry                    external dcl 244 ref 331 517 531
length                                                 builtin function         dcl 256 ref 324 486 491 572 574 586
lex_error_                      000156 constant        entry                    external dcl 10-150 ref 10-168 10-172
lex_string_$init_lex_delims     000132 constant        entry                    external dcl 233 ref 322
lex_string_$lex                 000134 constant        entry                    external dcl 237 ref 324
max                                                    builtin function         dcl 10-148 ref 10-154
max_answer_lth          123            based           fixed bin(21,0)          level 2 dcl 4-13 ref 486
maxlength                                              builtin function         dcl 256 ref 525 525 576 579
message                   1     000000 constant        varying char(80)         initial array level 2 dcl 189 ref 10-168 10-172
n                                      parameter       fixed bin(17,0)          dcl 9-33 ref 9-31 9-38 9-39 9-42 9-45
name                                   based           fixed bin(17,0)          level 4 dcl 1-29 ref 390 419 453
null                                                   builtin function         dcl 256 in procedure "hcom_parse_" ref 309 343 345
                                                                                  484 484 9-37 9-39 9-42 9-45
null                                                   builtin function         dcl 6-92 in procedure "SEMANTIC_ANALYSIS" ref 8-64
                                                                                  8-73 8-79 8-86
null                                                   builtin function         dcl 10-148 in procedure "ERROR" ref 10-161 10-161
                                                                                  10-166 10-168
null_approve                    000152 automatic       bit(1)                   unaligned dcl 292 set ref 304* 561 837*
null_audit                      000153 automatic       bit(1)                   unaligned dcl 292 set ref 304* 561 854*
null_install                    000154 automatic       bit(1)                   unaligned dcl 292 set ref 304* 561 871*
op                                     based           structure                level 3 dcl 1-29
path                                   parameter       char                     unaligned dcl 43 set ref 40 517*
pathname_$component             000144 constant        entry                    external dcl 244 ref 525 525
person                          000216 automatic       varying char(24)         dcl 378 set ref 393* 397* 410* 760 863
preset_sw               106(02)        based           bit(1)                   level 3 packed unaligned dcl 4-13 set ref 488*
proc_ptr                        000132 automatic       pointer                  dcl 269 set ref 309* 315* 324* 343 343* 345*
question_sw             106            based           bit(1)                   level 3 packed unaligned dcl 4-13 set ref 489*
quoted_string            11(01)        based           bit(1)                   level 4 packed unaligned dcl 7-68 ref 8-92 8-104
                                                                                  8-113 8-118 8-124
range                  1562            based           structure                array level 3 dcl 1-29
reverse                                                builtin function         dcl 256 ref 569
search                                                 builtin function         dcl 6-92 ref 8-92
seg                                    parameter       char                     unaligned dcl 43 in procedure "hcom_parse_" set ref
                                                                                  40 313 324 324
seg                    2076            based           structure                level 2 in structure "d" dcl 1-29 in procedure
                                                                                  "hcom_parse_"
select                  343            based           structure                level 4 dcl 1-29
selected               1557            based           structure                level 3 packed unaligned dcl 1-29
set_return_arg         1756            based           entry variable           level 2 dcl 1-29 ref 522
severity                        000000 constant        fixed bin(17,0)          initial array level 2 packed unaligned dcl 189 ref
                                                                                  10-153 10-154 10-168 10-172
source                    7            based           structure                level 3 dcl 1-29
src_array                              based           structure                level 1 dcl 1-189
src_array_comment                      parameter       structure                level 1 dcl 187 set ref 40
substr                                                 builtin function         dcl 256 in procedure "hcom_parse_" ref 599 599 605
substr                                                 builtin function         dcl 6-92 in procedure "SEMANTIC_ANALYSIS" ref 8-92
                                                                                  8-126
summary                  51            parameter       varying char(2000)       level 2 in structure "src_array_comment" dcl 187
                                                                                  in procedure "hcom_parse_" set ref 597* 597 599*
                                                                                  599 605* 605
summary                 420            based           varying char(2000)       level 5 in structure "d" dcl 1-29 in procedure
                                                                                  "hcom_parse_" ref 525 525 576 579
switches                106            based           structure                level 2 dcl 4-13
text                                   based           char                     unaligned dcl 544 ref 569 582 583 586
text_arr                               based           char(1)                  array unaligned dcl 544 set ref 572 592
text_line                              based           char                     unaligned dcl 544 ref 597 597 599 599 604 605
token                                  based           structure                level 1 dcl 7-68
token_value                            based           char                     unaligned dcl 7-68 set ref 367* 393 397 410 422 426
                                                                                  443 456 461 470 568 8-92 8-92 8-106* 8-113 8-128
translator_temp_$get_segment    000146 constant        entry                    external dcl 244 ref 315
translator_temp_$release_all_segments
                                000150 constant        entry                    external dcl 244 ref 343
valid                           000155 automatic       bit(1)                   unaligned dcl 296 set ref 397* 399 410* 412 443* 445
                                                                                  461* 462 470* 472
value                   347            based           structure                level 4 dcl 1-29
vdt                       2            based           entry variable           level 3 dcl 1-29 set ref 397 410 436* 438* 440* 443
                                                                                  470
verify                                                 builtin function         dcl 6-92 in procedure "SEMANTIC_ANALYSIS" ref 8-92
verify                                                 builtin function         dcl 256 in procedure "hcom_parse_" ref 569 582 597
                                                                                  604
version                   2     000100 automatic       fixed bin(17,0)          level 2 dcl 214 set ref 483*
yes_or_no_sw            106(01)        based           bit(1)                   level 3 packed unaligned dcl 4-13 ref 486

NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED.
ADD                                    internal static fixed bin(17,0)          initial dcl 1-146
ADD_FIELD                              internal static fixed bin(17,0)          initial dcl 1-146
ALL                                    internal static bit(36)                  initial dcl 1-146
CHECK                                  internal static fixed bin(17,0)          initial dcl 1-146
CLEARxxx                               internal static fixed bin(2,0)           initial dcl 1-146
COMPARE                                internal static fixed bin(17,0)          initial dcl 1-146
DISPLAY                                internal static fixed bin(17,0)          initial dcl 1-146
EXISTS                                 internal static fixed bin(17,0)          initial dcl 1-146
FORMAT                                 internal static fixed bin(17,0)          initial dcl 1-146
GET                                    internal static fixed bin(17,0)          initial dcl 1-146
INSTALL                                internal static fixed bin(17,0)          initial dcl 1-146
LAST                                   internal static fixed bin(2,0)           initial dcl 1-146
MINUS                                  internal static fixed bin(2,0)           initial dcl 1-146
MODIFY                                 internal static bit(1)                   initial unaligned dcl 1-146
NOCOMP                                 internal static fixed bin(35,0)          initial dcl 1-146
NONSTAR                                internal static fixed bin(35,0)          initial dcl 1-146
NOTSET                                 internal static fixed bin(17,0)          initial dcl 1-146
NO_MODIFY                              internal static bit(1)                   initial unaligned dcl 1-146
NOxxx                                  internal static fixed bin(2,0)           initial dcl 1-146
PLUS                                   internal static fixed bin(2,0)           initial dcl 1-146
Pcomment                               automatic       pointer                  dcl 7-20
Psrc_array                             automatic       pointer                  dcl 1-209
Pstmt                                  automatic       pointer                  dcl 7-40
SET                                    internal static fixed bin(2,0)           initial dcl 1-146
STAR                                   internal static fixed bin(35,0)          initial dcl 1-146
STARSTAR                               internal static fixed bin(35,0)          initial dcl 1-146
UNSET                                  internal static fixed bin(2,0)           initial dcl 1-146
comment                                based           structure                level 1 dcl 7-20
comment_value                          based           char                     unaligned dcl 7-20
condition_info_header_ptr              automatic       pointer                  dcl 2-4
condition_info_ptr                     automatic       pointer                  dcl 3-10
cq_info_version_7                      internal static fixed bin(17,0)          initial dcl 4-44
max                                                    builtin function         dcl 6-92
oper                                   internal static varying char(16)         initial array dcl 1-177
stmt                                   based           structure                level 1 dcl 7-40
stmt_value                             based           char                     unaligned dcl 7-40
temp_seg_array                         based           pointer                  array dcl 1-29

NAMES DECLARED BY EXPLICIT CONTEXT.
ERROR                           005337 constant        entry                    internal dcl 10-139 ref 530
JANITOR                         002144 constant        entry                    internal dcl 341 ref 310 316 338
LEX                             005251 constant        entry                    internal dcl 9-31 ref 757 759 761 765 770 775 838
                                                                                  842 845 847 855 859 862 864 872 876 879 881 885
                                                                                  890 895 905 910 915 925 930 935
MY_ERROR                        003351 constant        entry                    internal dcl 509 ref 767 772 777 780 784 788 802 806
                                                                                  822 826 830 887 892 897 902 907 912 917 922 927
                                                                                  932 937 942 945 949
RD_ACTION                       000723 constant        label                    array(37) dcl 755 ref 752
RD_MATCH                        004467 constant        label                    dcl 748 ref 8-90 8-92 8-101 8-109 8-113 8-118 8-128
                                                                                  744
RD_MATCH_NO_TOKEN               004472 constant        label                    dcl 749 ref 8-73 8-79 8-86
RD_NEXT_REDUCTION               004136 constant        label                    dcl 8-55 ref 8-68 8-84 8-88 8-99 8-104 8-111 8-116
                                                                                  8-120 8-124 8-130 745
RD_TEST_REDUCTION               004137 constant        label                    dcl 8-58 ref 8-53 763 800 812 816 820 840 849 857
                                                                                  866 874 883
RD_TEST_RESULT                  004463 constant        label                    dcl 744 ref 734 736 738 740 742
RD_TEST_TOKEN                   000710 constant        label                    array(6) dcl 8-73 ref 8-65 8-71
RD_TOKEN_FCN                    000716 constant        label                    array(5) dcl 733 ref 731
RETURN_FALSE                    003262 constant        label                    dcl 496
SEMANTIC_ANALYSIS               004126 constant        entry                    internal dcl 6-30 ref 329
apv_id                          002575 constant        entry                    internal dcl 416 ref 737
audit_pers                      002302 constant        entry                    internal dcl 382 ref 739
change_pers                     002454 constant        entry                    internal dcl 403 ref 735
date                            002177 constant        entry                    internal dcl 362 ref 733
hcom_parse_                     001512 constant        entry                    external dcl 40
install_id                      003014 constant        entry                    internal dcl 450 ref 741
set_command_question            003266 constant        entry                    internal dcl 476 ref 387 408 433 467
set_text                        003565 constant        entry                    internal dcl 542 ref 794

THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION.

STORAGE REQUIREMENTS FOR THIS PROGRAM.

	Object	Text	Link	Symbol	Defs	Static
Start          0       0      7052        7232    6473        7062
Length      7672    6473       160         423     357         104

BLOCK NAME	         STACK SIZE     TYPE		WHY NONQUICK/WHO SHARES STACK FRAME
hcom_parse_                         780 external procedure  is an external procedure.  
on unit on line 310                  64 on unit               
JANITOR                              70 internal procedure  is called by several nonquick procedures.  
date                                    internal procedure  shares stack frame of external procedure hcom_parse_.  
audit_pers                          114 internal procedure  enables or reverts conditions.  
on unit on line 385                  64 on unit               
on unit on line 406                  64 on unit               
on unit on line 431                  64 on unit               
on unit on line 465                  64 on unit               
set_command_question                 82 internal procedure  enables or reverts conditions.  
MY_ERROR                                internal procedure  shares stack frame of external procedure hcom_parse_.  
set_text                                internal procedure  shares stack frame of external procedure hcom_parse_.  
SEMANTIC_ANALYSIS                       internal procedure  shares stack frame of external procedure hcom_parse_.  
LEX                                     internal procedure  shares stack frame of external procedure hcom_parse_.  
ERROR                                   internal procedure  shares stack frame of external procedure hcom_parse_.  

STORAGE FOR INTERNAL STATIC VARIABLES.

   LOC IDENTIFIER                  BLOCK NAME
000010 LEXDLM                      hcom_parse_
000051 LEXCTL                      hcom_parse_
000112 TRACING                     hcom_parse_

STORAGE FOR AUTOMATIC VARIABLES.

STACK FRAME                 LOC IDENTIFIER                  BLOCK NAME
hcom_parse_              000100 cond_info                   hcom_parse_
                         000132 proc_ptr                    hcom_parse_
                         000134 Ccode                       hcom_parse_
                         000136 APstmt                      hcom_parse_
                         000140 APtoken                     hcom_parse_
                         000142 Lignore                     hcom_parse_
                         000152 null_approve                hcom_parse_
                         000153 null_audit                  hcom_parse_
                         000154 null_install                hcom_parse_
                         000155 valid                       hcom_parse_
                         000156 Serrors                     hcom_parse_
                         000157 error_msg                   hcom_parse_
                         000212 clock_time                  hcom_parse_
                         000214 date_out                    hcom_parse_
                         000216 person                      hcom_parse_
                         000225 ident                       hcom_parse_
                         000234 cq_info_ptr                 hcom_parse_
                         000236 Pthis_token                 hcom_parse_
                         000240 Ptoken                      hcom_parse_
                         000242 SPDL                        hcom_parse_
                         000243 MERROR_SEVERITY             hcom_parse_
                         000244 SERROR_CONTROL              hcom_parse_
                         000245 SERROR_PRINTED              hcom_parse_
                         000245 MIN_PRINT_SEVERITY          hcom_parse_
                         000246 PRINT_SEVERITY_CONTROL      hcom_parse_
                         000266 code                        date
                         000304 Ptext                       set_text
                         000306 Ltext                       set_text
                         000310 Ptext_line                  set_text
                         000312 Ltext_line                  set_text
                         000313 i                           set_text
                         000314 Iline                       set_text
                         000324 LTOKEN_REQD_VALUE           SEMANTIC_ANALYSIS
                         000325 NRED                        SEMANTIC_ANALYSIS
                         000326 PRED                        SEMANTIC_ANALYSIS
                         000330 PTOKEN_REQD                 SEMANTIC_ANALYSIS
                         000332 PTOKEN_REQD_VALUE           SEMANTIC_ANALYSIS
                         000334 STOKEN_FCN                  SEMANTIC_ANALYSIS
                         000335 CODE                        SEMANTIC_ANALYSIS
                         000336 I                           SEMANTIC_ANALYSIS
                         000337 NUMBER                      SEMANTIC_ANALYSIS
                         000340 DIRECTION                   SEMANTIC_ANALYSIS
                         000372 i                           LEX
                         000404 Pstmt                       ERROR
                         000406 Perring_token               ERROR

THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM.
r_e_as              alloc_char_temp     call_ent_var_desc   call_ext_out_desc   call_ext_out        call_int_this
call_int_other      return_mac          tra_ext_2           alloc_auto_adj      enable_op           shorten_stack
ext_entry_desc      int_entry           set_chars_eis       index_chars_eis

THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM.
com_err_                      convert_date_to_binary_       cv_dec_check_                 date_time_$format
find_condition_info_          hcom_cfix_validate_           hcom_default_validate_        hcom_site_validate_
ioa_                          lex_error_                    lex_string_$init_lex_delims   lex_string_$lex
pathname_$component           translator_temp_$get_segment  translator_temp_$release_all_segments

THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM.
error_table_$bigarg           error_table_$improper_data_format
error_table_$translation_failed




   LINE    LOC      LINE    LOC      LINE    LOC      LINE    LOC      LINE    LOC      LINE    LOC      LINE    LOC   
     40 001503       958 001537   10    3 001540   10  168 001571       301 001573       302 001574       304 001575
    306 001601       309 001611       310 001613       313 001635       315 001657       316 001702       322 001711
    324 001763       327 002073       329 002075       331 002076       335 002126       338 002136       339 002142
    341 002143       343 002151       345 002166       347 002171       350 002176       362 002177       367 002201
    368 002227       371 002234       372 002274       382 002301       385 002307       387 002323       388 002330
    390 002331       393 002345       394 002360       397 002364       399 002444       403 002453       406 002461
    408 002475       409 002502       410 002503       412 002565       416 002574       419 002602       422 002616
    423 002631       426 002635       427 002650       431 002653       433 002667       434 002674       436 002675
    438 002711       440 002721       443 002726       445 003004       450 003013       453 003021       456 003035
    457 003050       460 003054       461 003057       462 003140       465 003147       467 003163       468 003170
    470 003171       472 003253       496 003262       476 003265       482 003273       483 003274       484 003300
    485 003317       486 003325       488 003334       489 003336       490 003340       491 003342       492 003344
    494 003350       509 003351       514 003353       516 003355       517 003363       519 003410       522 003415
    525 003433       530 003531       531 003540       534 003564       542 003565       561 003566       563 003574
    564 003614       567 003615       568 003620       569 003643       570 003655       572 003657       574 003667
    576 003702       577 003706       578 003726       579 003742       582 003744       583 003762       584 003774
    585 003775       586 003776       587 004000       588 004001       590 004002       591 004003       592 004004
    594 004011       597 004013       599 004044       604 004070       605 004102       607 004124       609 004125
 6   30 004126       630 004127    8   50 004131    8   52 004134    8   53 004135    8   55 004136    8   58 004137
 8   60 004142    8   62 004144    8   63 004170    8   64 004173    8   65 004177    8   68 004207    8   70 004210
 8   71 004214    8   73 004216    8   79 004235    8   84 004246    8   86 004247    8   88 004253    8   90 004254
 8   92 004255    8   99 004311    8  101 004312    8  104 004315    8  106 004320    8  107 004344    8  108 004346
 8  109 004351    8  111 004352    8  113 004353    8  116 004367    8  118 004370    8  120 004374    8  123 004375
 8  124 004376    8  126 004402    8  127 004407    8  128 004413    8  130 004421       731 004422       733 004424
    734 004426       735 004427       736 004435       737 004436       738 004444       739 004445       740 004453
    741 004454       742 004462       744 004463       745 004466       748 004467       749 004472       751 004475
    752 004477       755 004501       757 004506       758 004512       759 004517       760 004523       761 004532
    762 004536       763 004540       765 004541       767 004545       768 004551       770 004552       772 004556
    773 004562       775 004563       777 004567       778 004573       780 004574       782 004600       784 004601
    786 004605       788 004606       790 004612       792 004613       794 004616       795 004617       797 004620
    799 004623       800 004625       802 004626       804 004632       806 004633       808 004637       810 004640
    812 004642       814 004643       816 004645       818 004646       820 004650       822 004651       824 004655
    826 004656       828 004662       830 004663       832 004667       834 004670       836 004675       837 004676
    838 004700       839 004704       840 004706       842 004707       844 004713       845 004720       846 004724
    847 004733       848 004737       849 004741       851 004742       853 004747       854 004750       855 004752
    856 004756       857 004760       859 004761       861 004765       862 004772       863 004776       864 005005
    865 005011       866 005013       868 005014       870 005021       871 005022       872 005024       873 005030
    874 005032       876 005033       878 005037       879 005044       880 005050       881 005057       882 005063
    883 005065       885 005066       887 005072       888 005076       890 005077       892 005103       893 005107
    895 005110       897 005114       898 005120       900 005121       902 005124       903 005130       905 005131
    907 005135       908 005141       910 005142       912 005146       913 005152       915 005153       917 005157
    918 005163       920 005164       922 005167       923 005173       925 005174       927 005200       928 005204
    930 005205       932 005211       933 005215       935 005216       937 005222       938 005226       940 005227
    942 005232       943 005236       945 005237       947 005243       949 005244       951 005250    9   31 005251
 9   36 005253    9   37 005255    9   38 005262    9   39 005264    9   40 005277    9   41 005301    9   42 005303
 9   44 005313    9   45 005314    9   47 005327    9   48 005331    9   49 005334    9   51 005336   10  139 005337
10  153 005341   10  154 005351   10  156 005360   10  158 005367   10  160 005370   10  161 005372   10  164 005405
10  166 005411   10  168 005413   10  172 005517   10  177 005646


                                          -----------------------------------------------------------


Historical Background

This edition of the Multics software materials and documentation is provided and donated
to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. 
as a contribution to computer science knowledge.  
This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology,
Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL
and BULL HN Information Systems Inc. to the development of this operating system. 
Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970),
renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership
of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture 
for managing computer hardware properly and for executing programs. Many subsequent operating systems 
incorporated Multics principles.
Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., 
as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. .

                                          -----------------------------------------------------------

Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without
fee is hereby granted,provided that the below copyright notice and historical background appear in all copies
and that both the copyright notice and historical background and this permission notice appear in supporting
documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining
to distribution of the programs without specific prior written permission.
    Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc.
    Copyright 2006 by BULL HN Information Systems Inc.
    Copyright 2006 by Bull SAS
    All Rights Reserved