COMPILATION LISTING OF SEGMENT get_pl1_parm_desc_string_ Compiled by: Multics PL/I Compiler, Release 28d, of September 14, 1983 Compiled at: Honeywell LCPD Phoenix, System M Compiled on: 10/03/83 1710.6 mst Mon 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 11 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 12 /* */ 13 /* Name: get_pl1_parm_desc_string_ */ 14 /* */ 15 /* Given a pointer to the argument descriptor for an entry point parameter, and a */ 16 /* string in which the PL/I declaration of the entry point is being constructed, this */ 17 /* subroutine appends a description of the parameter to the string. */ 18 /* */ 19 /* Status */ 20 /* */ 21 /* 0) Created in May, 1979 by G. C. Dixon */ 22 /* 1) Modified in Jan, 1981 by G. C. Dixon - handle decimal unaligned values; */ 23 /* reimplement handling of structure alignment */ 24 /* 2) Modified in Jan, 1983 by T. G. Oke - handle star extents for pl1 and fortran */ 25 /* */ 26 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 27 28 29 30 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ 31 32 33 get_pl1_parm_desc_string_: 34 procedure (Pdesc, string, Acode); 35 36 dcl Pdesc ptr, /* ptr to descriptor to be printed. */ 37 string char(*) varying, /* return string, as supplied by caller. */ 38 Acode fixed bin(35); 39 40 offset = 0; 41 call recurse (Pdesc, 1, 0, "1"b, "0"b, offset, string, Acode); 42 return; 43 44 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * **/ 45 46 47 recurse: entry (Pdesc, level, Nignored_dim, Slast, ASpacked, Aoffset, string, Acode); 48 49 dcl level fixed bin, /* structure level of this descriptor. */ 50 Nignored_dim fixed bin, /* number of dimension inherited from containing */ 51 /* structure, to be ignored on output. */ 52 Slast bit(1) aligned, /* on if last structure element at this structure */ 53 /* is being output, or on for scalars. */ 54 ASpacked bit(1) aligned, /* on if prev structure level was packed. */ 55 Aoffset fixed bin; /* offset in words of next structure element */ 56 /* descriptor from one being processed. */ 57 58 59 60 dcl j fixed bin; 61 dcl offset fixed bin; 62 dcl (type, Ndim, size, scale) fixed bin, 63 Spacked bit(1) aligned; 64 dcl Pelement_desc ptr; 65 66 dcl desc (0:Aoffset-1) fixed bin(35) based(Pdesc); 67 68 dcl decode_descriptor_ entry (ptr, fixed bin, fixed bin, bit(1) aligned, fixed bin, fixed bin, fixed bin); 69 70 dcl pl1_type (1:46) char(24) varying int static init ( 71 "fixed bin", 72 "fixed bin", 73 "float bin", 74 "float bin", 75 "complex fixed bin", 76 "complex fixed bin", 77 "complex float bin", 78 "complex float bin", 79 "fixed dec", 80 "float dec", 81 "complex fixed dec", 82 "complex float dec", 83 "ptr", 84 "offset", 85 "label", 86 "entry", 87 "", /* structure */ 88 "area", 89 "bit", 90 "bit", 91 "char", 92 "char", 93 "file", 94 (9)*, 95 "uns fixed bin", 96 "uns fixed bin", 97 (8)*, 98 "fixed dec", 99 "float dec", 100 "complex fixed dec", 101 "complex float dec"); 102 dcl star_pl1_bits bit (36) static initial ("400000000000"b3); 103 dcl star_fort_bits bit (36) static initial ("377777777777"b3); 104 105 dcl star_pl1_size fixed bin(35) based (addr (star_pl1_bits)); 106 dcl star_fort_size fixed bin(35) based (addr (star_fort_bits)); 107 108 dcl error_table_$bad_segment fixed bin(35) ext static; 109 110 dcl (addr, addrel, length, ltrim, mod, substr) 111 builtin; 112 113 Acode = 0; 114 Aoffset = 1; 115 call decode_descriptor_ (Pdesc, 0, type, Spacked, Ndim, size, scale); 116 if (1 <= type & type <= 23) | /* Support only PL/I data types. */ 117 (33 <= type & type <= 34) | 118 (43 <= type & type <= 46) then; 119 else do; /* unimplemented or invalid descriptor. */ 120 Acode = error_table_$bad_segment; 121 return; 122 end; 123 124 if type = 17 then do; /* Handle structure level. */ 125 string = string || cv_num(level); 126 end; 127 else if level > 1 then do; /* Handle structure element level. */ 128 string = string || cv_num(level); 129 string = string || " "; 130 end; 131 else; /* Do nothing for scalars. */ 132 133 Aoffset = Aoffset + 3*Ndim; /* Handle arrays. */ 134 if Ndim - Nignored_dim > 0 then do; /* Dimensions reported in prev. recursions are */ 135 string = string || "("; /* ignored. */ 136 do j = 3 * (Ndim-Nignored_dim-1) to 0 by -3; 137 if desc(j+1) = 1 then string = string || cv_desc_num_(desc(j+2)); 138 /* Omit lbound of 1. */ 139 else do; 140 if desc (j+1) = star_pl1_size | 141 desc (j+1) = star_fort_size /* star extent */ 142 143 then string = string || cv_desc_num_(desc (j+1)); 144 else do; 145 string = string || cv_desc_num_(desc(j+1)); 146 string = string || ":"; 147 string = string || cv_desc_num_(desc(j+2)); 148 end; 149 end; 150 string = string || ","; 151 end; 152 substr(string,length(string),1) = ")"; /* Change final , to ) after last dimension. */ 153 string = string || " "; 154 end; 155 156 string = string || pl1_type(type); /* Output PL/I data type. */ 157 158 /* Output precision and scale. */ 159 if (type <= 8) | (33 <= type & type <= 34) then do; 160 /* binary numeric. */ 161 if size = 17 & scale = 0 then; /* omit default size/scale. */ 162 else do; 163 string = string || "("; 164 string = string || cv_num (size); 165 166 if mod(type-1,4) < 2 then /* signed fixed binary. */ 167 if scale ^= 0 then do; /* include scale when nonzero. */ 168 string = string || ","; 169 string = string || cv_num (scale); 170 end; 171 else; 172 else if (33 <= type & type <= 34) then/* unsigned fixed binary. */ 173 if scale ^= 0 then do; /* include scale when nonzero. */ 174 string = string || ","; 175 string = string || cv_num (scale); 176 end; 177 string = string || ")"; 178 end; 179 end; 180 181 else if (9 <= type & type <= 12) | /* decimal numeric */ 182 (43 <= type & type <= 46) then do; 183 string = string || "("; 184 string = string || cv_num(size); /* Always include size. Most people don't know */ 185 /* what the default is for decimal data. */ 186 if mod(type,2) = 1 then /* fixed decimal */ 187 if scale ^= 0 then do; /* include scale when nonzero. */ 188 string = string || ","; 189 string = string || cv_num (scale); 190 end; 191 string = string || ")"; 192 end; 193 194 else if 19 <= type & type <= 22 then do; 195 string = string || "("; /* bit or character string. */ 196 if size = 16777215 then /* star extent. */ 197 string = string || "*"; 198 else string = string || cv_num(size); 199 string = string || ")"; 200 if mod(type,2) = 0 then /* varying bit or char string. */ 201 string = string || " var"; 202 end; 203 204 else if type = 18 then do; /* area */ 205 string = string || "("; 206 if size = 16777215 then /* star extent. */ 207 string = string || "*"; 208 else string = string || cv_num(size); 209 string = string || ")"; 210 end; 211 212 /* Handle storage alignment. */ 213 if type = 17 then do; /* structures or substructures. */ 214 if Spacked then; /* If structure packed, all its elements will */ 215 /* be marked unaligned. */ 216 else if all_structure_elements_packed() then /* If structure unpacked, only mark it aligned*/ 217 string = string || " aligned"; /* if all its elements are packed. */ 218 end; 219 220 else do; /* scalars, array or structure elements. */ 221 if level = 1 then do; /* scalars: assume user know default alignment.*/ 222 if type = 19 | type = 21 then /* Only give alignment if it differs from the */ 223 if Spacked then; /* default. */ 224 else string = string || " aligned"; 225 else if Spacked then 226 string = string || " unal"; 227 end; 228 else do; /* structure elements. */ 229 if ASpacked then /* containing structure is packed. */ 230 string = string || " unal"; /* its elements are packed by definition. */ 231 else /* containing structure not packed. */ 232 if Spacked then /* Explicitly state alignment of structure els. */ 233 string = string || " unal"; 234 else string = string || " aligned"; 235 end; 236 end; 237 238 if type = 17 then do; /* process the structure elements. */ 239 do j = 1 to size; /* structure contains size elements. */ 240 string = string || ", "; 241 Pelement_desc = addrel(addr(desc(Aoffset-1)), 1); 242 /* Aoffset is offset of next structure element */ 243 /* descriptor from structure descriptor. */ 244 offset = 0; /* Number of descriptors used up by structure */ 245 /* element will be stored in offset by the call.*/ 246 call recurse (Pelement_desc, level+1, Ndim, (j=size&Slast), Spacked, offset, string, Acode); 247 if Acode ^= 0 then return; 248 Aoffset = Aoffset + offset; /* Skip over descriptors for this structure el. */ 249 end; 250 end; 251 RETURN: return; 252 253 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 254 255 256 cv_num: proc (n) returns (char(16) varying); 257 258 dcl n fixed bin(17), 259 n_ fixed bin(35), 260 p pic "---------------9"; 261 262 p = n; 263 go to COMMON; 264 265 cv_desc_num_: 266 entry (n_) returns (char (16) varying); 267 268 if n_ = star_pl1_size | n_ = star_fort_size /* star extent */ 269 then return ("*"); 270 else p = n_; 271 go to COMMON; 272 273 274 cv_num_: entry (n_) returns (char(16) varying); 275 276 p = n_; 277 278 COMMON: return (ltrim(p)); 279 280 end cv_num; 281 282 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 283 284 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 285 286 287 all_structure_elements_packed: /* Internal procedure finds out if all elements of*/ 288 proc returns(bit(1)); /* a structure are packed. */ 289 290 dcl Spacked bit(1) aligned, 291 elem_offset fixed bin, 292 temp_offset fixed bin; 293 294 elem_offset = Aoffset; /* Save current offset. */ 295 Spacked = "1"b; /* Start by assuming all are packed. Search ends */ 296 do j = 1 to size while (Spacked); /* when first unpacked element is found. */ 297 /* Algorithm in this do loop same as that used */ 298 /* above for actually emitting elem. dcls. */ 299 Pelement_desc = addrel(addr(desc(elem_offset-1)),1); 300 temp_offset = 0; 301 call recurse_structure_elements_packed (Pelement_desc, level+1, Ndim, (j=size&Slast), 302 Spacked, temp_offset, Acode); 303 if Acode ^= 0 then go to RETURN; 304 elem_offset = elem_offset + temp_offset; 305 end; 306 return (Spacked); 307 308 end all_structure_elements_packed; 309 310 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 311 312 313 recurse_structure_elements_packed: 314 entry (Pdesc, level, Nignored_dim, Slast, ASpacked, Aoffset, Acode); 315 316 Acode = 0; /* decode descriptor for structure element, just */ 317 Aoffset = 1; /* as for the $recurse entry point. */ 318 call decode_descriptor_ (Pdesc, 0, type, Spacked, Ndim, size, scale); 319 if (1 <= type & type <= 23) | 320 (33 <= type & type <= 34) | 321 (43 <= type & type <= 46) then; 322 else do; 323 Acode = error_table_$bad_segment; 324 return; 325 end; 326 327 if ^Spacked then do; /* If structure element unpacked, we can stop now.*/ 328 ASpacked = "0"b; 329 return; 330 end; 331 332 if type = 17 then /* If structure el is another structure, return */ 333 /* result of testing its elements. */ 334 ASpacked = all_structure_elements_packed (); 335 336 return; 337 338 /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ 339 340 341 end get_pl1_parm_desc_string_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/03/83 1009.5 get_pl1_parm_desc_string_.pl1 >spec>on>pl128d>get_pl1_parm_desc_string_.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. ASpacked parameter bit(1) dcl 49 set ref 47 229 313 328* 332* Acode parameter fixed bin(35,0) dcl 36 set ref 33 41* 47 113* 120* 246* 247 301* 303 313 316* 323* Aoffset parameter fixed bin(17,0) dcl 49 set ref 47 114* 133* 133 241 248* 248 294 313 317* Ndim automatic fixed bin(17,0) dcl 62 set ref 115* 133 134 136 246* 301* 318* Nignored_dim parameter fixed bin(17,0) dcl 49 ref 47 134 136 313 Pdesc parameter pointer dcl 36 set ref 33 41* 47 115* 137 137 140 140 140 145 147 241 299 313 318* Pelement_desc automatic pointer dcl 64 set ref 241* 246* 299* 301* Slast parameter bit(1) dcl 49 ref 47 246 301 313 Spacked automatic bit(1) dcl 62 in procedure "get_pl1_parm_desc_string_" set ref 115* 214 222 225 231 246* 318* 327 Spacked automatic bit(1) dcl 290 in procedure "all_structure_elements_packed" set ref 295* 296 301* 306 addr builtin function dcl 110 ref 140 140 241 268 268 299 addrel builtin function dcl 110 ref 241 299 decode_descriptor_ 000000 constant entry external dcl 68 ref 115 318 desc based fixed bin(35,0) array dcl 66 set ref 137 137* 140 140 140* 145* 147* 241 299 elem_offset automatic fixed bin(17,0) dcl 290 set ref 294* 299 304* 304 error_table_$bad_segment external static fixed bin(35,0) dcl 108 ref 120 323 j automatic fixed bin(17,0) dcl 60 set ref 136* 137 137 140 140 140 145 147* 239* 246* 296* 301* length builtin function dcl 110 ref 152 level parameter fixed bin(17,0) dcl 49 set ref 47 125* 127 128* 221 246 301 313 ltrim builtin function dcl 110 ref 278 mod builtin function dcl 110 ref 166 186 200 n parameter fixed bin(17,0) dcl 258 ref 256 262 n_ parameter fixed bin(35,0) dcl 258 ref 265 268 268 270 274 276 offset automatic fixed bin(17,0) dcl 61 set ref 40* 41* 244* 246* 248 p automatic picture unaligned dcl 258 set ref 262* 270* 276* 278 pl1_type internal static varying char(24) initial array dcl 70 ref 156 scale automatic fixed bin(17,0) dcl 62 set ref 115* 161 166 169* 172 175* 186 189* 318* size automatic fixed bin(17,0) dcl 62 set ref 115* 161 164* 184* 196 198* 206 208* 239 246 296 301 318* star_fort_bits internal static bit(36) initial unaligned dcl 103 set ref 140 268 star_fort_size based fixed bin(35,0) dcl 106 ref 140 268 star_pl1_bits internal static bit(36) initial unaligned dcl 102 set ref 140 268 star_pl1_size based fixed bin(35,0) dcl 105 ref 140 268 string parameter varying char dcl 36 set ref 33 41* 47 125* 125 128* 128 129* 129 135* 135 137* 137 140* 140 145* 145 146* 146 147* 147 150* 150 152 152* 153* 153 156* 156 163* 163 164* 164 168* 168 169* 169 174* 174 175* 175 177* 177 183* 183 184* 184 188* 188 189* 189 191* 191 195* 195 196* 196 198* 198 199* 199 200* 200 205* 205 206* 206 208* 208 209* 209 216* 216 224* 224 225* 225 229* 229 231* 231 234* 234 240* 240 246* substr builtin function dcl 110 set ref 152* temp_offset automatic fixed bin(17,0) dcl 290 set ref 300* 301* 304 type automatic fixed bin(17,0) dcl 62 set ref 115* 116 116 116 116 116 116 124 156 159 159 159 166 172 172 181 181 181 181 186 194 194 200 204 213 222 222 238 318* 319 319 319 319 319 319 332 NAMES DECLARED BY EXPLICIT CONTEXT. COMMON 000000 constant label dcl 278 ref 263 271 RETURN 000000 constant label dcl 251 set ref 303 all_structure_elements_packed 000000 constant entry internal dcl 287 ref 216 332 cv_desc_num_ 000000 constant entry internal dcl 265 ref 137 140 145 147 cv_num 000000 constant entry internal dcl 256 ref 125 128 164 169 175 184 189 198 208 cv_num_ 000000 constant entry internal dcl 274 get_pl1_parm_desc_string_ 000000 constant entry external dcl 33 recurse 000000 constant entry external dcl 47 ref 41 246 recurse_structure_elements_packed 000000 constant entry external dcl 313 ref 301 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. ERROR 459, SEVERITY 3 ON LINE 258 Syntax error in the fixed-point picture declared for "p". ERROR 440, SEVERITY 3 ON LINE 262 Syntax error in a picture declared for "cp.224". ERROR 440, SEVERITY 3 ON LINE 270 Syntax error in a picture declared for "cp.227". ERROR 440, SEVERITY 3 ON LINE 276 Syntax error in a picture declared for "cp.230". ----------------------------------------------------------- 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