COMPILATION LISTING OF SEGMENT valid_decimal_ Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Multics Op. - System M Compiled on: 11/11/86 0930.8 mst Tue Options: optimize map 1 /* ****************************************************** 2* * * 3* * * 4* * Copyright (c) 1972 by Massachusetts Institute of * 5* * Technology and Honeywell Information Systems, Inc. * 6* * * 7* * * 8* ****************************************************** */ 9 10 valid_decimal_: proc (P_dtype, P_dptr, P_prec) returns (bit (1)); 11 12 /* My contract: you give me the true dtype and precision of decimal data, and its address 13* I will return true if the data is completly valid for EIS use 14* 15* design and code by JRDavis Aug 78 16* modified 12 Apr 79 to do 4bit decimal right, and use data_type_info_ 17* modified 31 Jan 84 by R. Gray to support generic types 18* 19**/ 20 21 dcl (P_dtype fixed bin, /* data type of data */ 22 P_dptr ptr, /* to data to test */ 23 P_prec fixed bin) parameter; /* declared precision of data */ 24 25 dcl prec fixed bin init (P_prec), /* copy arg for efficiency */ 26 dtype fixed bin init (P_dtype), /* ditto */ 27 dptr ptr init (P_dptr), /* likewise */ 28 sign_index fixed bin, /* which char is sign char */ 29 digit_index, /* which is first of digits */ 30 imag_index fixed bin, /* where imag component begins */ 31 data_char char (122) based (dptr), /* overlay for data */ 32 (YES init ("1"b), NO init ("0"b)) bit (1) static options (constant); 33 34 dcl 1 atr aligned like data_type_info_$info based (atrp); /* the atributes of our data type */ 35 dcl atrp ptr; 36 37 dcl (abs, addr, lbound, hbound, substr, verify, index) builtin; 38 39 dcl validate_4bit_decimal_$sign entry (ptr, fixed bin) returns (bit (1) aligned), 40 validate_4bit_decimal_$digits entry (ptr, fixed bin, fixed bin) returns (bit (1) aligned); 41 42 43 44 if prec < 0 | prec > data_type_info_$max_decimal_precision then return (NO); 45 if dtype < 1 | dtype > hbound (data_type_info_$info, 1) then return (NO); 46 47 atrp = addr (data_type_info_$info (dtype)); /* set up atr for convenience */ 48 49 if ^atr.computational | ^atr.arithmetic | ^atr.decimal /* not dec? yechh */ 50 then return (NO); 51 52 if atr.packed_dec /* 4bit decimal */ 53 then do; 54 if atr.signed 55 then do; 56 if atr.trailing_sign 57 then do; 58 sign_index = prec; /* is offset, not index per se */ 59 digit_index = 0; 60 end; 61 else do; /* leading sign, more familiar */ 62 sign_index = 0; 63 digit_index = 1; 64 end; 65 66 if ^validate_4bit_decimal_$sign (dptr, sign_index) then return (NO); 67 end; /* signed */ 68 else digit_index = 0; 69 70 if ^validate_4bit_decimal_$digits (dptr, digit_index, prec) then return (NO); 71 72 if atr.complex then do; 73 imag_index = prec + 1; 74 if ^atr.fixed 75 then imag_index = imag_index + 2; /* for exponent */ 76 if ^atr.digit_aligned /* is byte aligned, may need pad */ 77 then if mod (imag_index, 2) = 1 78 then imag_index = imag_index + 1; 79 80 if atr.overpunched 81 then return (NO); /* how did you get past the door? */ 82 else if ^validate_4bit_decimal_$sign (dptr, imag_index + sign_index) then return (NO); 83 84 if ^validate_4bit_decimal_$digits (dptr, imag_index + digit_index, prec) then return (NO); 85 end; /* testing imag part */ 86 87 88 return (YES); 89 end; /* packed dec testing */ 90 91 else do; /* 9bit decimal */ 92 93 if atr.signed 94 then do; 95 if atr.overpunched 96 then do; 97 if atr.trailing_sign 98 then do; 99 sign_index = prec; 100 digit_index = 1; 101 end; 102 else do; 103 sign_index = 1; 104 digit_index = 2; 105 end; 106 107 if ^nine_bit_overpunched_sign_ok (substr (data_char, sign_index, 1)) then return (NO); 108 if ^nine_bit_digit_ok (substr (data_char, digit_index, prec - 1)) then return (NO); 109 110 if atr.complex /* no idea how to validate this */ 111 then return (NO); 112 return (YES); 113 end; /* overpunched */ 114 else do; /* regular signed 9 bit */ 115 if atr.generic 116 then do; 117 sign_index = 5; 118 digit_index = 6; 119 end; 120 else if atr.trailing_sign 121 then do; 122 sign_index = prec + 1; 123 digit_index = 1; 124 end; 125 else do; 126 sign_index = 1; 127 digit_index = 2; 128 end; 129 130 if ^nine_bit_sign_ok (substr (data_char, sign_index, 1)) then return (NO); 131 end; /* non-overpunched signed 9bit */ 132 end; /* signed */ 133 else digit_index = 1; /* unsigned */ 134 135 if ^nine_bit_digit_ok (substr (data_char, digit_index, prec)) then return (NO); 136 137 if atr.complex then do; 138 imag_index = prec + 1; 139 if atr.generic then imag_index = 4 * ceil(imag_index/4e0) +4; /* skip exponent word align */ 140 if ^atr.fixed then imag_index = imag_index + 1; /* skip exponent */ 141 if ^nine_bit_sign_ok (substr (data_char, imag_index + sign_index, 1)) then return (NO); 142 143 if ^nine_bit_digit_ok (substr (data_char, imag_index + digit_index, prec)) then return (NO); 144 end; /* checking imag part */ 145 146 return (YES); 147 end; /* 9 bit decimal */ 148 149 return (NO); /* should never get here */ 150 151 152 nine_bit_sign_ok: proc (ch) returns (bit (1)); 153 dcl ch char (1); 154 return (index (data_type_info_$ninebit_sign_chars, ch) ^= 0); /* sign must be one of these */ 155 end nine_bit_sign_ok; 156 157 nine_bit_digit_ok: proc (chs) returns (bit (1)); 158 dcl chs char (*); 159 return (verify (chs, data_type_info_$ninebit_digit_chars) = 0); /* must all be valid digits */ 160 end nine_bit_digit_ok; 161 162 nine_bit_overpunched_sign_ok: proc (ch) returns (bit (1)); 163 dcl ch char (1); 164 return (index (data_type_info_$ninebit_overpunched_sign_chars, ch) ^= 0); 165 end nine_bit_overpunched_sign_ok; 1 1 /* BEGIN INCLUDE FILE ... data_type_info_.incl.pl1 1 2* 1 3* attributes of each Multics data type. You may not rely on the dimension never exceeding 64 1 4* James R. Davis 6 Apr 79 1 5* Modified JMAthane June 83 to add "type" bit field 1 6* Upped bound from 64 to 80 10/18/83 S. Herbst 1 7* Added "hex" and "generic" bits 01/23/84 S. Herbst 1 8* Upped bound from 80 to 86 01/81/84 R. Gray 1 9* Upper bound from 86 to 87 JMAthane (for Pascal strings type dtype) 1 10**/ 1 11 1 12 1 13 1 14 /****^ HISTORY COMMENTS: 1 15* 1) change(86-09-05,JMAthane), approve(86-09-05,MCR7525), 1 16* audit(86-09-11,Martinson), install(86-11-10,MR12.0-1208): 1 17* The data_type_info array now has 87 entries instead of 86 due to 1 18* introduction of pascal_string_type_dtype. 1 19* END HISTORY COMMENTS */ 1 20 1 21 1 22 dcl data_type_info_$version_number fixed bin external static; 1 23 dcl data_type_info_this_version fixed bin internal static options (constant) init (1); 1 24 1 25 dcl 1 data_type_info_$info (87) aligned external static, 1 26 2 computational bit (1) unal, 1 27 2 arithmetic bit (1) unal, 1 28 2 arithmetic_attributes unal, /* only valid if arithmetic */ 1 29 3 fixed bit (1) unal, /* PL/I type */ 1 30 3 complex bit (1) unal, /* PL/I mode */ 1 31 3 decimal bit (1) unal, /* PL/I base */ 1 32 3 signed bit (1) unal, 1 33 3 trailing_sign bit (1) unal, /* only valid if signed */ 1 34 3 decimal_attributes unal, /* only valid if decimal */ 1 35 4 packed_dec bit (1) unal, /* 4 bits per digit or 9 */ 1 36 4 digit_aligned bit (1) unal, /* valid for packed_dec only */ 1 37 4 overpunched bit (1) unal, 1 38 2 char_string bit (1) unal, /* valid for non-arithmetic */ 1 39 2 bit_string bit (1) unal, /* valid for non-arithmetic */ 1 40 2 varying bit (1) unal, /* for bit or char only */ 1 41 2 type bit (1) unal, /* this symbol is a type */ 1 42 2 hex bit (1) unal, /* a hexadecimal type (eg., hex floating point) */ 1 43 2 generic bit (1) unal, /* eg., real_flt_dec_generic_dtype */ 1 44 2 pad bit (20) unal; 1 45 1 46 dcl data_type_info_$ninebit_sign_chars char (2) external static; 1 47 dcl data_type_info_$ninebit_digit_chars char (10) external static; 1 48 dcl data_type_info_$ninebit_overpunched_sign_chars char (22) external static; 1 49 1 50 dcl data_type_info_$max_decimal_precision fixed bin external static; 1 51 dcl data_type_info_$max_float_binary_precision fixed bin external static; 1 52 dcl data_type_info_$max_fixed_binary_precision fixed bin external static; 1 53 1 54 1 55 /* END INCLUDE FILE ... data_type_info_.incl.pl1 */ 166 167 168 end /* valid_decimal_ */; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/11/86 0909.7 valid_decimal_.pl1 >spec>install>1208>valid_decimal_.pl1 166 1 11/10/86 0953.4 data_type_info_.incl.pl1 >spec>install>1208>data_type_info_.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. NO constant bit(1) initial unaligned dcl 25 ref 44 45 49 66 70 80 82 84 107 108 110 130 135 141 143 149 P_dptr parameter pointer dcl 21 ref 10 25 P_dtype parameter fixed bin(17,0) dcl 21 ref 10 25 P_prec parameter fixed bin(17,0) dcl 21 ref 10 25 YES constant bit(1) initial unaligned dcl 25 ref 88 112 146 addr builtin function dcl 37 ref 47 arithmetic 0(01) based bit(1) level 2 packed unaligned dcl 34 ref 49 arithmetic_attributes 0(02) based structure level 2 packed unaligned dcl 34 atr based structure level 1 dcl 34 atrp 000110 automatic pointer dcl 35 set ref 47* 49 49 49 52 54 56 72 74 76 80 93 95 97 110 115 120 137 139 140 ch parameter char(1) unaligned dcl 163 in procedure "nine_bit_overpunched_sign_ok" ref 162 164 ch parameter char(1) unaligned dcl 153 in procedure "nine_bit_sign_ok" ref 152 154 chs parameter char unaligned dcl 158 ref 157 159 complex 0(03) based bit(1) level 3 packed unaligned dcl 34 ref 72 110 137 computational based bit(1) level 2 packed unaligned dcl 34 ref 49 data_char based char(122) unaligned dcl 25 ref 107 107 108 108 130 130 135 135 141 141 143 143 data_type_info_$info 000014 external static structure array level 1 dcl 1-25 set ref 45 47 data_type_info_$max_decimal_precision 000024 external static fixed bin(17,0) dcl 1-50 ref 44 data_type_info_$ninebit_digit_chars 000020 external static char(10) unaligned dcl 1-47 ref 159 data_type_info_$ninebit_overpunched_sign_chars 000022 external static char(22) unaligned dcl 1-48 ref 164 data_type_info_$ninebit_sign_chars 000016 external static char(2) unaligned dcl 1-46 ref 154 decimal 0(04) based bit(1) level 3 packed unaligned dcl 34 ref 49 decimal_attributes 0(07) based structure level 3 packed unaligned dcl 34 digit_aligned 0(08) based bit(1) level 4 packed unaligned dcl 34 ref 76 digit_index 000105 automatic fixed bin(17,0) dcl 25 set ref 59* 63* 68* 70* 84 100* 104* 108 108 118* 123* 127* 133* 135 135 143 143 dptr 000102 automatic pointer initial dcl 25 set ref 25* 66* 70* 82* 84* 107 107 108 108 130 130 135 135 141 141 143 143 dtype 000101 automatic fixed bin(17,0) initial dcl 25 set ref 25* 45 45 47 fixed 0(02) based bit(1) level 3 packed unaligned dcl 34 ref 74 140 generic 0(15) based bit(1) level 2 packed unaligned dcl 34 ref 115 139 hbound builtin function dcl 37 ref 45 imag_index 000106 automatic fixed bin(17,0) dcl 25 set ref 73* 74* 74 76 76* 76 82 84 138* 139* 139 140* 140 141 141 143 143 index builtin function dcl 37 ref 154 164 overpunched 0(09) based bit(1) level 4 packed unaligned dcl 34 ref 80 95 packed_dec 0(07) based bit(1) level 4 packed unaligned dcl 34 ref 52 prec 000100 automatic fixed bin(17,0) initial dcl 25 set ref 25* 44 44 58 70* 73 84* 99 108 108 122 135 135 138 143 143 sign_index 000104 automatic fixed bin(17,0) dcl 25 set ref 58* 62* 66* 82 99* 103* 107 107 117* 122* 126* 130 130 141 141 signed 0(05) based bit(1) level 3 packed unaligned dcl 34 ref 54 93 substr builtin function dcl 37 ref 107 107 108 108 130 130 135 135 141 141 143 143 trailing_sign 0(06) based bit(1) level 3 packed unaligned dcl 34 ref 56 97 120 validate_4bit_decimal_$digits 000012 constant entry external dcl 39 ref 70 84 validate_4bit_decimal_$sign 000010 constant entry external dcl 39 ref 66 82 verify builtin function dcl 37 ref 159 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. abs builtin function dcl 37 data_type_info_$max_fixed_binary_precision external static fixed bin(17,0) dcl 1-52 data_type_info_$max_float_binary_precision external static fixed bin(17,0) dcl 1-51 data_type_info_$version_number external static fixed bin(17,0) dcl 1-22 data_type_info_this_version internal static fixed bin(17,0) initial dcl 1-23 lbound builtin function dcl 37 NAMES DECLARED BY EXPLICIT CONTEXT. nine_bit_digit_ok 000676 constant entry internal dcl 157 ref 108 135 143 nine_bit_overpunched_sign_ok 000725 constant entry internal dcl 162 ref 107 nine_bit_sign_ok 000651 constant entry internal dcl 152 ref 130 141 valid_decimal_ 000014 constant entry external dcl 10 NAMES DECLARED BY CONTEXT OR IMPLICATION. ceil builtin function ref 139 mod builtin function ref 76 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1130 1156 775 1140 Length 1356 775 26 163 132 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME valid_decimal_ 124 external procedure is an external procedure. nine_bit_sign_ok internal procedure shares stack frame of external procedure valid_decimal_. nine_bit_digit_ok 66 internal procedure is called during a stack extension. nine_bit_overpunched_sign_ok internal procedure shares stack frame of external procedure valid_decimal_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME valid_decimal_ 000100 prec valid_decimal_ 000101 dtype valid_decimal_ 000102 dptr valid_decimal_ 000104 sign_index valid_decimal_ 000105 digit_index valid_decimal_ 000106 imag_index valid_decimal_ 000110 atrp valid_decimal_ THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. fx1_to_fl2 r_e_as r_ne_as alloc_char_temp call_ext_out call_int_this_desc return_mac fl2_to_fx1 mdfx1 ext_entry int_entry_desc ceil_fl verify_eis THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. validate_4bit_decimal_$digits validate_4bit_decimal_$sign THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. data_type_info_$info data_type_info_$max_decimal_precision data_type_info_$ninebit_digit_chars data_type_info_$ninebit_overpunched_sign_chars data_type_info_$ninebit_sign_chars LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 10 000007 25 000021 44 000031 45 000042 47 000054 49 000057 52 000070 54 000073 56 000076 58 000101 59 000103 60 000104 62 000105 63 000106 66 000110 67 000133 68 000134 70 000135 72 000163 73 000166 74 000171 76 000176 80 000207 82 000220 84 000247 88 000300 93 000306 95 000311 97 000314 99 000317 100 000321 101 000323 103 000324 104 000326 107 000330 108 000350 110 000410 112 000421 115 000427 117 000432 118 000434 119 000436 120 000437 122 000442 123 000445 124 000447 126 000450 127 000452 130 000454 132 000474 133 000475 135 000477 137 000535 138 000540 139 000543 140 000555 141 000561 143 000603 146 000643 152 000651 154 000653 157 000675 159 000711 162 000725 164 000727 ----------------------------------------------------------- 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