COMPILATION LISTING OF SEGMENT gcos_make_tape Compiled by: Multics PL/I Compiler, Release 27d, of October 11, 1982 Compiled at: Honeywell LISD Phoenix, System M Compiled on: 11/19/82 1014.5 mst Fri Options: optimize map 1 /* *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* *********************************************************** */ 9 10 11 gcos_make_tape: gmt: proc; 12 13 14 /* Procedure to create gcos tape in standard system format from ascii file. 15* Calling sequence is: 16* 17* gmt input_pn tape_label -tape_type 18* 19* where 20* 21* 22* 1) input_pn is the relative path name of the 23* ascii segment to be converted 24* 25* 26* 2) tape_label is the label of the tape to be 27* written 28* 29* 3) tape_type is an optional tape type. If specified, 30* it must be "-9", in which case the tape 31* label will become tape_label||",9track". 32* If not specified, the tape label will 33* become tape_label||",7track" 34* 35* 36* */ 37 38 39 /* DECLARATIONS */ 40 /* ------------ */ 41 42 43 /* fixed bin */ 44 45 dcl ( 46 al, /* argument length */ 47 i, /* random variable */ 48 tape_label_len /* tape label character count */ 49 ) fixed bin aligned; 50 51 dcl ( 52 code, /* error code */ 53 error_table_$badopt ext 54 )fixed bin (35) aligned; 55 56 57 /* pointers */ 58 59 dcl ( 60 ap, /* argument pointer */ 61 sp /* pointer to ios status string */ 62 ) ptr aligned; 63 64 65 /* bit strings */ 66 67 dcl ( 68 eof init ("0"b) /* ON when end of ascii file is read */ 69 ) bit (1) aligned; 70 71 dcl ( 72 rcrdhdr init ("000010000000"b) /* record header for gcos tape */ 73 ) bit (12) aligned; 74 75 dcl ( 76 status_bits /* ios status string */ 77 ) bit (72) aligned; 78 79 80 /* character strings */ 81 82 dcl nl char (1) unaligned init (" 83 "); /* new line character */ 84 85 dcl ( 86 dim_name init ("nstd_"), /* name of output dim */ 87 tape_label_suffix init (",7track") /* for making tape label */ 88 ) char (8) aligned; 89 90 dcl ( 91 tape_label /* actual tape label */ 92 ) char (32) aligned; 93 94 dcl ( 95 word14 /* buffer for writing tape */ 96 ) char (56) aligned; 97 98 dcl ( 99 input_buffer /* for reading segment */ 100 ) char (84) aligned; 101 102 dcl ( 103 input_pn /* path-name of input segment */ 104 ) char (168) aligned; 105 106 107 /* masks */ 108 109 dcl arg char (al) based (ap); /* argument mask */ 110 111 dcl 1 status aligned based (sp), /* for checking io status */ 112 2 scode fixed bin aligned, 113 2 pad bit (9) unaligned, 114 2 eof bit (1) unaligned; 115 116 117 /* builtin functions */ 118 119 dcl ( 120 addr, 121 null, 122 index, 123 substr 124 ) builtin; 125 126 /* conditions */ 127 128 dcl ( 129 cleanup 130 ) condition; 131 132 133 /* external entries */ 134 135 dcl com_err_ ext entry 136 options (variable); 137 138 dcl cu_$arg_ptr ext entry 139 (fixed bin aligned, ptr aligned, fixed bin aligned, fixed bin (35) aligned); 140 141 dcl cv_ascii_to_bcd_ ext entry 142 (ptr aligned, ptr aligned, fixed bin (35) aligned); 143 144 dcl gcos_gsr_write_ ext entry 145 (char (*) aligned, ptr aligned, fixed bin aligned, bit (12) aligned, bit (1) aligned, fixed bin (35) aligned); 146 147 dcl gcos_gsr_write_$gsr_write_close ext entry 148 (char (*) aligned, fixed bin (35) aligned); 149 150 dcl gcos_gsr_write_$gsr_write_init ext entry 151 (char (*) aligned, fixed bin (35) aligned); 152 153 dcl ios_$attach ext entry 154 (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); 155 156 dcl ios_$detach ext entry 157 (char (*) aligned, char (*) aligned, char (*) aligned, bit (72) aligned); 158 159 dcl ios_$order ext entry 160 (char (*) aligned, char (*) aligned, ptr aligned, bit (72) aligned); 161 162 dcl ios_$read ext entry 163 (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned); 164 165 dcl ios_$setsize ext entry 166 (char (*) aligned, fixed bin aligned, bit (72) aligned); 167 168 dcl ios_$write ext entry 169 (char (*) aligned, ptr aligned, fixed bin aligned, fixed bin aligned, fixed bin aligned, bit (72) aligned); 170 171 /* */ 172 173 go to COMMON; 174 175 gcos_make_file: gmf: entry; 176 177 dim_name = "file_"; /* attach output to file */ 178 179 COMMON: 180 181 sp = addr (status_bits); /* pointer to ios status string */ 182 on condition (cleanup) /* establish cleanup handler */ 183 call wrap_up; 184 185 call get_arg (1); /* fetch ascii file path-name */ 186 if code ^= 0 /* missing argument */ 187 then return; 188 189 input_pn = arg; /* remember (for detaching) */ 190 call ios_$attach ("gmt_input", "file_", input_pn, "r", status_bits); /* attach file */ 191 if scode ^= 0 /* error attaching file */ 192 then do; 193 call com_err_ (scode, "gmt", "Error attaching ^a", input_pn); 194 return; 195 end; 196 197 call get_arg (2); /* fetch tape name */ 198 if code ^= 0 /* missing argument */ 199 then do; 200 call wrap_up; 201 return; 202 end; 203 204 tape_label_len = al; /* get length */ 205 tape_label = arg; /* and label */ 206 207 call get_arg (3); /* fetch option */ 208 if code = 0 /* an option is present */ 209 then do; 210 if dim_name ^= "nstd_" /* error, tape option for file output */ 211 then go to BADOPT; 212 if arg = "-9" /* request for 9 track tape */ 213 then tape_label_suffix = ",9track"; 214 else /* invalid option */ 215 do; 216 BADOPT: 217 call com_err_ (error_table_$badopt, "gmt", "^a", arg); 218 call wrap_up; 219 return; 220 end; 221 end; 222 223 if dim_name ^= "nstd_" /* file output */ 224 then tape_label_suffix = ".bcd"; /* file name = "name.bcd" */ 225 226 tape_label = substr (tape_label, 1, tape_label_len)||tape_label_suffix; /* make tape label */ 227 228 call ios_$attach ("gmt_output", dim_name, tape_label, "w", status_bits); /* attach tape */ 229 if scode ^= 0 /* error attaching tape */ 230 then do; 231 call com_err_ (scode, "gmt", "Error attaching ^a", tape_label); 232 call wrap_up; 233 return; 234 end; 235 236 if dim_name ^= "nstd_" /* not testing */ 237 then do; 238 call ios_$setsize ("gmt_output", 36, status_bits); /* set element size to full word */ 239 if scode ^= 0 /* error setting element size */ 240 then do; 241 call com_err_ (scode, "gmt", "Error setting element size"); 242 call wrap_up; 243 return; 244 end; 245 end; 246 247 call gcos_gsr_write_$gsr_write_init ("gmt_output", code); /* initialize write proc */ 248 if code ^= 0 /* error in initialization */ 249 then do; 250 call com_err_ (code, "gmt", "Error initializing gsr_write"); 251 call wrap_up; 252 return; 253 end; 254 255 input_buffer = tape_label; /* first write is tape label */ 256 call cv_ascii_to_bcd_ (addr (input_buffer), addr (word14), code); 257 if code ^= 0 258 then do; 259 call com_err_ (0, "gmt", "Error converting tape label ^a to bcd", tape_label); 260 call wrap_up; 261 return; 262 end; 263 264 if dim_name = "nstd_" /* output is to tape */ 265 then do; 266 267 call ios_$write ("gmt_output", addr (word14), 0, 14, i, status_bits); /* write tape label */ 268 if scode ^= 0 /* error writing tape label */ 269 then do; 270 call com_err_ (scode, "gmt", "Error writing tape label"); 271 call wrap_up; 272 return; 273 end; 274 275 call ios_$order ("gmt_output", "eof", null, status_bits); /* eof mark follows tape label */ 276 if scode ^= 0 /* error in order call */ 277 then do; 278 call com_err_ (scode, "gmt", "Error in order call to write eof mark"); 279 call wrap_up; 280 return; 281 end; 282 283 end; 284 285 do while (^eof); /* loop for writing body of tape */ 286 287 input_buffer = ""; /* blank out reading space */ 288 289 call ios_$read ("gmt_input", addr (input_buffer), 0, 84, i, status_bits); /* read a line of input */ 290 if scode ^= 0 /* error reading */ 291 then do; 292 call com_err_ (scode, "gmt", "Error reading ^a", input_pn); 293 call wrap_up; 294 return; 295 end; 296 297 i = index (input_buffer, nl); /* find new_line character */ 298 if i ^= 0 /* and blank it out */ 299 then substr (input_buffer, i, 1) = " "; 300 301 if status.eof /* end of input */ 302 then eof = "1"b; /* remember */ 303 304 call cv_ascii_to_bcd_ (addr (input_buffer), addr (word14), code); /* convert to bcd */ 305 if code ^= 0 /* conversion error */ 306 then do; 307 call com_err_ (0, "gmt", "Invalid input: ^a", input_buffer); 308 call wrap_up; 309 return; 310 end; 311 312 call gcos_gsr_write_ ("gmt_output", addr (word14), 14, rcrdhdr, eof, code); /* write bcd */ 313 if code ^= 0 /* error writing bcd */ 314 then do; 315 call com_err_ (code, "gmt", "Error writing tape record"); 316 call wrap_up; 317 return; 318 end; 319 320 end; 321 322 if dim_name = "nstd_" /* not testing */ 323 then do i = 1 to 2; /* put two eof marks at end of tape */ 324 325 call ios_$order ("gmt_output", "eof", null, status_bits); 326 if scode ^= 0 /* error writing eofs */ 327 then do; 328 call com_err_ (code, "gmt", "Error writing final eofs"); 329 call wrap_up; 330 return; 331 end; 332 333 end; 334 335 call wrap_up; 336 337 /* */ 338 339 get_arg: proc (an); 340 341 dcl ( 342 an /* argument number */ 343 ) fixed bin aligned; 344 345 call cu_$arg_ptr (an, ap, al, code); /* fetch an argument */ 346 if code ^= 0 /* print error message */ 347 then if an < 3 /* not option */ 348 then call com_err_ (code, "gmt"); 349 return; 350 351 end get_arg; 352 353 354 355 wrap_up: proc; /* do final detaching */ 356 357 call ios_$detach ("gmt_input", input_pn, "", status_bits); 358 call gcos_gsr_write_$gsr_write_close ("gm_output", code); 359 call ios_$detach ("gmt_output", tape_label, "", status_bits); 360 return; 361 362 end wrap_up; 363 364 365 end gcos_make_tape; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/19/82 0934.0 gcos_make_tape.pl1 >spec>on>11/19/82>gcos_make_tape.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. addr builtin function dcl 119 ref 179 256 256 256 256 267 267 289 289 304 304 304 304 312 312 al 000100 automatic fixed bin(17,0) dcl 45 set ref 189 204 205 212 216 216 345* an parameter fixed bin(17,0) dcl 341 set ref 339 345* 346 ap 000104 automatic pointer dcl 59 set ref 189 205 212 216 345* arg based char unaligned dcl 109 set ref 189 205 212 216* cleanup 000250 stack reference condition dcl 128 ref 182 code 000103 automatic fixed bin(35,0) dcl 51 set ref 186 198 208 247* 248 250* 256* 257 304* 305 312* 313 315* 328* 345* 346 346* 358* com_err_ 000012 constant entry external dcl 135 ref 193 216 231 241 250 259 270 278 292 307 315 328 346 cu_$arg_ptr 000014 constant entry external dcl 138 ref 345 cv_ascii_to_bcd_ 000016 constant entry external dcl 141 ref 256 304 dim_name 000116 automatic char(8) initial dcl 85 set ref 85* 177* 210 223 228* 236 264 322 eof 000110 automatic bit(1) initial dcl 67 in procedure "gmt" set ref 67* 285 301* 312* eof 1(09) based bit(1) level 2 in structure "status" packed unaligned dcl 111 in procedure "gmt" ref 301 error_table_$badopt 000010 external static fixed bin(35,0) dcl 51 set ref 216* gcos_gsr_write_ 000020 constant entry external dcl 144 ref 312 gcos_gsr_write_$gsr_write_close 000022 constant entry external dcl 147 ref 358 gcos_gsr_write_$gsr_write_init 000024 constant entry external dcl 150 ref 247 i 000101 automatic fixed bin(17,0) dcl 45 set ref 267* 289* 297* 298 298 322* index builtin function dcl 119 ref 297 input_buffer 000150 automatic char(84) dcl 98 set ref 255* 256 256 287* 289 289 297 298* 304 304 307* input_pn 000175 automatic char(168) dcl 102 set ref 189* 190* 193* 292* 357* ios_$attach 000026 constant entry external dcl 153 ref 190 228 ios_$detach 000030 constant entry external dcl 156 ref 357 359 ios_$order 000032 constant entry external dcl 159 ref 275 325 ios_$read 000034 constant entry external dcl 162 ref 289 ios_$setsize 000036 constant entry external dcl 165 ref 238 ios_$write 000040 constant entry external dcl 168 ref 267 nl 000114 automatic char(1) initial unaligned dcl 82 set ref 82* 297 null builtin function dcl 119 ref 275 275 325 325 rcrdhdr 000111 automatic bit(12) initial dcl 71 set ref 71* 312* scode based fixed bin(17,0) level 2 dcl 111 set ref 191 193* 229 231* 239 241* 268 270* 276 278* 290 292* 326 sp 000106 automatic pointer dcl 59 set ref 179* 191 193 229 231 239 241 268 270 276 278 290 292 301 326 status based structure level 1 dcl 111 status_bits 000112 automatic bit(72) dcl 75 set ref 179 190* 228* 238* 267* 275* 289* 325* 357* 359* substr builtin function dcl 119 set ref 226 298* tape_label 000122 automatic char(32) dcl 90 set ref 205* 226* 226 228* 231* 255 259* 359* tape_label_len 000102 automatic fixed bin(17,0) dcl 45 set ref 204* 226 tape_label_suffix 000120 automatic char(8) initial dcl 85 set ref 85* 212* 223* 226 word14 000132 automatic char(56) dcl 94 set ref 256 256 267 267 304 304 312 312 NAMES DECLARED BY EXPLICIT CONTEXT. BADOPT 000455 constant label dcl 216 ref 210 COMMON 000251 constant label dcl 179 ref 173 gcos_make_file 000241 constant entry external dcl 175 gcos_make_tape 000221 constant entry external dcl 11 get_arg 001744 constant entry internal dcl 339 ref 185 197 207 gmf 000231 constant entry external dcl 175 gmt 000211 constant entry external dcl 11 wrap_up 002012 constant entry internal dcl 355 ref 182 200 218 232 242 251 260 271 279 293 308 316 329 335 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 2340 2402 2137 2350 Length 2606 2137 42 170 201 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME gmt 269 external procedure is an external procedure. on unit on line 182 64 on unit get_arg internal procedure shares stack frame of external procedure gmt. wrap_up 86 internal procedure is called by several nonquick procedures. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME gmt 000100 al gmt 000101 i gmt 000102 tape_label_len gmt 000103 code gmt 000104 ap gmt 000106 sp gmt 000110 eof gmt 000111 rcrdhdr gmt 000112 status_bits gmt 000114 nl gmt 000116 dim_name gmt 000120 tape_label_suffix gmt 000122 tape_label gmt 000132 word14 gmt 000150 input_buffer gmt 000175 input_pn gmt THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. alloc_cs call_ext_out_desc call_ext_out call_int_this call_int_other return enable shorten_stack ext_entry int_entry THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. com_err_ cu_$arg_ptr cv_ascii_to_bcd_ gcos_gsr_write_ gcos_gsr_write_$gsr_write_close gcos_gsr_write_$gsr_write_init ios_$attach ios_$detach ios_$order ios_$read ios_$setsize ios_$write THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$badopt LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 67 000175 71 000176 82 000200 85 000202 11 000210 173 000227 175 000230 177 000247 179 000251 182 000253 185 000275 186 000301 189 000303 190 000310 191 000351 193 000353 194 000410 197 000411 198 000415 200 000417 201 000423 204 000424 205 000426 207 000432 208 000436 210 000440 212 000444 216 000455 218 000511 219 000515 223 000516 226 000524 228 000541 229 000602 231 000604 232 000641 233 000645 236 000646 238 000652 239 000702 241 000704 242 000732 243 000736 247 000737 248 000761 250 000763 251 001011 252 001015 255 001016 256 001021 257 001040 259 001042 260 001075 261 001101 264 001102 267 001106 268 001153 270 001155 271 001203 272 001207 275 001210 276 001246 278 001250 279 001276 280 001302 285 001303 287 001306 289 001311 290 001355 292 001357 293 001414 294 001420 297 001421 298 001432 301 001436 304 001444 305 001463 307 001465 308 001520 309 001524 312 001525 313 001573 315 001575 316 001623 317 001627 320 001630 322 001631 325 001642 326 001700 328 001702 329 001730 330 001734 333 001735 335 001737 365 001743 339 001744 345 001746 346 001763 349 002010 355 002011 357 002017 358 002050 359 002072 360 002125 ----------------------------------------------------------- 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