COMPILATION LISTING OF SEGMENT picture Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Multics Op. - System M Compiled on: 10/22/86 1526.3 mst Wed Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1981 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* *********************************************************** */ 9 10 11 12 13 14 /****^ HISTORY COMMENTS: 15* 1) change(86-10-20,TLNguyen), approve(86-10-20,MCR7560), 16* audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1195): 17* Correct an usage message. 18* END HISTORY COMMENTS */ 19 20 21 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16 */ 22 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo */ 23 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend */ 24 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt */ 25 26 /* Created: Mar 78 J Falksen */ 27 /* Updated: Aug 78 J Falksen */ 28 /* added conversion handler */ 29 /* fixed error message */ 30 /* added valid_pictured_data entry */ 31 /* removed quotes from command output */ 32 /* made command use NL separator when multiple output values */ 33 /* Updated: Aug 80 J Falksen */ 34 /* cleanup for installation and format_pl1 */ 35 /* Updated: Oct. 86 Tai L. Nguyen */ 36 /* corrected an usage message */ 37 38 /* Syntax: pic pic_string values {-control_arg} */ 39 /* */ 40 /* Function: returns one or more values processed through a specified */ 41 /* PL/I picture. */ 42 /* */ 43 /* Arguments: */ 44 /* pic_string */ 45 /* is a valid PL/I picture as defined in the PL/I Reference Manual and */ 46 /* the PL/I Language Specification. */ 47 /* values */ 48 /* are strings having data appropriate for editing into the picture. */ 49 /* Each value must be convertible to the type implied by the picture */ 50 /* specified. If multiple values are presented, the results are */ 51 /* separated by single spaces. Any resulting value that contains a */ 52 /* space is quoted. */ 53 /* */ 54 /* Control argument: */ 55 /* -strip */ 56 /* removes leading spaces from edited picture values; removes trailing */ 57 /* zeros following a decimal point; removes a decimal point if it would */ 58 /* have been the last character of a returned value. */ 59 /* */ 60 /* */ 61 /* Syntax as active function: [pic pic_string values {-control_arg}] */ 62 63 /* Syntax: [vpd pic_string values] */ 64 /* */ 65 /* Function: Returns "true" if all values can be formatted via pic_string. */ 66 /* Otherwise returns "false". */ 67 /* */ 68 /* */ 69 /* Arguments: */ 70 /* pic_string */ 71 /* is a valid PL/I picture. */ 72 /* value */ 73 /* is a string to be edited into the picture. */ 74 /* */ 75 /* */ 76 /* Notes: For more information on PL/I picture and picture strings, see */ 77 /* the PL/I Reference Manual, Order No. AM83 or the PL/I Language */ 78 /* Specification, Order No. AG94. */ 79 80 pic: picture: proc; /* edit a value into a picture */ 81 82 testing = "0"b; 83 me = "picture"; 84 goto start; 85 86 valid_pictured_data: vpd: entry; /* see if value will edit into pic */ 87 88 testing = "1"b; 89 me = "valid_pictured_data"; 90 goto start; 91 92 start: 93 strip_sw = "0"b; /* dont strip leading/trailing */ 94 call cu_$af_arg_count (argct, code); 95 if (code ^= 0) /* called as command? */ 96 then do; /* ...YES */ 97 retval_p = null (); /* no return string */ 98 error = com_err_; /* set error message routine */ 99 arg_ptr = cu_$arg_ptr; 100 end; 101 else do; /* ...NO */ 102 call cu_$af_return_arg (argct, retval_p, retval_l, code); 103 /* get return string */ 104 retval = ""; 105 error = active_fnc_err_; /* set error message routine */ 106 arg_ptr = cu_$af_arg_ptr; 107 end; 108 if (argct < 2) 109 then do; /* tsk, tsk */ 110 if (me = "picture") 111 then call error (error_table_$noarg, me, 112 "Usage:^-pic pic_str {-strip} value ..."); 113 else call error (error_table_$noarg, me, 114 "Usage:^-vpd pic_str value ..."); 115 return; 116 end; 117 call arg_ptr (1, argp, argl, code); /* get the picture string */ 118 if (argl = 0) /* he wants the default */ 119 then do; 120 the_picture = default; 121 picp = addr (default); 122 picl = length (default); /* which include NO extraneous */ 123 strip_sw = "1"b; /* spaces or blanks */ 124 dcl default char (13) int static options (constant) 125 init ("(15)-9v.(15)9"); 126 end; 127 else do; /* use his picture (SMILE!) */ 128 the_picture = arg; 129 picp = argp; 130 picl = argl; 131 end; 132 133 call picture_info_ ((picv), addr (buff), code); 134 /* let PL/I routine process it */ 135 if (code ^= 0) /* Oh, */ 136 then do; /* ...you didnt like that one! */ 137 call error (0, me, 138 "^[Normalized picture > 64 char" || 139 "^;Scale factor not in range -128:+127" || 140 "^;Syntax error^]. ^a", 141 sign (code - 434) + 2, /* That's right, they return a FUNNY */ 142 the_picture); /* code! */ 143 return; 144 end; 145 do argno = 2 to argct while (^strip_sw); 146 call arg_ptr (argno, argp, argl, code); 147 if (arg = "-strip") 148 then strip_sw = "1"b; 149 end; 150 151 on condition (conversion) /* just in case he blows it */ 152 begin; 153 Cond = "Conversion"; 154 goto err_exit; 155 end; 156 on condition (size) /* just in case he blows it */ 157 begin; 158 Cond = "Size"; 159 goto err_exit; 160 end; 161 do argno = 2 to argct; 162 call arg_ptr (argno, argp, argl, code); 163 if (arg ^= "-strip") 164 then do; 165 166 /* let somebody do it who UNDERSTANDS all these things */ 167 temp_length = addr (buff) -> picture_image.prec 168 + 262144 * (addr (buff) -> picture_image.scale 169 - addr (buff) -> picture_image.scalefactor); 170 171 call assign_ (addr (temp), 172 map_type (addr (buff) -> picture_image.type), 173 temp_length, argp, 42, (argl)); 174 call pack_picture_ (addr (target) -> bit1, buff, temp); 175 176 if ^testing /* not valid_pictured_data */ 177 then do; 178 pictured 179 = substr (target, 1, addr (buff) -> picture_image.varlength); 180 if strip_sw /* should we dump the extras? */ 181 then do; 182 pictured = ltrim (pictured); 183 if (index (pictured, ".") ^= 0) 184 then do; 185 pictured = rtrim (pictured, "0"); 186 if (substr (pictured, length (pictured), 1) = ".") 187 then pictured 188 = substr (pictured, 1, length (pictured) - 1); 189 end; 190 end; 191 if (retval_p = null ()) 192 then call ioa_ ("^a", pictured); 193 else do; 194 j = index (pictured, " "); 195 if (length (retval) > 0) 196 then retval = retval || " "; 197 if (j > 0) 198 then retval = retval || """"; 199 retval = retval || pictured; 200 if (j > 0) 201 then retval = retval || """"; 202 end; 203 end; 204 end; 205 end; 206 if testing 207 then do; 208 if (retval_p = null ()) /* command? */ 209 then call ioa_ ("true"); /* yes. print it */ 210 else retval = "true"; /* no. return it */ 211 end; 212 213 return; 214 215 err_exit: 216 if testing 217 then do; 218 if (retval_p = null ()) /* command? */ 219 then call ioa_ ("false"); /* yes. print it */ 220 else retval = "false"; /* no. return it */ 221 end; 222 else call error (0, me, 223 "^a condition occurred while editing ""^a"" thru ""^a""", 224 Cond, arg, the_picture); 225 return; 226 227 dcl active_fnc_err_ entry options (variable); 228 dcl arg char (argl) based (argp); 229 dcl argct fixed bin; 230 dcl argl fixed bin (21); 231 dcl argno fixed bin; 232 dcl argp ptr; 233 dcl assign_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, 234 fixed bin (35)); 235 dcl bit1 bit (1) unaligned based; 236 dcl buff (20) fixed binary; 237 dcl code fixed bin (35); 238 dcl Cond char (12); 239 dcl com_err_ entry options (variable); 240 dcl conversion condition; 241 dcl cu_$af_arg_count entry (fixed bin, fixed bin (35)); 242 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); 243 dcl arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) 244 automatic; 245 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); 246 dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); 247 dcl error entry options (variable) automatic; 248 dcl error_table_$noarg fixed bin (35) ext static; 249 dcl ioa_ entry options (variable); 250 dcl j fixed bin; 251 dcl me char (32); 252 dcl pack_picture_ options (variable); 253 dcl picl fixed bin; 254 dcl picp ptr; 255 dcl picture_info_ entry (char (*) aligned, ptr, fixed bin (35)); 256 dcl pictured char (256) var; 257 dcl picv char (picl) based (picp); 258 dcl retval char (retval_l) var based (retval_p); 259 dcl retval_l fixed bin (21); 260 dcl retval_p ptr; 261 dcl size condition; 262 dcl strip_sw bit (1); 263 dcl target char (128); 264 dcl temp (128) char (1) unaligned; 265 dcl temp_length fixed bin (35); 266 dcl testing bit (1); 267 dcl the_picture char (100) var; 268 269 dcl (addr, index, length, ltrim, null, rtrim, sign, substr) builtin; 270 1 1 /* BEGIN INCLUDE FILE ... picture_image.incl.pl1 1 2* 1 3* James R. Davis 12 Mar 79 1 4**/ 1 5 1 6 dcl 1 picture_image aligned based, 1 7 2 type fixed bin (8) unal, 1 8 2 prec fixed bin (8) unal, /* precision or length of associated value */ 1 9 2 scale fixed bin (8) unal, /* for both fixed and float pictures, 1 10* =ndigits after "v" - scale_factor */ 1 11 2 piclength fixed bin (8) unal, /* length of picture_constant.chars, <64 1 12* =length of normalized-picture-string */ 1 13 2 varlength fixed bin (8) unal, /* length of pictured variable in chars, <64 1 14* =length of normalized_picture_string - "k" and "v" */ 1 15 2 scalefactor fixed bin (8) unal, /* value of pict-sc-f, -256<=x<256 */ 1 16 2 explength fixed bin (8) unal, /* length of exp field for float */ 1 17 2 drift_character char (1) unal, 1 18 2 chars char (0 refer (picture_image.piclength)) aligned; 1 19 1 20 dcl ( 1 21 picture_char_type init (24), 1 22 picture_realfix_type init (25), 1 23 picture_complexfix_type 1 24 init (26), 1 25 picture_realflo_type init (27), 1 26 picture_complexflo_type 1 27 init (28) 1 28 ) fixed bin (8) unal static internal options (constant); 1 29 1 30 /* END INCLUDE FILE ... picture_image.incl.pl1 */ 271 272 dcl map_type (24:28) fixed bin int static init ( 273 42, /* character */ 274 18, /* real fixed dec */ 275 22, /* cplx fixed dec */ 276 20, /* real float dec */ 277 24); /* cplx float dec */ 278 end picture; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/22/86 1526.3 picture.pl1 >spec>install>1195>picture.pl1 271 1 06/28/79 1204.8 picture_image.incl.pl1 >ldd>include>picture_image.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. Cond 000133 automatic char(12) unaligned dcl 238 set ref 153* 158* 222* active_fnc_err_ 000016 constant entry external dcl 227 ref 105 addr builtin function dcl 269 ref 121 133 133 167 167 167 171 171 171 174 178 arg based char unaligned dcl 228 set ref 128 147 163 222* arg_ptr 000144 automatic entry variable dcl 243 set ref 99* 106* 117 146 162 argct 000100 automatic fixed bin(17,0) dcl 229 set ref 94* 102* 108 145 161 argl 000101 automatic fixed bin(21,0) dcl 230 set ref 117* 118 128 130 146* 147 162* 163 171 222 222 argno 000102 automatic fixed bin(17,0) dcl 231 set ref 145* 146* 161* 162* argp 000104 automatic pointer dcl 232 set ref 117* 128 129 146* 147 162* 163 171* 222 assign_ 000020 constant entry external dcl 233 ref 171 bit1 based bit(1) unaligned dcl 235 set ref 174* buff 000106 automatic fixed bin(17,0) array dcl 236 set ref 133 133 167 167 167 171 174* 178 code 000132 automatic fixed bin(35,0) dcl 237 set ref 94* 95 102* 117* 133* 135 137 146* 162* com_err_ 000022 constant entry external dcl 239 ref 98 conversion 000136 stack reference condition dcl 240 ref 151 cu_$af_arg_count 000024 constant entry external dcl 241 ref 94 cu_$af_arg_ptr 000032 constant entry external dcl 246 ref 106 cu_$af_return_arg 000026 constant entry external dcl 242 ref 102 cu_$arg_ptr 000030 constant entry external dcl 245 ref 99 default 000000 constant char(13) initial unaligned dcl 124 set ref 120 121 122 error 000150 automatic entry variable dcl 247 set ref 98* 105* 110 113 137 222 error_table_$noarg 000034 external static fixed bin(35,0) dcl 248 set ref 110* 113* index builtin function dcl 269 ref 183 194 ioa_ 000036 constant entry external dcl 249 ref 191 208 218 j 000154 automatic fixed bin(17,0) dcl 250 set ref 194* 197 200 length builtin function dcl 269 ref 122 186 186 195 ltrim builtin function dcl 269 ref 182 map_type 000010 internal static fixed bin(17,0) initial array dcl 272 set ref 171* me 000155 automatic char(32) unaligned dcl 251 set ref 83* 89* 110 110* 113* 137* 222* null builtin function dcl 269 ref 97 191 208 218 pack_picture_ 000040 constant entry external dcl 252 ref 174 picl 000165 automatic fixed bin(17,0) dcl 253 set ref 122* 130* 133 picp 000166 automatic pointer dcl 254 set ref 121* 129* 133 picture_image based structure level 1 dcl 1-6 picture_info_ 000042 constant entry external dcl 255 ref 133 pictured 000170 automatic varying char(256) dcl 256 set ref 178* 182* 182 183 185* 185 186 186 186* 186 186 191* 194 199 picv based char unaligned dcl 257 ref 133 prec 0(09) based fixed bin(8,0) level 2 packed unaligned dcl 1-6 ref 167 retval based varying char dcl 258 set ref 104* 195 195* 195 197* 197 199* 199 200* 200 210* 220* retval_l 000271 automatic fixed bin(21,0) dcl 259 set ref 102* 104 195 197 199 200 210 220 retval_p 000272 automatic pointer dcl 260 set ref 97* 102* 104 191 195 195 195 197 197 199 199 200 200 208 210 218 220 rtrim builtin function dcl 269 ref 185 scale 0(18) based fixed bin(8,0) level 2 packed unaligned dcl 1-6 ref 167 scalefactor 1(09) based fixed bin(8,0) level 2 packed unaligned dcl 1-6 ref 167 sign builtin function dcl 269 ref 137 size 000274 stack reference condition dcl 261 ref 156 strip_sw 000302 automatic bit(1) unaligned dcl 262 set ref 92* 123* 145 147* 180 substr builtin function dcl 269 ref 178 186 186 target 000303 automatic char(128) unaligned dcl 263 set ref 174 178 temp 000343 automatic char(1) array unaligned dcl 264 set ref 171 171 174* temp_length 000403 automatic fixed bin(35,0) dcl 265 set ref 167* 171* testing 000404 automatic bit(1) unaligned dcl 266 set ref 82* 88* 176 206 215 the_picture 000405 automatic varying char(100) dcl 267 set ref 120* 128* 137* 222* type based fixed bin(8,0) level 2 packed unaligned dcl 1-6 ref 171 varlength 1 based fixed bin(8,0) level 2 packed unaligned dcl 1-6 ref 178 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. picture_char_type internal static fixed bin(8,0) initial unaligned dcl 1-20 picture_complexfix_type internal static fixed bin(8,0) initial unaligned dcl 1-20 picture_complexflo_type internal static fixed bin(8,0) initial unaligned dcl 1-20 picture_realfix_type internal static fixed bin(8,0) initial unaligned dcl 1-20 picture_realflo_type internal static fixed bin(8,0) initial unaligned dcl 1-20 NAMES DECLARED BY EXPLICIT CONTEXT. err_exit 001223 constant label dcl 215 ref 154 159 pic 000162 constant entry external dcl 80 picture 000153 constant entry external dcl 80 start 000217 constant label dcl 92 ref 84 90 valid_pictured_data 000204 constant entry external dcl 86 vpd 000175 constant entry external dcl 86 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 1520 1564 1331 1530 Length 1766 1331 44 166 167 6 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME picture 402 external procedure is an external procedure. on unit on line 151 64 on unit on unit on line 156 64 on unit STORAGE FOR INTERNAL STATIC VARIABLES. LOC IDENTIFIER BLOCK NAME 000010 map_type picture STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME picture 000100 argct picture 000101 argl picture 000102 argno picture 000104 argp picture 000106 buff picture 000132 code picture 000133 Cond picture 000144 arg_ptr picture 000150 error picture 000154 j picture 000155 me picture 000165 picl picture 000166 picp picture 000170 pictured picture 000271 retval_l picture 000272 retval_p picture 000302 strip_sw picture 000303 target picture 000343 temp picture 000403 temp_length picture 000404 testing picture 000405 the_picture picture THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_char_temp call_ent_var_desc call_ent_var call_ext_out_desc call_ext_out return_mac tra_ext_1 sign_mac enable_op shorten_stack ext_entry int_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. active_fnc_err_ assign_ com_err_ cu_$af_arg_count cu_$af_arg_ptr cu_$af_return_arg cu_$arg_ptr ioa_ pack_picture_ picture_info_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$noarg LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 80 000152 82 000167 83 000170 84 000173 86 000174 88 000211 89 000213 90 000216 92 000217 94 000220 95 000231 97 000233 98 000235 99 000242 100 000245 102 000246 104 000263 105 000264 106 000271 108 000274 110 000277 113 000327 115 000352 117 000353 118 000371 120 000373 121 000400 122 000402 123 000403 126 000405 128 000406 129 000416 130 000417 133 000421 135 000453 137 000456 143 000522 145 000523 146 000535 147 000551 149 000561 151 000563 153 000577 154 000603 156 000606 158 000622 159 000626 161 000631 162 000641 163 000655 167 000663 171 000702 174 000734 176 000755 178 000757 180 000770 182 000772 183 001014 185 001026 186 001044 191 001057 194 001103 195 001115 197 001127 199 001141 200 001154 205 001165 206 001167 208 001171 210 001211 213 001222 215 001223 218 001225 220 001245 221 001256 222 001257 225 001322 ----------------------------------------------------------- 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