COMPILATION LISTING OF SEGMENT cobol_pic_val_comp Compiled by: Multics PL/I Compiler, Release 31b, of April 24, 1989 Compiled at: Bull HN, Phoenix AZ, System-M Compiled on: 05/24/89 1017.6 mst Wed Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) BULL HN Information Systems Inc., 1989 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 6* * * 7* * Copyright (c) 1972 by Massachusetts Institute of * 8* * Technology and Honeywell Information Systems, Inc. * 9* * * 10* *********************************************************** */ 11 12 13 14 15 /****^ HISTORY COMMENTS: 16* 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), 17* audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): 18* MCR8060 cobol_pic_val_comp.pl1 Reformatted code to new Cobol standard. 19* END HISTORY COMMENTS */ 20 21 22 /* Modified on 04/13/778 by FCH, [3.0-1], fig con in level 88 item */ 23 /* Modified since version 3.0 */ 24 25 /* format: style3 */ 26 cobol_pic_val_comp: 27 proc (dn_ptr, veptr) returns (fixed bin); 28 29 /*This procedure compares the data attributes in the type 9 token 30* addressed by dn_ptr against the attributes of the value in the 31* initial value extension addressed by veptr*/ 32 33 34 35 status = 0; 36 37 if ^dn_ptr -> data_name.numeric 38 then do; 39 40 /*non_numeric dn*/ 41 42 if init.numeric /* [3.0-1] */ 43 then do; /*non-numeric dn, numeric value*/ 44 status = 185; 45 end; 46 47 else if init.fig_con & init.non_numeric /* [3.0-1] */ 48 then do; 49 substr (alpha.type, 6, 2) = substr (a_init.type, 6, 2); 50 /* [3.0-1] */ 51 substr (veptr -> based_char_string, 1, 9) = /* [3.0-1] */ addr (alpha) -> alpha_string; 52 /* [3.0-1] */ 53 54 status = -1; /* [3.0-1] */ 55 56 57 end; /* [3.0-1] */ 58 59 else if init.non_numeric /* [3.0-1] */ 60 /*alpha init val or ALL literal*/ 61 then if dn_ptr -> data_name.item_length < veptr -> a_init.length 62 then status = 182; 63 64 end; 65 66 else do; 67 68 if init.numeric & ^init.fig_con /* [3.0-1] */ 69 then do; 70 71 /*numeric dn, numeric lit val*/ 72 73 if dn_ptr -> data_name.places_left < veptr -> n_init.places_left 74 then do; 75 if dn_ptr -> data_name.places_left >= 0 76 then do; 77 status = 182; 78 go to retrn; 79 end; 80 end; 81 82 if dn_ptr -> data_name.places_right < veptr -> n_init.places_right 83 then do; 84 if dn_ptr -> data_name.places_right >= 0 85 then do; 86 status = 182; 87 go to retrn; 88 end; 89 end; 90 91 if veptr -> n_init.sign ^= " " 92 then do; 93 if (^dn_ptr -> data_name.bin_18 | ^dn_ptr -> data_name.bin_36 94 | ^dn_ptr -> data_name.bin_16 | ^dn_ptr -> data_name.bin_32) 95 & dn_ptr -> data_name.item_signed = "0"b 96 then do; 97 98 /* warning: pic no sign value sign */ 99 100 status = 211; 101 go to retrn; 102 end; 103 104 end; 105 106 end; 107 108 /*numeric dn, val not numeric lit*/ 109 110 else if init.fig_con /* [3.0-1] */ 111 then do; /*val is fig con*/ 112 113 if substr (veptr -> a_init.info, 2, 7) ^= "0000001"b 114 then status = 184; /*numeric item has non-numeric value*/ 115 116 /*val is fig con zero*/ 117 /*change alphanumeric initial value extension to numeric*/ 118 119 else do; /* [3.0-1] */ 120 substr (zero_ext.type, 6, 2) = substr (a_init.type, 6, 2); 121 122 substr (veptr -> based_char_string, 1, 21) = addr (zero_ext) -> zero_ext_string; 123 124 /*tell caller that token needs update to Name Table*/ 125 126 status = -1; 127 end; 128 end; 129 130 /*numeric dn, val not numeric lit or fig con zero*/ 131 132 else if init.non_numeric /* [3.0-1] */ 133 /*numeric dn, alphanumeric literal value*/ 134 then status = 184; 135 136 end; 137 138 retrn: 139 return (status); 140 141 142 143 144 145 declare dn_ptr ptr, 146 veptr ptr; /*input*/ 1 1 1 2 /* BEGIN INCLUDE FILE ... cobol_type9.incl.pl1 */ 1 3 /* Last modified on 11/19/76 by ORN */ 1 4 1 5 /* 1 6*A type 9 data name token is entered into the name table by the data 1 7*division syntax phase for each data name described in the data division. 1 8*The replacement phase subsequently replaces type 8 user word references 1 9*to data names in the procedure division minpral file with the corresponding 1 10*type 9 tokens from the name table. 1 11**/ 1 12 1 13 /* dcl dn_ptr ptr; */ 1 14 1 15 /* BEGIN DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 1 16 dcl 1 data_name based (dn_ptr), 2 1 2 2 /* begin include file ... cobol_TYPE9.incl.pl1 */ 2 3 /* Last modified on 06/19/77 by ORN */ 2 4 /* Last modified on 12/28/76 by FCH */ 2 5 2 6 /* header */ 2 7 2 size fixed bin, 2 8 2 line fixed bin, 2 9 2 column fixed bin, 2 10 2 type fixed bin, 2 11 /* body */ 2 12 2 string_ptr ptr, 2 13 2 prev_rec ptr, 2 14 2 searched bit (1), 2 15 2 duplicate bit (1), 2 16 2 saved bit (1), 2 17 2 debug_ind bit (1), 2 18 2 filler2 bit (3), 2 19 2 used_as_sub bit (1), 2 20 2 def_line fixed bin, 2 21 2 level fixed bin, 2 22 2 linkage fixed bin, 2 23 2 file_num fixed bin, 2 24 2 size_rtn fixed bin, 2 25 2 item_length fixed bin(24), 2 26 2 places_left fixed bin, 2 27 2 places_right fixed bin, 2 28 /* description */ 2 29 2 file_section bit (1), 2 30 2 working_storage bit (1), 2 31 2 constant_section bit (1), 2 32 2 linkage_section bit (1), 2 33 2 communication_section bit (1), 2 34 2 report_section bit (1), 2 35 2 level_77 bit (1), 2 36 2 level_01 bit (1), 2 37 2 non_elementary bit (1), 2 38 2 elementary bit (1), 2 39 2 filler_item bit (1), 2 40 2 s_of_rdf bit (1), 2 41 2 o_of_rdf bit (1), 2 42 2 bin_18 bit (1), 2 43 2 bin_36 bit (1), 2 44 2 pic_has_l bit (1), 2 45 2 pic_is_do bit (1), 2 46 2 numeric bit (1), 2 47 2 numeric_edited bit (1), 2 48 2 alphanum bit (1), 2 49 2 alphanum_edited bit (1), 2 50 2 alphabetic bit (1), 2 51 2 alphabetic_edited bit (1), 2 52 2 pic_has_p bit (1), 2 53 2 pic_has_ast bit (1), 2 54 2 item_signed bit(1), 2 55 2 sign_separate bit (1), 2 56 2 display bit (1), 2 57 2 comp bit (1), 2 58 2 ascii_packed_dec_h bit (1), /* as of 8/16/76 this field used for comp8. */ 2 59 2 ascii_packed_dec bit (1), 2 60 2 ebcdic_packed_dec bit (1), 2 61 2 bin_16 bit (1), 2 62 2 bin_32 bit (1), 2 63 2 usage_index bit (1), 2 64 2 just_right bit (1), 2 65 2 compare_argument bit (1), 2 66 2 sync bit (1), 2 67 2 temporary bit (1), 2 68 2 bwz bit (1), 2 69 2 variable_length bit (1), 2 70 2 subscripted bit (1), 2 71 2 occurs_do bit (1), 2 72 2 key_a bit (1), 2 73 2 key_d bit (1), 2 74 2 indexed_by bit (1), 2 75 2 value_numeric bit (1), 2 76 2 value_non_numeric bit (1), 2 77 2 value_signed bit (1), 2 78 2 sign_type bit (3), 2 79 2 pic_integer bit (1), 2 80 2 ast_when_zero bit (1), 2 81 2 label_record bit (1), 2 82 2 sign_clause_occurred bit (1), 2 83 2 okey_dn bit (1), 2 84 2 subject_of_keyis bit (1), 2 85 2 exp_redefining bit (1), 2 86 2 sync_in_rec bit (1), 2 87 2 rounded bit (1), 2 88 2 ad_bit bit (1), 2 89 2 debug_all bit (1), 2 90 2 overlap bit (1), 2 91 2 sum_counter bit (1), 2 92 2 exp_occurs bit (1), 2 93 2 linage_counter bit (1), 2 94 2 rnm_01 bit (1), 2 95 2 aligned bit (1), 2 96 2 not_user_writable bit (1), 2 97 2 database_key bit (1), 2 98 2 database_data_item bit (1), 2 99 2 seg_num fixed bin, 2 100 2 offset fixed bin(24), 2 101 2 initial_ptr fixed bin, 2 102 2 edit_ptr fixed bin, 2 103 2 occurs_ptr fixed bin, 2 104 2 do_rec char(5), 2 105 2 bitt bit (1), 2 106 2 byte bit (1), 2 107 2 half_word bit (1), 2 108 2 word bit (1), 2 109 2 double_word bit (1), 2 110 2 half_byte bit (1), 2 111 2 filler5 bit (1), 2 112 2 bit_offset bit (4), 2 113 2 son_cnt bit (16), 2 114 2 max_red_size fixed bin(24), 2 115 2 name_size fixed bin, 2 116 2 name char(0 refer(data_name.name_size)); 2 117 2 118 2 119 2 120 /* end include file ... cobol_TYPE9.incl.pl1 */ 2 121 1 17 1 18 /* END DECLARATION OF TYPE9 (DATA NAME) TOKEN */ 1 19 1 20 /* END INCLUDE FILE ... cobol_type9.incl.pl1 */ 1 21 147 148 149 150 151 152 declare 1 init based (veptr), /* [3.0-1] */ 153 2 numeric bit (1), /* [3.0-1] */ 154 2 non_numeric bit (1), /* [3.0-1] */ 155 2 fig_con bit (1), /* [3.0-1] */ 156 2 all_lit bit (1), /* [3.0-1] */ 157 2 single bit (1), /* [3.0-1] */ 158 2 thru1 bit (1), /* [3.0-1] */ 159 2 thru2 bit (1), /* [3.0-1] */ 160 2 filler bit (1); /* [3.0-1] */ 161 162 declare 1 a_init based (veptr), 163 2 type bit (8), 164 2 info bit (8), 165 2 length fixed bin, 166 2 string char (0 refer (a_init.length)); 167 168 declare 1 n_init based (veptr), 169 2 type bit (8), 170 2 info bit (8), 171 2 sign char (1), 172 2 expsign char (1), 173 2 explaces fixed bin, 174 2 places_left fixed bin, 175 2 places_right fixed bin, 176 2 places fixed bin, 177 2 string char (0 refer (n_init.places)); 178 179 declare based_char_string char (1000) based; 180 declare zero_ext_constant fixed bin internal static init (21); 181 182 declare zero_ext_string char (21) based; 183 declare alpha_string char (9) based; /* [3.0-1] */ 184 185 declare 1 zero_ext internal static, 186 2 type bit (8) init ("10000000"b), 187 2 info bit (8) init ("00000000"b), 188 2 sign char (1) init (" "), 189 2 expsign char (1) init (" "), 190 2 explaces fixed bin init (0), 191 2 places_left fixed bin init (1), 192 2 places_right fixed bin init (0), 193 2 places fixed bin init (1), 194 2 string char (1) init ("0"); 195 196 declare 1 alpha static internal, /* [3.0-1] */ 197 2 type bit (8) init ("0"b), /* [3.0-1] */ 198 2 info bit (8) init ("0"b), /* [3.0-1] */ 199 2 length fixed bin init (1), /* [3.0-1] */ 200 2 string char (1) init ("0"); /* [3.0-1] */ 201 202 declare tempbin fixed bin; 203 declare status fixed bin; /*output: zero or diagnostic number*/ 204 declare addr builtin; 205 declare substr builtin; 206 207 end cobol_pic_val_comp; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 05/24/89 0835.8 cobol_pic_val_comp.pl1 >spec>install>MR12.3-1048>cobol_pic_val_comp.pl1 147 1 03/27/82 0439.9 cobol_type9.incl.pl1 >ldd>include>cobol_type9.incl.pl1 1-17 2 11/11/82 1712.7 cobol_TYPE9.incl.pl1 >ldd>include>cobol_TYPE9.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. a_init based structure level 1 unaligned dcl 162 addr builtin function dcl 204 ref 51 122 alpha 000016 internal static structure level 1 unaligned dcl 196 set ref 51 alpha_string based char(9) packed unaligned dcl 183 ref 51 based_char_string based char(1000) packed unaligned dcl 179 set ref 51* 122* bin_16 21(32) based bit(1) level 2 packed packed unaligned dcl 1-16 ref 93 bin_18 21(13) based bit(1) level 2 packed packed unaligned dcl 1-16 ref 93 bin_32 21(33) based bit(1) level 2 packed packed unaligned dcl 1-16 ref 93 bin_36 21(14) based bit(1) level 2 packed packed unaligned dcl 1-16 ref 93 data_name based structure level 1 unaligned dcl 1-16 dn_ptr parameter pointer dcl 145 ref 26 37 59 73 75 82 84 93 93 93 93 93 fig_con 0(02) based bit(1) level 2 packed packed unaligned dcl 152 ref 47 68 110 info 0(08) based bit(8) level 2 packed packed unaligned dcl 162 ref 113 init based structure level 1 packed packed unaligned dcl 152 item_length 16 based fixed bin(24,0) level 2 dcl 1-16 ref 59 item_signed 21(25) based bit(1) level 2 packed packed unaligned dcl 1-16 ref 93 length 1 based fixed bin(17,0) level 2 dcl 162 ref 59 n_init based structure level 1 unaligned dcl 168 non_numeric 0(01) based bit(1) level 2 packed packed unaligned dcl 152 ref 47 59 132 numeric 21(17) based bit(1) level 2 in structure "data_name" packed packed unaligned dcl 1-16 in procedure "cobol_pic_val_comp" ref 37 numeric based bit(1) level 2 in structure "init" packed packed unaligned dcl 152 in procedure "cobol_pic_val_comp" ref 42 68 places_left 17 based fixed bin(17,0) level 2 in structure "data_name" dcl 1-16 in procedure "cobol_pic_val_comp" ref 73 75 places_left 2 based fixed bin(17,0) level 2 in structure "n_init" dcl 168 in procedure "cobol_pic_val_comp" ref 73 places_right 20 based fixed bin(17,0) level 2 in structure "data_name" dcl 1-16 in procedure "cobol_pic_val_comp" ref 82 84 places_right 3 based fixed bin(17,0) level 2 in structure "n_init" dcl 168 in procedure "cobol_pic_val_comp" ref 82 sign 0(18) based char(1) level 2 packed packed unaligned dcl 168 ref 91 status 000100 automatic fixed bin(17,0) dcl 203 set ref 35* 44* 54* 59* 77* 86* 100* 113* 126* 132* 138 substr builtin function dcl 205 set ref 49* 49 51* 113 120* 120 122* type based bit(8) level 2 in structure "a_init" packed packed unaligned dcl 162 in procedure "cobol_pic_val_comp" ref 49 120 type 000010 internal static bit(8) initial level 2 in structure "zero_ext" packed packed unaligned dcl 185 in procedure "cobol_pic_val_comp" set ref 120* type 000016 internal static bit(8) initial level 2 in structure "alpha" packed packed unaligned dcl 196 in procedure "cobol_pic_val_comp" set ref 49* veptr parameter pointer dcl 145 ref 26 42 47 47 49 51 59 59 68 68 73 82 91 110 113 120 122 132 zero_ext 000010 internal static structure level 1 unaligned dcl 185 set ref 122 zero_ext_string based char(21) packed unaligned dcl 182 ref 122 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. tempbin automatic fixed bin(17,0) dcl 202 zero_ext_constant internal static fixed bin(17,0) initial dcl 180 NAMES DECLARED BY EXPLICIT CONTEXT. cobol_pic_val_comp 000006 constant entry external dcl 26 retrn 000173 constant label dcl 138 ref 78 87 101 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 226 250 200 236 Length 450 200 22 164 26 12 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME cobol_pic_val_comp 66 external procedure is an external procedure. STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 zero_ext cobol_pic_val_comp 000016 alpha cobol_pic_val_comp STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME cobol_pic_val_comp 000100 status cobol_pic_val_comp THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. return_mac ext_entry NO EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. NO EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 26 000002 35 000013 37 000014 42 000022 44 000030 45 000032 47 000033 49 000044 51 000050 54 000053 57 000055 59 000056 64 000065 68 000066 73 000101 75 000104 77 000106 78 000110 82 000111 84 000114 86 000116 87 000120 91 000121 93 000126 100 000135 101 000137 106 000140 110 000141 113 000143 120 000153 122 000157 126 000162 128 000164 132 000165 138 000173 ----------------------------------------------------------- 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