COMPILATION LISTING OF SEGMENT l6_ftf_ Compiled by: Multics PL/I Compiler, Release 27d, of October 11, 1982 Compiled at: Honeywell LISD Phoenix, System M Compiled on: 11/18/82 1644.4 mst Thu 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 12 /*(stringsize, stringrange): DEBUG*/ 13 /* format: style3,linecom,ifthenstmt,indthenelse,^indnoniterdo,indend,initlm3,dclind5,idind32 */ 14 l6_ftf_: 15 proc (Pl6swp, Piobp, Piobl, Puop, Puof, Peop, Peof, Ptdir, Pcode); 16 17 /*dcl ioa_ entry options(variable); DEBUG*/ 18 dcl ( 19 Pl6swp ptr, /* Input -- Pointer to iocb for Level 6 communication. */ 20 Piobp ptr, /* Input -- Pointer to an IO buffer. */ 21 Piobl fixed bin (21), /* Input -- Length of the IO buffer if Piobp is non-null. */ 22 Puop ptr, /* Input -- Pointer to an iocb for user output. */ 23 Puof bit (1), /* Input -- Flag controlling user output. */ 24 Peop ptr, /* Input -- Pointer to an iocb for error output. */ 25 Peof bit (1), /* Input -- Flag controlling error output. */ 26 Ptdir char (168), /* Input -- Pathname of directory where transfers happen. */ 27 Pcode fixed bin (35) /* Output -- Standard system error code. */ 28 ) parameter; 29 30 /* 31* D_E_S_C_R_I_P_T_I_O_N_ 32* 33* This subroutine takes a pointer to an iocb opened for 34* stream_input_output to a Level 6 and an IO buffer pointer and length 35* in characters, and implements the Level 6 FTF protocol to transfer a 36* single file to or from the Level 6. The IO buffer is used for receiving 37* input from, and sending output to the Level 6 as defined by the protocol. 38* The other arguments are a pointer to an iocb for writing information 39* to the user and a flag controlling this output; and a pointer to an 40* iocb for writing error messages and a flag controlling this. Fianlly, 41* a standard system status code is returned indicating the success or 42* failure of the file transfer. 43* If no IO buffer pointer is provided then a temp segment will be 44* used and released for each invocation of this subroutine. If the 45* user and/or error output flags are off, the corresponding pointers 46* may be null and no output will be done. 47* 48* 49* J_O_U_R_N_A_L_I_Z_A_T_I_O_N_ 50* 51* 1) Written 6/79 by R.J.C. Kissel. 52**/ 53 54 dcl iobp ptr; /* Pointer to the IO buffer. */ 55 dcl cleanup condition; 56 dcl l6_switchp ptr; /* Pointer to Level 6 iocb. */ 57 dcl user_switchp ptr; /* Pointer to user output iocb. */ 58 dcl error_switchp ptr; /* Pointer to error output iocb. */ 59 dcl user_flag bit (1); /* ON -- Output information to the user. */ 60 dcl error_flag bit (1); /* ON -- Output error messages to the user. */ 61 dcl tseg_allocated bit (1); /* ON -- Indicates we allocated a temp segment. */ 62 dcl sub_name char (7) internal static options (constant) init ("l6_ftf_"); 63 dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); 64 dcl code fixed bin (35); /* Returned status code. */ 65 dcl iobl fixed bin (21); /* Length of the IO buffer. */ 66 dcl sys_info$max_seg_size fixed bin (19) external; 67 dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); 68 dcl io_buf_array (iobl) char (1) based unaligned; 69 dcl io_buf char (iobl) based unaligned; 70 dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); 71 dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); 72 dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); 73 dcl length builtin; 74 dcl null builtin; 75 dcl substr builtin; 76 dcl target_dir char (168); 77 dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); 78 79 dcl 1 file_info, 80 2 iox_info, 81 3 file_ptr ptr, 82 3 attached bit (1), 83 3 open bit (1), 84 3 mode fixed bin, /* Either stream or record. */ 85 2 direction fixed bin, 86 2 name char (168), 87 2 type fixed bin, 88 2 data_type fixed bin, 89 2 rec_size fixed bin (21), 90 2 starting_rec fixed bin (21), 91 2 access fixed bin, 92 2 key_len fixed bin, 93 2 key_off fixed bin, 94 2 percent_fill fixed bin, 95 2 key_type fixed bin, 96 2 ci_size fixed bin, 97 2 size fixed bin (21), 98 2 init_file_count fixed bin, 99 2 accept_file_count fixed bin; 100 101 dcl 1 binary_data aligned based, 102 2 num_sextets fixed bin (35) aligned, 103 2 sextets (0 refer (binary_data.num_sextets)) fixed bin (6) unsigned unaligned; 104 105 dcl Cstream fixed bin internal static options (constant) init (1); 106 dcl Crecord fixed bin internal static options (constant) init (2); 107 dcl Cinput fixed bin internal static options (constant) init (1); 108 dcl Coutput fixed bin internal static options (constant) init (2); 109 dcl Cnew fixed bin internal static options (constant) init (1); 110 dcl Cold fixed bin internal static options (constant) init (2); 111 dcl Cascii fixed bin internal static options (constant) init (1); 112 dcl Cbinary fixed bin internal static options (constant) init (2); 113 dcl Cbcd fixed bin internal static options (constant) init (3); 114 dcl Csequential fixed bin internal static options (constant) init (1); 115 dcl Crelative fixed bin internal static options (constant) init (2); 116 dcl Cindexed fixed bin internal static options (constant) init (3); 117 dcl Cuninitialized fixed bin internal static options (constant) init (0); 118 dcl message_ptr ptr; 119 dcl message_len fixed bin (21); 120 dcl message char (message_len) based (message_ptr); 121 dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); 122 dcl l6_file_switch char (14) internal static options (constant) init ("l6_file_switch"); 123 dcl iox_$open entry (ptr, fixed bin, bit (1), fixed bin (35)); 124 dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); 125 dcl iox_$close entry (ptr, fixed bin (35)); 126 dcl iox_$detach_iocb entry (ptr, fixed bin (35)); 127 dcl mod builtin; 128 dcl rtrim builtin; 129 dcl addr builtin; 130 dcl string builtin; 131 dcl copy builtin; 132 dcl addrel builtin; 133 dcl maxlength builtin; 134 dcl currentsize builtin; 135 dcl min builtin; 136 dcl rank builtin; 137 dcl byte builtin; 138 dcl current_iob_position fixed bin (21); 139 dcl current_iob_length fixed bin (21); 140 dcl current_tusn fixed bin; 141 dcl current_rsn fixed bin; 142 dcl last_successful_rsn fixed bin; 143 dcl global_string char (1024) varying; 144 dcl data_buf char (1024) varying; 145 dcl error_table_$short_record fixed bin (35) external; 146 dcl error_table_$end_of_info fixed bin (35) external; 147 dcl accept_msg char (256); 148 dcl accept_msg_len fixed bin (21); 149 dcl internal_tu char (1000) varying; 150 dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); 151 dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); 152 dcl Cnew_line char (1) internal static options (constant) init (" 153 "); 154 dcl ioa_$ioa_switch entry options (variable); 155 dcl ioa_$ioa_switch_nnl entry options (variable); 156 dcl timer_manager_$alarm_call entry (fixed bin (71), bit (2), entry); 157 dcl timer_manager_$reset_alarm_call entry (entry); 158 dcl read_timeout entry variable; 159 dcl write_timeout entry variable; 160 dcl get_chars_done bit (1); 161 dcl put_chars_done bit (1); 162 dcl timeout_value fixed bin (71); 163 164 l6_switchp = Pl6swp; 165 user_switchp = Puop; 166 user_flag = Puof; 167 error_switchp = Peop; 168 error_flag = Peof; 169 target_dir = Ptdir; 170 171 last_successful_rsn = 0; 172 current_rsn = 0; 173 current_tusn = 0; 174 current_iob_position = 0; 175 current_iob_length = 0; 176 global_string = ""; 177 data_buf = ""; 178 internal_tu = "0"; 179 180 read_timeout = Read_Timeout; 181 write_timeout = Write_Timeout; 182 get_chars_done = "0"b; 183 put_chars_done = "0"b; 184 timeout_value = 2 * 60 * 1000000; /* 2 minutes in microseconds. */ 185 186 tseg_allocated = "0"b; 187 188 call Init_File_Info (); 189 190 on cleanup call Cleanup_Handler (); 191 192 /* Setup the IO buffer pointer and length. */ 193 194 if Piobp = null () 195 then do; 196 call get_temp_segment_ (sub_name, iobp, code); 197 if code ^= 0 then call ERROR (code, 0, "Error getting temp segment for io buffer."); 198 199 tseg_allocated = "1"b; 200 iobl = sys_info$max_seg_size * 4; 201 end; 202 203 else do; 204 iobp = Piobp; 205 iobl = Piobl; 206 end; 207 208 /* Do the control phase dialogue with the Level 6. */ 209 210 call Read (code); 211 if code ^= 0 then call ERROR (code, 0, "Trying to read the first record from the L6."); 212 213 call Get_Chars (3, message_ptr, message_len, "0"b, code); 214 if code ^= 0 then call ERROR (code, 0, "Looking for ""OK?""."); 215 216 if message ^= "OK?" then call ERROR (10, 0, "Connection request was not ""OK?"", but: ^a.", message); 217 218 call Write ("OK", code); 219 if code ^= 0 then call ERROR (code, 0, "Trying to send ""OK""."); 220 221 call Read (code); 222 if code ^= 0 then call ERROR (code, 0, "Trying to read initiate request."); 223 224 call Process_Initiate_Request (); 225 226 call Open_File (); 227 228 call Make_Accept_Msg (accept_msg, accept_msg_len); 229 230 call Write (substr (accept_msg, 1, accept_msg_len), code); 231 /* Acceptor's yes answer. */ 232 if code ^= 0 then call ERROR (code, 0, "Trying to send acceptor's yes answer."); 233 234 /* Do the file transfer as specified in the control phase. */ 235 236 if file_info.direction = Coutput 237 then call Send_File (); 238 else call Receive_File (); 239 240 Pcode = 0; 241 242 RETURN: 243 call Cleanup_Handler (); 244 return; 245 246 Read: 247 proc (Pcode); 248 249 dcl Pcode fixed bin (35) parameter; 250 251 dcl n_read fixed bin (21); 252 dcl code fixed bin (35); 253 get_chars_done = "0"b; 254 255 if timeout_value > 0 then call timer_manager_$alarm_call (timeout_value, "10"b, read_timeout); 256 /* Relative microseconds. */ 257 258 call iox_$get_chars (l6_switchp, iobp, iobl, n_read, code); 259 get_chars_done = "1"b; /* Narrow an already small window. */ 260 261 if timeout_value > 0 then call timer_manager_$reset_alarm_call (read_timeout); 262 263 /*call ioa_("read : ""^a"", ^d chars.",substr(iobp->io_buf,1,n_read),n_read); DEBUG*/ 264 if code = 0 | code = error_table_$short_record 265 then do; 266 current_iob_length = n_read; 267 current_iob_position = 0; 268 end; 269 270 else do; 271 current_iob_length = 0; 272 current_iob_position = 0; 273 end; 274 275 Pcode = code; 276 277 end Read; 278 279 Write: 280 proc (Poutput, Pcode); 281 282 dcl Poutput char (*) parameter; 283 dcl Pcode fixed bin (35) parameter; 284 285 dcl code fixed bin (35); 286 287 /*call ioa_("write: ""^a"", ^d chars.",Poutput,length(Poutput)); DEBUG*/ 288 put_chars_done = "0"b; 289 290 if timeout_value > 0 then call timer_manager_$alarm_call (timeout_value, "10"b, write_timeout); 291 /* Relative microseconds. */ 292 293 call iox_$put_chars (l6_switchp, addr (Poutput), length (Poutput), code); 294 put_chars_done = "1"b; /* Narrow an already small window. */ 295 296 if timeout_value > 0 then call timer_manager_$reset_alarm_call (write_timeout); 297 298 Pcode = code; 299 300 end Write; 301 302 Read_Timeout: 303 proc (Pmc_ptr, Pname); 304 305 dcl Pmc_ptr ptr; 306 dcl Pname char (*); 307 308 if get_chars_done then return; /* Hit the window. */ 309 310 call ERROR (720, 2, "Timeout on read from the L6."); 311 312 end Read_Timeout; 313 314 Write_Timeout: 315 proc (Pmc_ptr, Pname); 316 317 dcl Pmc_ptr ptr; 318 dcl Pname char (*); 319 320 if put_chars_done then return; /* Hit the window. */ 321 322 call ERROR (721, 0, "Timeout on write to the L6."); 323 324 end Write_Timeout; 325 326 ERROR: 327 proc () options (variable, non_quick); 328 329 dcl based_code fixed bin (35) based; 330 dcl based_action fixed bin based; 331 dcl caller_code fixed bin (35); 332 dcl code fixed bin (35); 333 dcl action fixed bin; 334 dcl arg_list_ptr ptr; 335 dcl nargs fixed bin; 336 dcl err_msg char (256); 337 dcl err_msg_len fixed bin; 338 dcl err_msg_count pic "99"; 339 dcl arg_ptr ptr; 340 dcl arg_len fixed bin (21); 341 342 dcl 1 reject, 343 2 header char (6) unaligned, 344 2 err_num pic "zzzzzzzzzz9" unaligned, 345 2 separator char (2) unaligned, 346 2 err_msg char (72) unaligned; 347 348 dcl cu_$arg_list_ptr entry (ptr); 349 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); 350 dcl ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1), bit (1)); 351 dcl ioa_$rsnpnnl entry options (variable); 352 dcl cu_$arg_count entry (fixed bin); 353 354 call cu_$arg_list_ptr (arg_list_ptr); 355 356 call cu_$arg_ptr (1, arg_ptr, arg_len, code); 357 if code ^= 0 then goto FATAL; 358 359 caller_code = arg_ptr -> based_code; 360 361 call cu_$arg_ptr (2, arg_ptr, arg_len, code); 362 if code ^= 0 then goto FATAL; 363 364 action = arg_ptr -> based_action; 365 366 call cu_$arg_count (nargs); 367 368 if nargs > 2 369 then call ioa_$general_rs (arg_list_ptr, 3, 4, err_msg, err_msg_len, "0"b, "0"b); 370 else call ioa_$rsnpnnl ("Error number: ^d.", err_msg, err_msg_len, caller_code); 371 372 if error_flag 373 then call ioa_$ioa_switch (error_switchp, "^/^a Code = ^d.", substr (err_msg, 1, err_msg_len), caller_code); 374 375 if action = 0 then ; /* All done. */ 376 377 else if action = 1 378 then do; /* Send a rejection message. */ 379 reject.header = "8091&'"; 380 reject.err_num = caller_code; 381 reject.separator = ": "; 382 reject.err_msg = substr (err_msg, 1, length (reject.err_msg)); 383 384 call Write (string (reject), code); 385 end; 386 387 else if action = 2 388 then do; /* Send a file transfer error record. */ 389 if err_msg_len > 99 then err_msg_len = 99; 390 391 err_msg_count = err_msg_len; 392 393 call Write ("CU" || err_msg_count || substr (err_msg, 1, err_msg_len) || "R", code); 394 end; 395 396 else goto FATAL; 397 398 Pcode = caller_code; 399 goto RETURN; 400 401 FATAL: 402 Pcode = code; 403 goto RETURN; 404 405 end ERROR; 406 407 Process_Initiate_Request: 408 proc (); 409 410 dcl request_length fixed bin; 411 dcl file_name_length fixed bin (21); 412 dcl field_ptr ptr; 413 dcl field_len fixed bin (21); 414 dcl field char (field_len) based (field_ptr); 415 416 417 call Get_Chars (1, field_ptr, field_len, "0"b, code); 418 if field ^= " " | code ^= 0 then call ERROR (code, 1, "Character was ""^a"" instead of "" "".", field); 419 420 call Get_Chars (3, field_ptr, field_len, "0"b, code); 421 if code ^= 0 then call ERROR (code, 1, "Error getting initiate request length."); 422 423 request_length = cv_dec_check_ (field, code); 424 if code ^= 0 then call ERROR (code, 1, "Non-numeric initiate request length: ^a.", field); 425 426 call Get_Chars (1, field_ptr, field_len, "0"b, code); 427 if field ^= " " | code ^= 0 then call ERROR (code, 1, "Character was ""^a"" instead of "" "".", field); 428 429 call Get_Chars (1, field_ptr, field_len, "0"b, code); 430 if code ^= 0 then call ERROR (code, 1, "Error getting the direction."); 431 432 if field = "I" then file_info.direction = Coutput; 433 434 else if field = "O" then file_info.direction = Cinput; 435 436 else call ERROR (code, 1, "Unknown direction: ^a.", field); 437 438 call Get_Chars (1, field_ptr, field_len, "0"b, code); 439 if (field ^= "!" & field ^= """") | code ^= 0 440 then call ERROR (code, 1, "Character was ""^a"" instead of ""!"" or """".", field); 441 442 call Get_Chars (2, field_ptr, field_len, "0"b, code); 443 if code ^= 0 then call ERROR (code, 1, "Error getting name length."); 444 445 file_name_length = cv_dec_check_ (field, code); 446 if code ^= 0 then call ERROR (code, 1, "Non-numeric name length: ^a.", field); 447 448 call Get_Chars (file_name_length, field_ptr, field_len, "0"b, code); 449 if code ^= 0 then call ERROR (code, 1, "Error getting file name."); 450 451 file_info.name = field; 452 453 call Get_Chars (1, field_ptr, field_len, "0"b, code); 454 455 if code = error_table_$end_of_info then return; /* No attributes to process. */ 456 457 if field ^= "#" | code ^= 0 then call ERROR (code, 1, "Character was ""^a"" instead of ""#"".", field); 458 459 do while (code = 0); /* Process the attributes. */ 460 461 call Get_Chars (1, field_ptr, field_len, "0"b, code); 462 if code = 0 463 then do; /* Process an attribute indicator. */ 464 465 if field = "P" 466 then do; 467 call Get_Chars (1, field_ptr, field_len, "0"b, code); 468 if code ^= 0 then call ERROR (code, 1, "Error getting file type."); 469 470 if field = "D" | field = "R" | field = "F" then file_info.type = Crelative; 471 472 else if field = "S" then file_info.type = Csequential; 473 474 else if field = "I" then file_info.type = Cindexed; 475 476 else call ERROR (60, 1, "Unknown file type: ^a.", field); 477 end; 478 479 else if field = "Q" 480 then do; 481 call Get_Chars (1, field_ptr, field_len, "0"b, code); 482 if code ^= 0 then call ERROR (code, 1, "Error getting data type."); 483 484 if field = "8" then file_info.data_type = Cbinary; 485 486 else if field = "A" then file_info.data_type = Cascii; 487 488 else if field = "B" then file_info.data_type = Cbcd; 489 490 else call ERROR (61, 1, "Unknown data type: ^a.", field); 491 end; 492 493 else if field = "R" 494 then do; 495 call Get_Chars (4, field_ptr, field_len, "0"b, code); 496 if code ^= 0 then call ERROR (code, 1, "Error getting record size."); 497 498 file_info.rec_size = cv_dec_check_ (field, code); 499 if code ^= 0 then call ERROR (code, 1, "Non-numeric record size: ^a.", field); 500 end; 501 502 else if field = "S" 503 then do; 504 call Get_Chars (5, field_ptr, field_len, "0"b, code); 505 if code ^= 0 then call ERROR (code, 1, "Error getting starting record."); 506 507 file_info.starting_rec = cv_dec_check_ (field, code); 508 if code ^= 0 then call ERROR (code, 1, "Non-numeric starting record: ^a.", field); 509 end; 510 511 else if field = "T" 512 then do; 513 514 call Get_Chars (1, field_ptr, field_len, "0"b, code); 515 if code ^= 0 then call ERROR (code, 1, "Error getting file access."); 516 517 if field = "N" then file_info.access = Cnew; 518 519 else if field = "O" then file_info.access = Cold; 520 521 else call ERROR (62, 1, "Unknown file access code: ^a.", field); 522 end; 523 524 else if field = "U" 525 then do; 526 call Get_Chars (3, field_ptr, field_len, "0"b, code); 527 if code ^= 0 then call ERROR (code, 1, "Error getting key length."); 528 529 file_info.key_len = cv_dec_check_ (field, code); 530 if code ^= 0 then call ERROR (code, 1, "Non-numeric key length: ^a.", field); 531 end; 532 533 else if field = "V" 534 then do; 535 call Get_Chars (4, field_ptr, field_len, "0"b, code); 536 if code ^= 0 then call ERROR (code, 1, "Error getting key offset."); 537 538 file_info.key_off = cv_dec_check_ (field, code); 539 if code ^= 0 then call ERROR (code, 1, "Non-numeric key offset: ^a.", field); 540 end; 541 542 else if field = "W" 543 then do; 544 call Get_Chars (2, field_ptr, field_len, "0"b, code); 545 if code ^= 0 then call ERROR (code, 1, "Error getting percent fill."); 546 547 file_info.percent_fill = cv_dec_check_ (field, code); 548 if code ^= 0 then call ERROR (code, 1, "Non-numeric percent fill: ^a.", field); 549 end; 550 551 else if field = "X" 552 then do; 553 call Get_Chars (1, field_ptr, field_len, "0"b, code); 554 if code ^= 0 then call ERROR (code, 1, "Error getting key type."); 555 556 if field = "8" then file_info.key_type = Cbinary; 557 558 else if field = "A" then file_info.key_type = Cascii; 559 560 else if field = "B" then file_info.key_type = Cbcd; 561 562 else call ERROR (62, 1, "Unknown key type: ^a", field); 563 end; 564 565 else if field = "Y" 566 then do; 567 call Get_Chars (5, field_ptr, field_len, "0"b, code); 568 if code ^= 0 then call ERROR (code, 1, "Error getting ci size."); 569 570 file_info.ci_size = cv_dec_check_ (field, code); 571 if code ^= 0 then call ERROR (code, 1, "Non-numeric ci size: ^a.", field); 572 end; 573 574 else if field = "Z" 575 then do; 576 call Get_Chars (5, field_ptr, field_len, "0"b, code); 577 if code ^= 0 then call ERROR (code, 1, "Error getting file size."); 578 579 file_info.size = cv_dec_check_ (field, code); 580 if code ^= 0 then call ERROR (code, 1, "Non-numeric file size: ^a.", field); 581 end; 582 583 else if field = "[" 584 then do; 585 call Get_Chars (2, field_ptr, field_len, "0"b, code); 586 if code ^= 0 then call ERROR (code, 1, "Error getting initiators file count."); 587 588 file_info.init_file_count = cv_dec_check_ (field, code); 589 if code ^= 0 then call ERROR (code, 1, "Non-numeric initiators file count: ^a.", field); 590 end; 591 592 else if field = "\" 593 then do; 594 call Get_Chars (2, field_ptr, field_len, "0"b, code); 595 if code ^= 0 then call ERROR (code, 1, "Error getting acceptors file count."); 596 597 file_info.accept_file_count = cv_dec_check_ (field, code); 598 if code ^= 0 then call ERROR (code, 1, "Non-numeric acceptors file count: ^a.", field); 599 end; 600 601 else call ERROR (150, 1, "Unrecognized attribute indicator ""^a"".", field); 602 603 end; /* Process an attribute indicator. */ 604 end; /* Process the attributes. */ 605 end Process_Initiate_Request; 606 607 Make_Accept_Msg: 608 proc (Pmsg, Pmsglen); 609 610 dcl Pmsg char (*) parameter; 611 dcl Pmsglen fixed bin (21) parameter; 612 613 dcl Cfile_type (3) char (1) internal static options (constant) init ("S", "R", "I"); 614 dcl Cdata_type (3) char (1) internal static options (constant) init ("A", "8", "B"); 615 616 if file_info.direction = Cinput 617 then do; 618 Pmsg = "8005$"; 619 Pmsglen = 5; 620 end; 621 622 else do; 623 Pmsg = "8010$#P" || Cfile_type (file_info.type) || "Q" || Cdata_type (file_info.data_type); 624 Pmsglen = 10; 625 end; 626 627 end Make_Accept_Msg; 628 629 Get_Chars: 630 proc (Pnum, Pptr, Plen, Ptu, Pcode); 631 632 dcl Pnum fixed bin (21) parameter; 633 dcl Pptr ptr parameter; 634 dcl Plen fixed bin (21) parameter; 635 dcl Ptu bit (1) parameter; 636 dcl Pcode fixed bin (35) parameter; 637 638 dcl num_left fixed bin (21); 639 dcl num_to_get fixed bin (21); 640 dcl char_ptr ptr; 641 dcl char_len fixed bin (21); 642 dcl char_string char (char_len) based (char_ptr); 643 644 if current_iob_position + Pnum <= current_iob_length 645 then do; 646 Pptr = addr (iobp -> io_buf_array (current_iob_position + 1)); 647 Plen = Pnum; 648 Pcode = 0; 649 650 current_iob_position = current_iob_position + Pnum; 651 end; 652 653 else do; 654 if ^Ptu 655 then do; /* Should have been all in one record. */ 656 Pptr = null (); 657 Plen = 0; 658 Pcode = error_table_$end_of_info; 659 end; 660 661 else do; /* Data continues in the next transmission unit. */ 662 663 /* 664* First save what is left in this transmission unit in a global string, 665* but special case when there is nothing left in the current transmission 666* unit (this is also the case the first time when no transmission unit 667* has been gotten). This code assumes that data is never split across 668* more than two transmission units!! 669**/ 670 671 num_left = current_iob_length - current_iob_position; 672 num_to_get = Pnum - num_left; 673 674 if num_left ^= 0 675 then global_string = substr (iobp -> io_buf, current_iob_position + 1, num_left); 676 677 call Get_Next_Tu (); 678 679 call Get_Chars (num_to_get, char_ptr, char_len, "0"b, code); 680 if code ^= 0 then call ERROR (code, 2, "Error getting data from TU number: ^d.", current_tusn); 681 682 if num_left = 0 683 then do; 684 Pptr = char_ptr; 685 Plen = char_len; 686 Pcode = 0; 687 end; 688 689 else do; 690 global_string = global_string || char_string; 691 692 Pptr = addrel (addr (global_string), 1); 693 /* Since global string is varying. */ 694 Plen = length (global_string); 695 Pcode = 0; 696 end; 697 end; 698 end; 699 700 return; 701 702 Get_Next_Tu: 703 proc (); 704 705 dcl code fixed bin (35); 706 dcl ascii_rsn pic "99999"; 707 dcl tusn fixed bin; 708 dcl field_ptr ptr; 709 dcl field_len fixed bin (21); 710 dcl field char (field_len) based (field_ptr); 711 712 ascii_rsn = last_successful_rsn; 713 714 call Write ("P" || ascii_rsn, code); 715 if code ^= 0 then call ERROR (code, 2, "Error sending prompt ^a.", "P" || ascii_rsn); 716 717 call Read (code); 718 if code ^= 0 then call ERROR (code, 2, "Reading transmission unit ^d.", current_tusn + 1); 719 720 call Get_Chars (1, field_ptr, field_len, "0"b, code); 721 722 tusn = cv_dec_check_ (field, code); 723 if code ^= 0 then call ERROR (code, 2, "Non-numeric tusn: ^a.", field); 724 725 if tusn ^= current_tusn then call ERROR (40, "TUSN out of sequence. Expected = ^d, New = ^d.", current_tusn, tusn); 726 727 current_tusn = mod (current_tusn + 1, 10); 728 729 end Get_Next_Tu; 730 end Get_Chars; 731 732 Init_File_Info: 733 proc (); 734 735 file_info.file_ptr = null (); 736 file_info.attached = "0"b; 737 file_info.open = "0"b; 738 739 file_info.direction = Cuninitialized; 740 file_info.name = ""; 741 file_info.type = Cuninitialized; 742 file_info.data_type = Cuninitialized; 743 file_info.rec_size = Cuninitialized; 744 file_info.starting_rec = Cuninitialized; 745 file_info.access = Cuninitialized; 746 file_info.key_len = Cuninitialized; 747 file_info.key_off = Cuninitialized; 748 file_info.percent_fill = Cuninitialized; 749 file_info.key_type = Cuninitialized; 750 file_info.ci_size = Cuninitialized; 751 file_info.init_file_count = Cuninitialized; 752 file_info.accept_file_count = Cuninitialized; 753 754 end Init_File_Info; 755 756 Open_File: 757 proc (); 758 759 dcl code fixed bin (35); 760 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); 761 dcl dir_name char (168); 762 dcl entry_name char (32); 763 764 dcl 1 info like indx_info; 765 766 /* BEGIN include file: vfs_info.incl.pl1. */ 767 1 1 dcl 1 uns_info based (addr (info)), /* info structure for unstructured files */ 1 2 2 info_version fixed, /* (Input) must =1--only one version 1 3* currently supported */ 1 4 2 type fixed, /* =1 */ 1 5 2 end_pos fixed (34), /* length (bytes) not including header */ 1 6 2 flags aligned, 1 7 3 pad1 bit (2) unal, /* used for lock_status in other files */ 1 8 3 header_present bit (1) unal, /* on if file code is set */ 1 9 3 pad2 bit (33) unal, 1 10 2 header_id fixed (35); /* meaning is user defined */ 1 11 dcl 1 seq_info based (addr (info)), /* info structure for sequential files */ 1 12 2 info_version fixed, 1 13 2 type fixed, /* =2 */ 1 14 2 end_pos fixed (34), /* record count */ 1 15 2 flags aligned, 1 16 3 lock_status bit (2) unal, /* 0,1,2, or 3 to indicate not locked, 1 17* locked by (other,this,dead) process */ 1 18 3 pad bit (34) unal, 1 19 2 version fixed, /* end_pos valid only in latest version */ 1 20 2 action fixed; /* indicates if adjustment or rollback is needed */ 1 21 dcl 1 blk_info based (addr (info)), /* info structure for blocked files */ 1 22 2 info_version fixed, 1 23 2 type fixed, /* =3 */ 1 24 2 end_pos fixed (34), /* record count */ 1 25 2 flags aligned, 1 26 3 lock_status bit (2) unal, /* same as seq_info.= */ 1 27 3 pad bit (34) unal, 1 28 2 version fixed, /* only one currently supported */ 1 29 2 action fixed, /* non-zero if truncation in progress, else =0 */ 1 30 2 max_rec_len fixed (21), /* bytes--determines characteristiWc block size */ 1 31 2 pad fixed, /* not used at this time */ 1 32 2 time_last_modified fixed (71); /* time stamp for synchronization */ 1 33 dcl 1 indx_info based (addr (info)), /* info structure for indexed files */ 1 34 2 info_version fixed, 1 35 2 type fixed, /* =4 */ 1 36 2 records fixed (34), /* record count */ 1 37 2 flags aligned, 1 38 3 lock_status bit (2) unal, /* same as seq_info.= */ 1 39 3 pad bit (34) unal, 1 40 2 version_info aligned, 1 41 3 file_version fixed (17) unal, /* headers differ */ 1 42 3 program_version fixed (17) unal, /* may indicate bugs */ 1 43 2 action fixed, /* non-zero code indicates update in progress */ 1 44 2 non_null_recs fixed (34), /* count of allocated recs */ 1 45 2 record_bytes fixed (34), /* total record length */ 1 46 2 free_blocks fixed, /* available record blocks */ 1 47 2 index_height fixed, /* height of index tree (0 if empty) */ 1 48 2 nodes fixed, /* nodes being used in the index */ 1 49 2 key_bytes fixed (34), /* total length of keys */ 1 50 2 change_count fixed (35), /* bumped on each file modification */ 1 51 2 num_keys fixed (34), /* number of index entries */ 1 52 2 dup_keys fixed (34), /* 0 if all keys are distinct, else 1 for each dup */ 1 53 2 dup_key_bytes fixed (34), /* total bytes of duplicate keys */ 1 54 2 word (1) fixed; /* reserved for future use */ 1 55 dcl 1 vbl_info based (addr (info)), /* info structure for variable files */ 1 56 2 info_version fixed, 1 57 2 type fixed, /* =5 */ 1 58 2 end_pos fixed (34), /* logical end of file--not necessarily allocation count */ 1 59 2 flags aligned, 1 60 3 lock_status bit (2) unal, /* same as seq_info.= */ 1 61 3 pad bit (34) unal, 1 62 2 version fixed, /* only one currently supported */ 1 63 2 action fixed, /* same as in indexed files */ 1 64 2 first_nz fixed (34), /* position (numeric key) for first allocated record */ 1 65 2 last_nz fixed (34), /* last allocated record position */ 1 66 2 change_count fixed (35); /* used for synchronization */ 1 67 dcl vfs_version_1 static internal fixed init (1); 1 68 /* should be used in 1 69* assignments to info_version */ 768 769 /* END include file: vfs_info.incl.pl1. */ 770 771 dcl vfile_status_ entry (char (*), char (*), ptr, fixed bin (35)); 772 773 file_info.name = rtrim (target_dir) || ">" || file_info.name; 774 if substr (file_info.name, 1, 2) = ">>" then file_info.name = substr (file_info.name, 2); 775 /* Fix absolute path case. */ 776 777 if file_info.direction = Coutput 778 then do; 779 call expand_pathname_ (file_info.name, dir_name, entry_name, code); 780 if code ^= 0 then call ERROR (code, 1, "Error expanding pathname: ^a.", file_info.name); 781 782 info.info_version = vfs_version_1; 783 call vfile_status_ (dir_name, entry_name, addr (info), code); 784 if code ^= 0 then call ERROR (code, 1, "Error getting status of file for output: ^a.", file_info.name); 785 786 if info.type = 1 787 then do; /* An unstructured file. */ 788 if file_info.type = Cuninitialized then file_info.type = Csequential; 789 if file_info.data_type = Cuninitialized then file_info.data_type = Cascii; 790 791 if (file_info.type ^= Csequential) & (file_info.data_type ^= Cascii) 792 then call ERROR (500, 1, "^a is unstructured but L6 requested type = ^d, data_type = ^d.", 793 file_info.name, file_info.type, file_info.data_type); 794 end; 795 796 else if info.type = 2 797 then do; /* A sequential file. */ 798 if file_info.type = Cuninitialized then file_info.type = Csequential; 799 if file_info.data_type = Cuninitialized then file_info.data_type = Cbinary; 800 801 if (file_info.type ^= Csequential) & (file_info.data_type ^= Cbinary) 802 then call ERROR (501, 1, "^a is sequential but L6 requested type = ^d, data_type = ^d.", 803 file_info.name, file_info.type, file_info.data_type); 804 end; 805 806 else call ERROR (502, 1, "Transfer of file type: ^d, is not implemented.", info.type); 807 end; 808 809 else do; 810 if file_info.type = Cuninitialized then file_info.type = Csequential; 811 if file_info.data_type = Cuninitialized then file_info.data_type = Cascii; 812 if file_info.key_type = Cuninitialized then file_info.key_type = Cascii; 813 end; 814 815 if file_info.starting_rec = Cuninitialized then file_info.starting_rec = 0; 816 817 if file_info.type = Cindexed & (file_info.key_len = Cuninitialized | file_info.key_off = Cuninitialized) 818 then call ERROR (70, 1, "An indexed file was specified without a key length or offset."); 819 820 call iox_$attach_name (l6_file_switch, file_info.file_ptr, "vfile_ " || file_info.name, null (), code); 821 if code ^= 0 then call ERROR (code, 1, "Error attaching file: ^a.", file_info.name); 822 823 file_info.attached = "1"b; 824 825 if file_info.type = Csequential 826 then do; 827 if file_info.data_type = Cascii 828 then do; 829 if file_info.direction = Coutput 830 then call iox_$open (file_info.file_ptr, 1, "0"b, code); 831 /* Stream input */ 832 else call iox_$open (file_info.file_ptr, 2, "0"b, code); 833 /* Stream output */ 834 end; 835 836 else do; 837 if file_info.direction = Coutput 838 then call iox_$open (file_info.file_ptr, 4, "0"b, code); 839 /* Sequential input */ 840 else call iox_$open (file_info.file_ptr, 5, "0"b, code); 841 /* Sequential output */ 842 end; 843 end; 844 845 else call ERROR (327, 1, "Relative or indexed files are not supported: ^a.", file_info.name); 846 847 if code ^= 0 then call ERROR (code, 1, "Opening file: ^a.", file_info.name); 848 849 file_info.open = "1"b; 850 851 if file_info.starting_rec > 0 852 then do; 853 call iox_$position (file_info.file_ptr, 0, file_info.starting_rec, code); 854 if code ^= 0 855 then call ERROR (code, 1, "Error positioning file: ^a to record ^d.", file_info.name, 856 file_info.starting_rec); 857 end; 858 859 end Open_File; 860 861 Receive_File: 862 proc (); 863 864 dcl code fixed bin (35); 865 dcl eof bit (1); 866 dcl next_char_ptr ptr; 867 dcl next_char_len fixed bin (21); 868 dcl next_char char (next_char_len) based (next_char_ptr); 869 dcl last_prompt pic "99999"; 870 dcl strange_case_char char (1); 871 872 if user_flag then call ioa_$ioa_switch_nnl (user_switchp, "Transfer of file from L6 to ^a is -- ", file_info.name); 873 874 eof = "0"b; 875 strange_case_char = ""; 876 877 do while (^eof); 878 879 data_buf = ""; 880 881 if strange_case_char = "" 882 then do; 883 call Get_Chars (1, next_char_ptr, next_char_len, "1"b, code); 884 if code ^= 0 then call ERROR (code, 2, "Getting first character of record ^d.", current_rsn); 885 end; 886 887 else do; 888 next_char_ptr = addr (strange_case_char); 889 next_char_len = 1; 890 end; 891 892 if next_char = "8" | next_char = "A" | next_char = "B" then call Data_Record (strange_case_char); 893 894 else if next_char = "C" then call Control_Record (); 895 896 else if next_char = "E" then eof = "1"b; 897 898 else call ERROR (10, 2, "Unexpected media code: ^a in record ^d.", next_char, current_rsn); 899 900 if ^eof 901 then do; 902 call Write_Record (); 903 last_successful_rsn = current_rsn; 904 current_rsn = current_rsn + 1; 905 end; 906 907 else do; /* Finish the control phase dialogue. */ 908 last_prompt = last_successful_rsn + 1; 909 call Write ("P" || last_prompt, code); 910 if code ^= 0 then call ERROR (code, 0, "Error writing last prompt ^a.", "P" || last_prompt); 911 end; 912 end; 913 914 if user_flag then call ioa_$ioa_switch (user_switchp, "completed."); 915 916 return; 917 918 Control_Record: 919 proc (); 920 call ERROR (0, 0, substr (iobp -> io_buf, 1, current_iob_length)); 921 end Control_Record; 922 923 Data_Record: 924 proc (Pchar); 925 926 dcl Pchar char (1); 927 928 dcl end_of_record bit (1); 929 930 call Check_Rsn (); 931 932 end_of_record = "0"b; 933 Pchar = ""; 934 935 do while (^end_of_record); 936 937 call Get_Chars (1, next_char_ptr, next_char_len, "1"b, code); 938 if code ^= 0 then call ERROR (code, 2, "Error getting record segment header character."); 939 940 if next_char = "U" then call Process_Data ("0"b); 941 942 else if next_char = "P" then call Process_Data ("1"b); 943 944 else if next_char = "R" then end_of_record = "1"b; 945 946 /* Strange, inconsistent stuff. It might be a "E" or an "A" if the previous record ended the TU. */ 947 948 else do; 949 end_of_record = "1"b; 950 Pchar = next_char; 951 end; 952 953 end; 954 955 end Data_Record; 956 957 Check_Rsn: 958 proc (); 959 960 dcl ascii_rsn char (ascii_rsn_len) based (ascii_rsn_ptr); 961 dcl ascii_rsn_len fixed bin (21); 962 dcl ascii_rsn_ptr ptr; 963 dcl rsn fixed bin; 964 965 call Get_Chars (5, ascii_rsn_ptr, ascii_rsn_len, "1"b, code); 966 if code ^= 0 then call ERROR (code, 2, "Error getting record sequence number ^d.", current_rsn); 967 968 rsn = cv_dec_check_ (ascii_rsn, code); 969 if code ^= 0 then call ERROR (code, 2, "Non-numeric RSN: ^a.", ascii_rsn); 970 971 if rsn ^= current_rsn then call ERROR (30, 2, "RSN out of sequence. Expected = ^d, New = ^d.", current_rsn, rsn); 972 973 end Check_Rsn; 974 975 Process_Data: 976 proc (Ppacked); 977 978 dcl Ppacked bit (1) parameter; 979 980 dcl data_ptr ptr; 981 dcl data_len fixed bin (21); 982 dcl data char (data_len) based (data_ptr); 983 dcl data_count_ptr ptr; 984 dcl data_count_len fixed bin (21); 985 dcl data_count char (data_count_len) based (data_count_ptr); 986 dcl count fixed bin (21); 987 988 call Get_Chars (2, data_count_ptr, data_count_len, "1"b, code); 989 if code ^= 0 then call ERROR (code, 2, "Error getting data count for unpacked data in record: ^d.", current_rsn); 990 991 count = cv_dec_check_ (data_count, code); 992 if code ^= 0 then call ERROR (code, 2, "Non-numeric unpacked data count: ^a.", data_count); 993 994 if ^Ppacked 995 then do; 996 call Get_Chars (count, data_ptr, data_len, "1"b, code); 997 if code ^= 0 then call ERROR (code, 2, "Error getting unpacked data for record: ^d.", current_rsn); 998 999 data_buf = data_buf || data; 1000 end; 1001 1002 else do; 1003 call Get_Chars (1, data_ptr, data_len, "1"b, code); 1004 if code ^= 0 then call ERROR (code, 2, "Error getting packed character in record: ^d.", current_rsn); 1005 1006 data_buf = data_buf || copy (data, count); 1007 end; 1008 1009 end Process_Data; 1010 1011 Write_Record: 1012 proc (); 1013 dcl code fixed bin (35); 1014 dcl char_idx fixed bin; 1015 dcl binary_data_buf (256) bit (36) aligned; 1016 dcl bdbp ptr; 1017 1018 if file_info.data_type = Cascii & file_info.type = Csequential 1019 then do; 1020 data_buf = data_buf || Cnew_line; 1021 call iox_$put_chars (file_info.file_ptr, addrel (addr (data_buf), 1), length (data_buf), code); 1022 end; 1023 1024 else if file_info.data_type = Cbinary & file_info.type = Csequential 1025 then do; 1026 bdbp = addr (binary_data_buf); 1027 bdbp -> binary_data.num_sextets = length (data_buf); 1028 1029 do char_idx = 1 to bdbp -> binary_data.num_sextets; 1030 if substr (data_buf, char_idx, 1) >= " " & substr (data_buf, char_idx, 1) <= "_" 1031 then bdbp -> binary_data.sextets (char_idx) = 1032 rank (substr (data_buf, char_idx, 1)) - rank (" "); 1033 else call ERROR (101, 2, 1034 "Invalid character in binary transfer: ^a. char index = ^d, rec no = ^d.", 1035 substr (data_buf, char_idx, 1), char_idx, current_rsn); 1036 end; 1037 1038 call iox_$write_record (file_info.file_ptr, bdbp, currentsize (bdbp -> binary_data) * 4, code); 1039 end; 1040 1041 else call ERROR (100, 2, "Unsupported data type (^d) or file type (^d).", file_info.data_type, file_info.type); 1042 1043 if code ^= 0 then call ERROR (code, 2, "Error writing data in record ^d.", current_rsn); 1044 1045 return; 1046 1047 end Write_Record; 1048 end Receive_File; 1049 1050 Send_File: 1051 proc (); 1052 1053 dcl rec_buf char (1024) aligned; 1054 dcl rec_buf_len fixed bin (21); 1055 dcl eof bit (1); 1056 dcl last_prompt_no pic "99999"; 1057 dcl last_prompt_ptr ptr; 1058 dcl last_prompt_len fixed bin (21); 1059 dcl last_prompt char (last_prompt_len) based (last_prompt_ptr); 1060 1061 if user_flag then call ioa_$ioa_switch_nnl (user_switchp, "Transfer of ^a to L6 is -- ", file_info.name); 1062 1063 eof = "0"b; 1064 do while (^eof); 1065 1066 if file_info.type = Csequential 1067 then do; 1068 if file_info.data_type = Cascii 1069 then call iox_$get_line (file_info.file_ptr, addr (rec_buf), length (rec_buf), rec_buf_len, 1070 code); 1071 else call iox_$read_record (file_info.file_ptr, addr (rec_buf), length (rec_buf), rec_buf_len, 1072 code); 1073 end; 1074 1075 else call ERROR (600, 2, "Blocked or indexed files are not yet supported."); 1076 1077 if code = error_table_$end_of_info then eof = "1"b; 1078 1079 else if code = 0 1080 then do; 1081 call Put_Record (rec_buf, rec_buf_len); 1082 current_rsn = current_rsn + 1; 1083 end; 1084 1085 else call ERROR (code, 2, "Error reading record ^d.", current_rsn); 1086 end; 1087 1088 call Eof (); 1089 1090 last_prompt_no = last_successful_rsn + 1; 1091 1092 call Read (code); 1093 if code ^= 0 then call ERROR (code, 0, "Error reading last prompt."); 1094 1095 call Get_Chars (6, last_prompt_ptr, last_prompt_len, "0"b, code); 1096 if code ^= 0 then call ERROR (code, 0, "Error getting last prompt characters."); 1097 1098 if last_prompt ^= "P" || last_prompt_no 1099 then call ERROR (0b, 0b, "Last prompt, expected ^a, received ^a.", "P" || last_prompt_no, last_prompt); 1100 1101 if user_flag then call ioa_$ioa_switch (user_switchp, "completed."); 1102 1103 return; 1104 1105 Put_Record: 1106 proc (Prec, Plen); 1107 1108 dcl Prec char (*) aligned parameter; 1109 dcl Plen fixed bin (21) parameter; 1110 1111 dcl temp_rec char (1024) varying; 1112 dcl rsn pic "99999"; 1113 dcl rec_segment_len pic "99"; 1114 dcl rec_type char (1); 1115 dcl split_len fixed bin (21); 1116 dcl header char (6); 1117 dcl rec_segment_hdr char (3); 1118 dcl data_idx fixed bin (21); 1119 dcl data_left fixed bin (21); 1120 dcl data_count fixed bin (21); 1121 dcl left_in_tu fixed bin (21); 1122 dcl char_idx fixed bin; 1123 1124 if file_info.data_type = Cascii 1125 then do; 1126 temp_rec = substr (Prec, 1, Plen - 1); /* Get rid of the newline at the end. */ 1127 1128 if temp_rec = "" then temp_rec = " "; /* Special case null lines for L6. */ 1129 1130 rec_type = "A"; 1131 end; 1132 1133 else if file_info.data_type = Cbinary 1134 then do; /* Turn binary data into characters and continue. */ 1135 temp_rec = ""; 1136 1137 do char_idx = 1 to addr (Prec) -> binary_data.num_sextets; 1138 temp_rec = temp_rec || byte (addr (Prec) -> binary_data.sextets (char_idx) + rank (" ")); 1139 end; 1140 1141 rec_type = "8"; 1142 end; 1143 1144 else call ERROR (610, 2, "Record data type ^d is not supported.", file_info.data_type); 1145 1146 /* First put in the record header, assuming it will split, substr takes care of everything. */ 1147 1148 rsn = current_rsn; 1149 header = rec_type || rsn; 1150 left_in_tu = maxlength (internal_tu) - length (internal_tu); 1151 1152 split_len = min (left_in_tu, length (header)); 1153 internal_tu = internal_tu || substr (header, 1, split_len); 1154 left_in_tu = left_in_tu - split_len; 1155 1156 if left_in_tu = 0 1157 then do; 1158 call Send_Tu (); 1159 left_in_tu = maxlength (internal_tu) - length (internal_tu); 1160 end; 1161 1162 internal_tu = internal_tu || substr (header, split_len + 1); 1163 /* May be the null string. */ 1164 left_in_tu = left_in_tu - (length (header) - split_len); 1165 1166 /* The header is in, now loop for each record segment, consisting of 1167* "U" || count || data, where count is 2 characters. */ 1168 1169 data_count = length (temp_rec); 1170 data_idx = 1; 1171 data_left = length (temp_rec); 1172 1173 do while (data_left > 0); 1174 1175 if left_in_tu > 3 1176 then do; 1177 data_count = min (left_in_tu - 3, 99, data_left); 1178 rec_segment_len = data_count; /* Convert to characters. */ 1179 internal_tu = internal_tu || "U" || rec_segment_len || substr (temp_rec, data_idx, data_count); 1180 data_idx = data_idx + data_count; 1181 data_left = data_left - data_count; 1182 left_in_tu = left_in_tu - 3 - data_count; 1183 end; 1184 1185 else do; 1186 data_count = min (99, data_left); 1187 rec_segment_len = data_count; 1188 rec_segment_hdr = "U" || rec_segment_len; 1189 1190 split_len = left_in_tu; 1191 internal_tu = internal_tu || substr (rec_segment_hdr, 1, split_len); 1192 /* That filled the tu. */ 1193 1194 call Send_Tu (); 1195 left_in_tu = maxlength (internal_tu) - length (internal_tu); 1196 1197 internal_tu = 1198 internal_tu || substr (rec_segment_hdr, split_len + 1) 1199 || substr (temp_rec, data_idx, data_count); 1200 data_idx = data_idx + data_count; 1201 data_left = data_left - data_count; 1202 left_in_tu = left_in_tu - (length (rec_segment_hdr) - split_len) - data_count; 1203 end; 1204 end; /* do */ 1205 1206 if left_in_tu > 0 1207 then internal_tu = internal_tu || "R"; 1208 else do; 1209 call Send_Tu (); 1210 internal_tu = internal_tu || "R"; 1211 end; 1212 1213 return; 1214 1215 Eof: 1216 entry (); 1217 1218 if maxlength (internal_tu) = length (internal_tu) then call Send_Tu (); 1219 1220 internal_tu = internal_tu || "E"; 1221 1222 call Send_Tu (); 1223 1224 return; 1225 1226 Send_Tu: 1227 proc (); 1228 1229 dcl prompt_ptr ptr; 1230 dcl prompt_len fixed bin (21); 1231 dcl prompt char (prompt_len) based (prompt_ptr); 1232 dcl rsn fixed bin; 1233 dcl tusn pic "9"; 1234 dcl tu char (length (internal_tu)) based (addrel (addr (internal_tu), 1)); 1235 1236 call Read (code); 1237 if code ^= 0 then call ERROR (code, 2, "Error getting prompt from L6."); 1238 1239 call Get_Chars (6, prompt_ptr, prompt_len, "0"b, code); 1240 if code ^= 0 then call ERROR (code, 2, "Error getting prompt characters."); 1241 1242 if substr (prompt, 1, 1) = "P" 1243 then do; 1244 1245 rsn = cv_dec_check_ (substr (prompt, 2, 5), code); 1246 if code ^= 0 then call ERROR (code, 2, "Non-numeric rsn in prompt: ^a.", prompt); 1247 1248 if rsn ^= last_successful_rsn & rsn ^= last_successful_rsn + 1 1249 /* Special case for split records. */ 1250 then call ERROR (655, 2, "Records out of sequence. Prompt was ^d, Expected ^d.", rsn, 1251 last_successful_rsn); 1252 1253 call Write (tu, code); 1254 if code ^= 0 1255 then call ERROR (code, 2, "Error writing tu: ^d, with record: ^d.", current_tusn, current_rsn); 1256 1257 last_successful_rsn = current_rsn - 1; 1258 1259 current_tusn = mod (current_tusn + 1, 10); 1260 tusn = current_tusn; 1261 internal_tu = tusn; 1262 end; 1263 1264 else if substr (prompt, 1, 1) = "C" then call ERROR (0, 0, substr (iobp -> io_buf, 1, current_iob_length)); 1265 1266 else call ERROR (653, 2, "First character of prompt was ""^a"" instead of ""P"".", substr (prompt, 1, 1)); 1267 1268 1269 end Send_Tu; 1270 end Put_Record; 1271 end Send_File; 1272 1273 Cleanup_Handler: 1274 proc (); 1275 1276 dcl code fixed bin (35); 1277 1278 if tseg_allocated then call release_temp_segment_ (sub_name, iobp, code); 1279 1280 if file_info.file_ptr ^= null () 1281 then do; 1282 call iox_$close (file_info.file_ptr, code); 1283 call iox_$detach_iocb (file_info.file_ptr, code); 1284 end; 1285 1286 call timer_manager_$reset_alarm_call (read_timeout); 1287 call timer_manager_$reset_alarm_call (write_timeout); 1288 1289 end Cleanup_Handler; 1290 1291 end l6_ftf_; 1292 SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 11/18/82 1628.6 l6_ftf_.pl1 >dumps>old>recomp>l6_ftf_.pl1 768 1 07/19/79 1547.0 vfs_info.incl.pl1 >ldd>include>vfs_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. Cascii constant fixed bin(17,0) initial dcl 111 ref 486 558 789 791 811 812 827 1018 1068 1124 Cbcd constant fixed bin(17,0) initial dcl 113 ref 488 560 Cbinary constant fixed bin(17,0) initial dcl 112 ref 484 556 799 801 1024 1133 Cdata_type 000000 constant char(1) initial array unaligned dcl 614 ref 623 Cfile_type 000001 constant char(1) initial array unaligned dcl 613 ref 623 Cindexed constant fixed bin(17,0) initial dcl 116 ref 474 817 Cinput constant fixed bin(17,0) initial dcl 107 ref 434 616 Cnew constant fixed bin(17,0) initial dcl 109 ref 517 Cnew_line 014554 constant char(1) initial unaligned dcl 152 ref 1020 Cold constant fixed bin(17,0) initial dcl 110 ref 519 Coutput constant fixed bin(17,0) initial dcl 108 ref 236 432 777 829 837 Crelative constant fixed bin(17,0) initial dcl 115 ref 470 Csequential constant fixed bin(17,0) initial dcl 114 ref 472 788 791 798 801 810 825 1018 1024 1066 Cuninitialized constant fixed bin(17,0) initial dcl 117 ref 739 741 742 743 744 745 746 747 748 749 750 751 752 788 789 798 799 810 811 812 815 817 817 Pchar parameter char(1) unaligned dcl 926 set ref 923 933* 950* Pcode parameter fixed bin(35,0) dcl 636 in procedure "Get_Chars" set ref 629 648* 658* 686* 695* Pcode parameter fixed bin(35,0) dcl 18 in procedure "l6_ftf_" set ref 14 240* 398* 401* Pcode parameter fixed bin(35,0) dcl 249 in procedure "Read" set ref 246 275* Pcode parameter fixed bin(35,0) dcl 283 in procedure "Write" set ref 279 298* Peof parameter bit(1) unaligned dcl 18 ref 14 168 Peop parameter pointer dcl 18 ref 14 167 Piobl parameter fixed bin(21,0) dcl 18 ref 14 205 Piobp parameter pointer dcl 18 ref 14 194 204 Pl6swp parameter pointer dcl 18 ref 14 164 Plen parameter fixed bin(21,0) dcl 1109 in procedure "Put_Record" ref 1105 1126 Plen parameter fixed bin(21,0) dcl 634 in procedure "Get_Chars" set ref 629 647* 657* 685* 694* Pmc_ptr parameter pointer dcl 317 in procedure "Write_Timeout" ref 314 Pmc_ptr parameter pointer dcl 305 in procedure "Read_Timeout" ref 302 Pmsg parameter char unaligned dcl 610 set ref 607 618* 623* Pmsglen parameter fixed bin(21,0) dcl 611 set ref 607 619* 624* Pname parameter char unaligned dcl 306 in procedure "Read_Timeout" ref 302 Pname parameter char unaligned dcl 318 in procedure "Write_Timeout" ref 314 Pnum parameter fixed bin(21,0) dcl 632 ref 629 644 647 650 672 Poutput parameter char unaligned dcl 282 set ref 279 293 293 293 293 Ppacked parameter bit(1) unaligned dcl 978 ref 975 994 Pptr parameter pointer dcl 633 set ref 629 646* 656* 684* 692* Prec parameter char dcl 1108 set ref 1105 1126 1137 1138 Ptdir parameter char(168) unaligned dcl 18 ref 14 169 Ptu parameter bit(1) unaligned dcl 635 ref 629 654 Puof parameter bit(1) unaligned dcl 18 ref 14 166 Puop parameter pointer dcl 18 ref 14 165 accept_file_count 73 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 597* 752* accept_msg 001304 automatic char(256) unaligned dcl 147 set ref 228* 230 230 accept_msg_len 001404 automatic fixed bin(21,0) dcl 148 set ref 228* 230 230 access 63 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 517* 519* 745* action 000102 automatic fixed bin(17,0) dcl 333 set ref 364* 375 377 387 addr builtin function dcl 129 ref 293 293 646 692 783 783 888 1021 1021 1026 1068 1068 1071 1071 1137 1138 1253 addrel builtin function dcl 132 ref 692 1021 1021 1253 arg_len 000214 automatic fixed bin(21,0) dcl 340 set ref 356* 361* arg_list_ptr 000104 automatic pointer dcl 334 set ref 354* 368* arg_ptr 000212 automatic pointer dcl 339 set ref 356* 359 361* 364 ascii_rsn 000116 automatic picture(5) unaligned dcl 706 in procedure "Get_Next_Tu" set ref 712* 714 715 ascii_rsn based char unaligned dcl 960 in procedure "Check_Rsn" set ref 968* 969* ascii_rsn_len 002222 automatic fixed bin(21,0) dcl 961 set ref 965* 968 968 969 969 ascii_rsn_ptr 002224 automatic pointer dcl 962 set ref 965* 968 969 attached 2 000176 automatic bit(1) level 3 packed unaligned dcl 79 set ref 736* 823* based_action based fixed bin(17,0) dcl 330 ref 364 based_code based fixed bin(35,0) dcl 329 ref 359 bdbp 002656 automatic pointer dcl 1016 set ref 1026* 1027 1029 1030 1038* 1038 binary_data based structure level 1 dcl 101 set ref 1038 binary_data_buf 002256 automatic bit(36) array dcl 1015 set ref 1026 byte builtin function dcl 137 ref 1138 caller_code 000100 automatic fixed bin(35,0) dcl 331 set ref 359* 370* 372* 380 398 char_idx 002255 automatic fixed bin(17,0) dcl 1014 in procedure "Write_Record" set ref 1029* 1030 1030 1030 1030 1033 1033 1033* char_idx 003725 automatic fixed bin(17,0) dcl 1122 in procedure "Put_Record" set ref 1137* 1138* char_len 000104 automatic fixed bin(21,0) dcl 641 set ref 679* 685 690 char_ptr 000102 automatic pointer dcl 640 set ref 679* 684 690 char_string based char unaligned dcl 642 ref 690 ci_size 70 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 570* 750* cleanup 000102 stack reference condition dcl 55 ref 190 code 000100 automatic fixed bin(35,0) dcl 1276 in procedure "Cleanup_Handler" set ref 1278* 1282* 1283* code 000100 automatic fixed bin(35,0) dcl 285 in procedure "Write" set ref 293* 298 code 000114 automatic fixed bin(35,0) dcl 705 in procedure "Get_Next_Tu" set ref 714* 715 715* 717* 718 718* 720* 722* 723 723* code 002052 automatic fixed bin(35,0) dcl 759 in procedure "Open_File" set ref 779* 780 780* 783* 784 784* 820* 821 821* 829* 832* 837* 840* 847 847* 853* 854 854* code 000121 automatic fixed bin(35,0) dcl 64 in procedure "l6_ftf_" set ref 196* 197 197* 210* 211 211* 213* 214 214* 218* 219 219* 221* 222 222* 230* 232 232* 417* 418 418* 420* 421 421* 423* 424 424* 426* 427 427* 429* 430 430* 436* 438* 439 439* 442* 443 443* 445* 446 446* 448* 449 449* 453* 455 457 457* 459 461* 462 467* 468 468* 481* 482 482* 495* 496 496* 498* 499 499* 504* 505 505* 507* 508 508* 514* 515 515* 526* 527 527* 529* 530 530* 535* 536 536* 538* 539 539* 544* 545 545* 547* 548 548* 553* 554 554* 567* 568 568* 570* 571 571* 576* 577 577* 579* 580 580* 585* 586 586* 588* 589 589* 594* 595 595* 597* 598 598* 679* 680 680* 1068* 1071* 1077 1079 1085* 1092* 1093 1093* 1095* 1096 1096* 1236* 1237 1237* 1239* 1240 1240* 1245* 1246 1246* 1253* 1254 1254* code 000101 automatic fixed bin(35,0) dcl 252 in procedure "Read" set ref 258* 264 264 275 code 002254 automatic fixed bin(35,0) dcl 1013 in procedure "Write_Record" set ref 1021* 1038* 1043 1043* code 000101 automatic fixed bin(35,0) dcl 332 in procedure "ERROR" set ref 356* 357 361* 362 384* 393* 401 code 002164 automatic fixed bin(35,0) dcl 864 in procedure "Receive_File" set ref 883* 884 884* 909* 910 910* 937* 938 938* 965* 966 966* 968* 969 969* 988* 989 989* 991* 992 992* 996* 997 997* 1003* 1004 1004* copy builtin function dcl 131 ref 1006 count 002245 automatic fixed bin(21,0) dcl 986 set ref 991* 996* 1006 cu_$arg_count 000070 constant entry external dcl 352 ref 366 cu_$arg_list_ptr 000060 constant entry external dcl 348 ref 354 cu_$arg_ptr 000062 constant entry external dcl 349 ref 356 361 current_iob_length 000276 automatic fixed bin(21,0) dcl 139 set ref 175* 266* 271* 644 671 920 920 1264 1264 current_iob_position 000275 automatic fixed bin(21,0) dcl 138 set ref 174* 267* 272* 644 646 650* 650 671 674 current_rsn 000300 automatic fixed bin(17,0) dcl 141 set ref 172* 884* 898* 903 904* 904 966* 971 971* 989* 997* 1004* 1033* 1043* 1082* 1082 1085* 1148 1254* 1257 current_tusn 000277 automatic fixed bin(17,0) dcl 140 set ref 173* 680* 718 725 725* 727* 727 1254* 1259* 1259 1260 currentsize builtin function dcl 134 ref 1038 cv_dec_check_ 000024 constant entry external dcl 77 ref 423 445 498 507 529 538 547 570 579 588 597 722 968 991 1245 data based char unaligned dcl 982 ref 999 1006 data_buf 000703 automatic varying char(1024) dcl 144 set ref 177* 879* 999* 999 1006* 1006 1020* 1020 1021 1021 1021 1021 1027 1030 1030 1030 1033 1033 data_count based char unaligned dcl 985 in procedure "Process_Data" set ref 991* 992* data_count 003723 automatic fixed bin(21,0) dcl 1120 in procedure "Put_Record" set ref 1169* 1177* 1178 1179 1180 1181 1182 1186* 1187 1197 1200 1201 1202 data_count_len 002244 automatic fixed bin(21,0) dcl 984 set ref 988* 991 991 992 992 data_count_ptr 002242 automatic pointer dcl 983 set ref 988* 991 992 data_idx 003721 automatic fixed bin(21,0) dcl 1118 set ref 1170* 1179 1180* 1180 1197 1200* 1200 data_left 003722 automatic fixed bin(21,0) dcl 1119 set ref 1171* 1173 1177 1181* 1181 1186 1201* 1201 data_len 002240 automatic fixed bin(21,0) dcl 981 set ref 996* 999 1003* 1006 data_ptr 002236 automatic pointer dcl 980 set ref 996* 999 1003* 1006 data_type 60 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 484* 486* 488* 623 742* 789 789* 791 791* 799 799* 801 801* 811 811* 827 1018 1024 1041* 1068 1124 1133 1144* dir_name 002053 automatic char(168) unaligned dcl 761 set ref 779* 783* direction 4 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 236 432* 434* 616 739* 777 829 837 end_of_record 002212 automatic bit(1) unaligned dcl 928 set ref 932* 935 944* 949* entry_name 002125 automatic char(32) unaligned dcl 762 set ref 779* 783* eof 003271 automatic bit(1) unaligned dcl 1055 in procedure "Send_File" set ref 1063* 1064 1077* eof 002165 automatic bit(1) unaligned dcl 865 in procedure "Receive_File" set ref 874* 877 896* 900 err_msg 000107 automatic char(256) unaligned dcl 336 in procedure "ERROR" set ref 368* 370* 372 372 382 393 err_msg 4(27) 000215 automatic char(72) level 2 in structure "reject" packed unaligned dcl 342 in procedure "ERROR" set ref 382* 382 err_msg_count 000210 automatic picture(2) unaligned dcl 338 set ref 391* 393 err_msg_len 000207 automatic fixed bin(17,0) dcl 337 set ref 368* 370* 372 372 389 389* 391 393 err_num 1(18) 000215 automatic picture(11) level 2 packed unaligned dcl 342 set ref 380* error_flag 000117 automatic bit(1) unaligned dcl 60 set ref 168* 372 error_switchp 000114 automatic pointer dcl 58 set ref 167* 372* error_table_$end_of_info 000042 external static fixed bin(35,0) dcl 146 ref 455 658 1077 error_table_$short_record 000040 external static fixed bin(35,0) dcl 145 ref 264 expand_pathname_ 000072 constant entry external dcl 760 ref 779 field based char unaligned dcl 414 in procedure "Process_Initiate_Request" set ref 418 418* 423* 424* 427 427* 432 434 436* 439 439 439* 445* 446* 451 457 457* 465 470 470 470 472 474 476* 479 484 486 488 490* 493 498* 499* 502 507* 508* 511 517 519 521* 524 529* 530* 533 538* 539* 542 547* 548* 551 556 558 560 562* 565 570* 571* 574 579* 580* 583 588* 589* 592 597* 598* 601* field based char unaligned dcl 710 in procedure "Get_Next_Tu" set ref 722* 723* field_len 002026 automatic fixed bin(21,0) dcl 413 in procedure "Process_Initiate_Request" set ref 417* 418 418 418 420* 423 423 424 424 426* 427 427 427 429* 432 434 436 436 438* 439 439 439 439 442* 445 445 446 446 448* 451 453* 457 457 457 461* 465 467* 470 470 470 472 474 476 476 479 481* 484 486 488 490 490 493 495* 498 498 499 499 502 504* 507 507 508 508 511 514* 517 519 521 521 524 526* 529 529 530 530 533 535* 538 538 539 539 542 544* 547 547 548 548 551 553* 556 558 560 562 562 565 567* 570 570 571 571 574 576* 579 579 580 580 583 585* 588 588 589 589 592 594* 597 597 598 598 601 601 field_len 000124 automatic fixed bin(21,0) dcl 709 in procedure "Get_Next_Tu" set ref 720* 722 722 723 723 field_ptr 000122 automatic pointer dcl 708 in procedure "Get_Next_Tu" set ref 720* 722 723 field_ptr 002024 automatic pointer dcl 412 in procedure "Process_Initiate_Request" set ref 417* 418 418 420* 423 424 426* 427 427 429* 432 434 436 438* 439 439 439 442* 445 446 448* 451 453* 457 457 461* 465 467* 470 470 470 472 474 476 479 481* 484 486 488 490 493 495* 498 499 502 504* 507 508 511 514* 517 519 521 524 526* 529 530 533 535* 538 539 542 544* 547 548 551 553* 556 558 560 562 565 567* 570 571 574 576* 579 580 583 585* 588 589 592 594* 597 598 601 file_info 000176 automatic structure level 1 unaligned dcl 79 file_name_length 002023 automatic fixed bin(21,0) dcl 411 set ref 445* 448* file_ptr 000176 automatic pointer level 3 dcl 79 set ref 735* 820* 829* 832* 837* 840* 853* 1021* 1038* 1068* 1071* 1280 1282* 1283* get_chars_done 002010 automatic bit(1) unaligned dcl 160 set ref 182* 253* 259* 308 get_temp_segment_ 000010 constant entry external dcl 63 ref 196 global_string 000302 automatic varying char(1024) dcl 143 set ref 176* 674* 690* 690 692 694 header 003716 automatic char(6) unaligned dcl 1116 in procedure "Put_Record" set ref 1149* 1152 1153 1162 1164 header 000215 automatic char(6) level 2 in structure "reject" packed unaligned dcl 342 in procedure "ERROR" set ref 379* indx_info based structure level 1 unaligned dcl 1-33 info 002135 automatic structure level 1 unaligned dcl 764 set ref 783 783 info_version 002135 automatic fixed bin(17,0) level 2 dcl 764 set ref 782* init_file_count 72 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 588* 751* internal_tu 001405 automatic varying char(1000) dcl 149 set ref 178* 1150 1150 1153* 1153 1159 1159 1162* 1162 1179* 1179 1191* 1191 1195 1195 1197* 1197 1206* 1206 1210* 1210 1218 1218 1220* 1220 1253 1253 1253 1261* io_buf based char unaligned dcl 69 ref 674 920 920 1264 1264 io_buf_array based char(1) array unaligned dcl 68 set ref 646 ioa_$general_rs 000064 constant entry external dcl 350 ref 368 ioa_$ioa_switch 000050 constant entry external dcl 154 ref 372 914 1101 ioa_$ioa_switch_nnl 000052 constant entry external dcl 155 ref 872 1061 ioa_$rsnpnnl 000066 constant entry external dcl 351 ref 370 iobl 000122 automatic fixed bin(21,0) dcl 65 set ref 200* 205* 258* 674 920 920 1264 1264 iobp 000100 automatic pointer dcl 54 set ref 196* 204* 258* 646 674 920 920 1264 1264 1278* iox_$attach_name 000026 constant entry external dcl 121 ref 820 iox_$close 000034 constant entry external dcl 125 ref 1282 iox_$detach_iocb 000036 constant entry external dcl 126 ref 1283 iox_$get_chars 000014 constant entry external dcl 67 ref 258 iox_$get_line 000044 constant entry external dcl 150 ref 1068 iox_$open 000030 constant entry external dcl 123 ref 829 832 837 840 iox_$position 000032 constant entry external dcl 124 ref 853 iox_$put_chars 000016 constant entry external dcl 70 ref 293 1021 iox_$read_record 000046 constant entry external dcl 151 ref 1071 iox_$write_record 000020 constant entry external dcl 71 ref 1038 iox_info 000176 automatic structure level 2 unaligned dcl 79 key_len 64 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 529* 746* 817 key_off 65 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 538* 747* 817 key_type 67 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 556* 558* 560* 749* 812 812* l6_file_switch 000002 constant char(14) initial unaligned dcl 122 set ref 820* l6_switchp 000110 automatic pointer dcl 56 set ref 164* 258* 293* last_prompt based char unaligned dcl 1059 in procedure "Send_File" set ref 1098 1098* last_prompt 002172 automatic picture(5) unaligned dcl 869 in procedure "Receive_File" set ref 908* 909 910 last_prompt_len 003276 automatic fixed bin(21,0) dcl 1058 set ref 1095* 1098 1098 1098 last_prompt_no 003272 automatic picture(5) unaligned dcl 1056 set ref 1090* 1098 1098 last_prompt_ptr 003274 automatic pointer dcl 1057 set ref 1095* 1098 1098 last_successful_rsn 000301 automatic fixed bin(17,0) dcl 142 set ref 171* 712 903* 908 1090 1248 1248 1248* 1257* left_in_tu 003724 automatic fixed bin(21,0) dcl 1121 set ref 1150* 1152 1154* 1154 1156 1159* 1164* 1164 1175 1177 1182* 1182 1190 1195* 1202* 1202 1206 length builtin function dcl 73 ref 293 293 382 694 1021 1021 1027 1068 1068 1071 1071 1150 1152 1159 1164 1169 1171 1195 1202 1218 1253 1253 maxlength builtin function dcl 133 ref 1150 1159 1195 1218 message based char unaligned dcl 120 set ref 216 216* message_len 000274 automatic fixed bin(21,0) dcl 119 set ref 213* 216 216 216 message_ptr 000272 automatic pointer dcl 118 set ref 213* 216 216 min builtin function dcl 135 ref 1152 1177 1186 mod builtin function dcl 127 ref 727 1259 n_read 000100 automatic fixed bin(21,0) dcl 251 set ref 258* 266 name 5 000176 automatic char(168) level 2 packed unaligned dcl 79 set ref 451* 740* 773* 773 774 774* 774 779* 780* 784* 791* 801* 820 821* 845* 847* 854* 872* 1061* nargs 000106 automatic fixed bin(17,0) dcl 335 set ref 366* 368 next_char based char unaligned dcl 868 set ref 892 892 892 894 896 898* 940 942 944 950 next_char_len 002170 automatic fixed bin(21,0) dcl 867 set ref 883* 889* 892 892 892 894 896 898 898 937* 940 942 944 950 next_char_ptr 002166 automatic pointer dcl 866 set ref 883* 888* 892 892 892 894 896 898 937* 940 942 944 950 null builtin function dcl 74 ref 194 656 735 820 820 1280 num_left 000100 automatic fixed bin(21,0) dcl 638 set ref 671* 672 674 674 682 num_sextets based fixed bin(35,0) level 2 dcl 101 set ref 1027* 1029 1038 1137 num_to_get 000101 automatic fixed bin(21,0) dcl 639 set ref 672* 679* open 2(01) 000176 automatic bit(1) level 3 packed unaligned dcl 79 set ref 737* 849* percent_fill 66 000176 automatic fixed bin(17,0) level 2 dcl 79 set ref 547* 748* prompt based char unaligned dcl 1231 set ref 1242 1245 1245 1246* 1264 1266 1266 prompt_len 003740 automatic fixed bin(21,0) dcl 1230 set ref 1239* 1242 1245 1245 1246 1246 1264 1266 1266 prompt_ptr 003736 automatic pointer dcl 1229 set ref 1239* 1242 1245 1245 1246 1264 1266 1266 put_chars_done 002011 automatic bit(1) unaligned dcl 161 set ref 183* 288* 294* 320 rank builtin function dcl 136 ref 1030 1030 1138 read_timeout 002000 automatic entry variable dcl 158 set ref 180* 255* 261* 1286* rec_buf 002670 automatic char(1024) dcl 1053 set ref 1068 1068 1068 1068 1071 1071 1071 1071 1081* rec_buf_len 003270 automatic fixed bin(21,0) dcl 1054 set ref 1068* 1071* 1081* rec_segment_hdr 003720 automatic char(3) unaligned dcl 1117 set ref 1188* 1191 1197 1202 rec_segment_len 003712 automatic picture(2) unaligned dcl 1113 set ref 1178* 1179 1187* 1188 rec_size 61 000176 automatic fixed bin(21,0) level 2 dcl 79 set ref 498* 743* rec_type 003713 automatic char(1) unaligned dcl 1114 set ref 1130* 1141* 1149 reject 000215 automatic structure level 1 packed unaligned dcl 342 set ref 384 384 release_temp_segment_ 000022 constant entry external dcl 72 ref 1278 request_length 002022 automatic fixed bin(17,0) dcl 410 set ref 423* rsn 003741 automatic fixed bin(17,0) dcl 1232 in procedure "Send_Tu" set ref 1245* 1248 1248 1248* rsn 002226 automatic fixed bin(17,0) dcl 963 in procedure "Check_Rsn" set ref 968* 971 971* rsn 003710 automatic picture(5) unaligned dcl 1112 in procedure "Put_Record" set ref 1148* 1149 rtrim builtin function dcl 128 ref 773 separator 4(09) 000215 automatic char(2) level 2 packed unaligned dcl 342 set ref 381* sextets 1 based fixed bin(6,0) array level 2 packed unsigned unaligned dcl 101 set ref 1030* 1138 size 71 000176 automatic fixed bin(21,0) level 2 dcl 79 set ref 579* split_len 003714 automatic fixed bin(21,0) dcl 1115 set ref 1152* 1153 1154 1162 1164 1190* 1191 1197 1202 starting_rec 62 000176 automatic fixed bin(21,0) level 2 dcl 79 set ref 507* 744* 815 815* 851 853* 854* strange_case_char 002174 automatic char(1) unaligned dcl 870 set ref 875* 881 888 892* string builtin function dcl 130 ref 384 384 sub_name 000006 constant char(7) initial unaligned dcl 62 set ref 196* 1278* substr builtin function dcl 75 ref 230 230 372 372 382 393 674 774 774 920 920 1030 1030 1030 1033 1033 1126 1153 1162 1179 1191 1197 1197 1242 1245 1245 1264 1264 1264 1266 1266 sys_info$max_seg_size 000012 external static fixed bin(19,0) dcl 66 ref 200 target_dir 000123 automatic char(168) unaligned dcl 76 set ref 169* 773 temp_rec 003306 automatic varying char(1024) dcl 1111 set ref 1126* 1128 1128* 1135* 1138* 1138 1169 1171 1179 1197 timeout_value 002012 automatic fixed bin(71,0) dcl 162 set ref 184* 255 255* 261 290 290* 296 timer_manager_$alarm_call 000054 constant entry external dcl 156 ref 255 290 timer_manager_$reset_alarm_call 000056 constant entry external dcl 157 ref 261 296 1286 1287 tseg_allocated 000120 automatic bit(1) unaligned dcl 61 set ref 186* 199* 1278 tu based char unaligned dcl 1234 set ref 1253* tusn 000120 automatic fixed bin(17,0) dcl 707 in procedure "Get_Next_Tu" set ref 722* 725 725* tusn 003742 automatic picture(1) unaligned dcl 1233 in procedure "Send_Tu" set ref 1260* 1261 type 57 000176 automatic fixed bin(17,0) level 2 in structure "file_info" dcl 79 in procedure "l6_ftf_" set ref 470* 472* 474* 623 741* 788 788* 791 791* 798 798* 801 801* 810 810* 817 825 1018 1024 1041* 1066 type 1 002135 automatic fixed bin(17,0) level 2 in structure "info" dcl 764 in procedure "Open_File" set ref 786 796 806* user_flag 000116 automatic bit(1) unaligned dcl 59 set ref 166* 872 914 1061 1101 user_switchp 000112 automatic pointer dcl 57 set ref 165* 872* 914* 1061* 1101* vfile_status_ 000074 constant entry external dcl 771 ref 783 vfs_version_1 constant fixed bin(17,0) initial dcl 1-67 ref 782 write_timeout 002004 automatic entry variable dcl 159 set ref 181* 290* 296* 1287* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Crecord internal static fixed bin(17,0) initial dcl 106 Cstream internal static fixed bin(17,0) initial dcl 105 blk_info based structure level 1 unaligned dcl 1-21 seq_info based structure level 1 unaligned dcl 1-11 uns_info based structure level 1 unaligned dcl 1-1 vbl_info based structure level 1 unaligned dcl 1-55 NAMES DECLARED BY EXPLICIT CONTEXT. Check_Rsn 011512 constant entry internal dcl 957 ref 930 Cleanup_Handler 014406 constant entry internal dcl 1273 ref 190 242 Control_Record 011325 constant entry internal dcl 918 ref 894 Data_Record 011361 constant entry internal dcl 923 ref 892 ERROR 002700 constant entry internal dcl 326 ref 197 211 214 216 219 222 232 310 322 418 421 424 427 430 436 439 443 446 449 457 468 476 482 490 496 499 505 508 515 521 527 530 536 539 545 548 554 562 568 571 577 580 586 589 595 598 601 680 715 718 723 725 780 784 791 801 806 817 821 845 847 854 884 898 910 920 938 966 969 971 989 992 997 1004 1033 1041 1043 1075 1085 1093 1096 1098 1144 1237 1240 1246 1248 1254 1264 1266 Eof 013721 constant entry internal dcl 1215 ref 1088 FATAL 003303 constant label dcl 401 ref 357 362 387 Get_Chars 007112 constant entry internal dcl 629 ref 213 417 420 426 429 438 442 448 453 461 467 481 495 504 514 526 535 544 553 567 576 585 594 679 720 883 937 965 988 996 1003 1095 1239 Get_Next_Tu 007311 constant entry internal dcl 702 ref 677 Init_File_Info 007626 constant entry internal dcl 732 ref 188 Make_Accept_Msg 007023 constant entry internal dcl 607 ref 228 Open_File 007657 constant entry internal dcl 756 ref 226 Process_Data 011715 constant entry internal dcl 975 ref 940 942 Process_Initiate_Request 003312 constant entry internal dcl 407 ref 224 Put_Record 013203 constant entry internal dcl 1105 ref 1081 RETURN 002351 constant label dcl 242 ref 399 403 Read 002357 constant entry internal dcl 246 ref 210 221 717 1092 1236 Read_Timeout 002561 constant entry internal dcl 302 ref 180 Receive_File 010751 constant entry internal dcl 861 ref 238 Send_File 012554 constant entry internal dcl 1050 ref 236 Send_Tu 013737 constant entry internal dcl 1226 ref 1158 1194 1209 1218 1222 Write 002462 constant entry internal dcl 279 ref 218 230 384 393 714 909 1253 Write_Record 012254 constant entry internal dcl 1011 ref 902 Write_Timeout 002631 constant entry internal dcl 314 ref 181 l6_ftf_ 001605 constant entry external dcl 14 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 15214 15312 14612 15224 Length 15576 14612 76 250 401 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME l6_ftf_ 2736 external procedure is an external procedure. on unit on line 190 64 on unit Read 88 internal procedure is called by several nonquick procedures. Write 88 internal procedure is called during a stack extension. Read_Timeout 92 internal procedure is assigned to an entry variable. Write_Timeout 92 internal procedure is assigned to an entry variable. ERROR 226 internal procedure is called during a stack extension, is declared options(non_quick), and is declared options(variable). Process_Initiate_Request internal procedure shares stack frame of external procedure l6_ftf_. Make_Accept_Msg internal procedure shares stack frame of external procedure l6_ftf_. Get_Chars 158 internal procedure calls itself recursively. Get_Next_Tu internal procedure shares stack frame of internal procedure Get_Chars. Init_File_Info internal procedure shares stack frame of external procedure l6_ftf_. Open_File internal procedure shares stack frame of external procedure l6_ftf_. Receive_File internal procedure shares stack frame of external procedure l6_ftf_. Control_Record internal procedure shares stack frame of external procedure l6_ftf_. Data_Record internal procedure shares stack frame of external procedure l6_ftf_. Check_Rsn internal procedure shares stack frame of external procedure l6_ftf_. Process_Data internal procedure shares stack frame of external procedure l6_ftf_. Write_Record internal procedure shares stack frame of external procedure l6_ftf_. Send_File internal procedure shares stack frame of external procedure l6_ftf_. Put_Record internal procedure shares stack frame of external procedure l6_ftf_. Send_Tu internal procedure shares stack frame of external procedure l6_ftf_. Cleanup_Handler 80 internal procedure is called by several nonquick procedures. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME Cleanup_Handler 000100 code Cleanup_Handler ERROR 000100 caller_code ERROR 000101 code ERROR 000102 action ERROR 000104 arg_list_ptr ERROR 000106 nargs ERROR 000107 err_msg ERROR 000207 err_msg_len ERROR 000210 err_msg_count ERROR 000212 arg_ptr ERROR 000214 arg_len ERROR 000215 reject ERROR Get_Chars 000100 num_left Get_Chars 000101 num_to_get Get_Chars 000102 char_ptr Get_Chars 000104 char_len Get_Chars 000114 code Get_Next_Tu 000116 ascii_rsn Get_Next_Tu 000120 tusn Get_Next_Tu 000122 field_ptr Get_Next_Tu 000124 field_len Get_Next_Tu Read 000100 n_read Read 000101 code Read Write 000100 code Write l6_ftf_ 000100 iobp l6_ftf_ 000110 l6_switchp l6_ftf_ 000112 user_switchp l6_ftf_ 000114 error_switchp l6_ftf_ 000116 user_flag l6_ftf_ 000117 error_flag l6_ftf_ 000120 tseg_allocated l6_ftf_ 000121 code l6_ftf_ 000122 iobl l6_ftf_ 000123 target_dir l6_ftf_ 000176 file_info l6_ftf_ 000272 message_ptr l6_ftf_ 000274 message_len l6_ftf_ 000275 current_iob_position l6_ftf_ 000276 current_iob_length l6_ftf_ 000277 current_tusn l6_ftf_ 000300 current_rsn l6_ftf_ 000301 last_successful_rsn l6_ftf_ 000302 global_string l6_ftf_ 000703 data_buf l6_ftf_ 001304 accept_msg l6_ftf_ 001404 accept_msg_len l6_ftf_ 001405 internal_tu l6_ftf_ 002000 read_timeout l6_ftf_ 002004 write_timeout l6_ftf_ 002010 get_chars_done l6_ftf_ 002011 put_chars_done l6_ftf_ 002012 timeout_value l6_ftf_ 002022 request_length Process_Initiate_Request 002023 file_name_length Process_Initiate_Request 002024 field_ptr Process_Initiate_Request 002026 field_len Process_Initiate_Request 002052 code Open_File 002053 dir_name Open_File 002125 entry_name Open_File 002135 info Open_File 002164 code Receive_File 002165 eof Receive_File 002166 next_char_ptr Receive_File 002170 next_char_len Receive_File 002172 last_prompt Receive_File 002174 strange_case_char Receive_File 002212 end_of_record Data_Record 002222 ascii_rsn_len Check_Rsn 002224 ascii_rsn_ptr Check_Rsn 002226 rsn Check_Rsn 002236 data_ptr Process_Data 002240 data_len Process_Data 002242 data_count_ptr Process_Data 002244 data_count_len Process_Data 002245 count Process_Data 002254 code Write_Record 002255 char_idx Write_Record 002256 binary_data_buf Write_Record 002656 bdbp Write_Record 002670 rec_buf Send_File 003270 rec_buf_len Send_File 003271 eof Send_File 003272 last_prompt_no Send_File 003274 last_prompt_ptr Send_File 003276 last_prompt_len Send_File 003306 temp_rec Put_Record 003710 rsn Put_Record 003712 rec_segment_len Put_Record 003713 rec_type Put_Record 003714 split_len Put_Record 003716 header Put_Record 003720 rec_segment_hdr Put_Record 003721 data_idx Put_Record 003722 data_left Put_Record 003723 data_count Put_Record 003724 left_in_tu Put_Record 003725 char_idx Put_Record 003736 prompt_ptr Send_Tu 003740 prompt_len Send_Tu 003741 rsn Send_Tu 003742 tusn Send_Tu THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as alloc_cs cat_realloc_cs call_ext_out_desc call_ext_out call_int_this_desc call_int_this call_int_other_desc call_int_other return tra_ext mod_fx1 enable shorten_stack ext_entry int_entry int_entry_desc repeat set_cs_eis THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. cu_$arg_count cu_$arg_list_ptr cu_$arg_ptr cv_dec_check_ expand_pathname_ get_temp_segment_ ioa_$general_rs ioa_$ioa_switch ioa_$ioa_switch_nnl ioa_$rsnpnnl iox_$attach_name iox_$close iox_$detach_iocb iox_$get_chars iox_$get_line iox_$open iox_$position iox_$put_chars iox_$read_record iox_$write_record release_temp_segment_ timer_manager_$alarm_call timer_manager_$reset_alarm_call vfile_status_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$end_of_info error_table_$short_record sys_info$max_seg_size LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 14 001576 164 001612 165 001616 166 001621 167 001626 168 001631 169 001636 171 001642 172 001643 173 001644 174 001645 175 001646 176 001647 177 001650 178 001651 180 001655 181 001660 182 001663 183 001664 184 001665 186 001674 188 001675 190 001676 194 001720 196 001725 197 001746 199 001774 200 001776 201 002002 204 002003 205 002006 210 002010 211 002016 213 002044 214 002066 216 002117 218 002162 219 002200 221 002226 222 002234 224 002262 226 002263 228 002264 230 002267 232 002312 236 002341 238 002346 240 002347 242 002351 244 002355 246 002356 253 002364 255 002366 258 002404 259 002424 261 002427 264 002440 266 002445 267 002450 268 002451 271 002452 272 002454 275 002455 277 002460 279 002461 288 002475 290 002477 293 002515 294 002540 296 002543 298 002554 300 002557 302 002560 308 002574 310 002577 312 002627 314 002630 320 002644 322 002647 324 002676 326 002677 354 002705 356 002713 357 002732 359 002734 361 002736 362 002755 364 002757 366 002761 368 002770 370 003041 372 003074 375 003141 377 003145 379 003147 380 003152 381 003161 382 003163 384 003166 385 003206 387 003207 389 003211 391 003216 393 003226 394 003273 398 003274 399 003300 401 003303 403 003307 407 003312 417 003313 418 003335 420 003401 421 003423 423 003452 424 003477 426 003535 427 003557 429 003623 430 003645 432 003674 434 003705 436 003714 438 003750 439 003772 442 004042 443 004064 445 004113 446 004140 448 004176 449 004216 451 004245 453 004252 455 004274 457 004301 459 004345 461 004347 462 004371 465 004373 467 004401 468 004423 470 004452 472 004473 474 004502 476 004511 477 004547 479 004550 481 004554 482 004576 484 004625 486 004636 488 004645 490 004654 491 004712 493 004713 495 004717 496 004741 498 004770 499 005015 500 005053 502 005054 504 005060 505 005102 507 005131 508 005156 509 005214 511 005215 514 005221 515 005243 517 005272 519 005303 521 005312 522 005350 524 005351 526 005355 527 005377 529 005426 530 005453 531 005511 533 005512 535 005516 536 005540 538 005567 539 005614 540 005652 542 005653 544 005657 545 005701 547 005730 548 005755 549 006013 551 006014 553 006020 554 006042 556 006071 558 006102 560 006111 562 006120 563 006156 565 006157 567 006163 568 006205 570 006234 571 006261 572 006317 574 006320 576 006324 577 006346 579 006375 580 006422 581 006460 583 006461 585 006465 586 006507 588 006536 589 006563 590 006621 592 006622 594 006626 595 006650 597 006677 598 006724 599 006762 601 006763 604 007021 605 007022 607 007023 616 007034 618 007037 619 007045 620 007047 623 007050 624 007105 627 007110 629 007111 644 007117 646 007125 647 007131 648 007133 650 007134 651 007136 654 007137 656 007144 657 007146 658 007147 659 007151 671 007152 672 007155 674 007160 677 007173 679 007174 680 007216 682 007253 684 007255 685 007260 686 007262 687 007263 690 007264 692 007300 694 007305 695 007307 700 007310 702 007311 712 007312 714 007323 715 007344 717 007404 718 007413 720 007453 722 007476 723 007523 725 007562 727 007617 729 007625 732 007626 735 007627 736 007631 737 007633 739 007635 740 007637 741 007642 742 007643 743 007644 744 007645 745 007646 746 007647 747 007650 748 007651 749 007652 750 007653 751 007654 752 007655 754 007656 756 007657 773 007660 774 007717 777 007727 779 007732 780 007756 782 010011 783 010013 784 010042 786 010075 788 010100 789 010104 791 010110 794 010160 796 010161 798 010163 799 010167 801 010173 804 010243 806 010244 807 010277 810 010300 811 010304 812 010310 815 010314 817 010317 820 010355 821 010415 823 010450 825 010452 827 010455 829 010460 832 010505 834 010526 837 010527 840 010554 843 010575 845 010576 847 010631 849 010667 851 010671 853 010673 854 010711 859 010750 861 010751 872 010752 874 011000 875 011001 877 011003 879 011005 881 011006 883 011016 884 011040 885 011073 888 011074 889 011076 892 011100 894 011121 896 011127 898 011136 900 011200 902 011202 903 011203 904 011205 905 011206 908 011207 909 011222 910 011242 912 011300 914 011301 916 011324 918 011325 920 011326 921 011357 923 011361 930 011363 932 011364 933 011365 935 011372 937 011374 938 011416 940 011445 942 011460 944 011471 949 011500 950 011502 953 011510 955 011511 957 011512 965 011513 966 011535 968 011570 969 011615 971 011653 973 011714 975 011715 988 011717 989 011741 991 011774 992 012021 994 012057 996 012065 997 012105 999 012140 1000 012153 1003 012154 1004 012176 1006 012231 1007 012252 1009 012253 1011 012254 1018 012255 1020 012265 1021 012274 1022 012317 1024 012320 1026 012325 1027 012327 1029 012331 1030 012337 1033 012370 1036 012433 1038 012435 1039 012461 1041 012462 1043 012520 1045 012553 1050 012554 1061 012555 1063 012603 1064 012604 1066 012606 1068 012611 1071 012640 1073 012663 1075 012664 1077 012713 1079 012722 1081 012724 1082 012727 1083 012730 1085 012731 1086 012762 1088 012763 1090 012764 1092 012777 1093 013005 1095 013033 1096 013055 1098 013103 1101 013157 1103 013202 1105 013203 1124 013214 1126 013217 1128 013232 1130 013243 1131 013245 1133 013246 1135 013250 1137 013251 1138 013261 1139 013310 1141 013312 1142 013314 1144 013315 1148 013350 1149 013360 1150 013364 1152 013367 1153 013373 1154 013405 1156 013407 1158 013411 1159 013412 1162 013415 1164 013433 1169 013440 1170 013442 1171 013444 1173 013446 1175 013450 1177 013453 1178 013464 1179 013474 1180 013544 1181 013547 1182 013551 1183 013554 1186 013555 1187 013562 1188 013572 1190 013576 1191 013600 1194 013612 1195 013613 1197 013616 1200 013661 1201 013664 1202 013666 1204 013675 1206 013676 1209 013710 1210 013711 1213 013720 1215 013721 1218 013722 1220 013726 1222 013735 1224 013736 1226 013737 1236 013740 1237 013746 1239 013775 1240 014017 1242 014046 1245 014055 1246 014103 1248 014141 1253 014206 1254 014230 1257 014266 1259 014271 1260 014276 1261 014306 1262 014312 1264 014313 1266 014347 1269 014404 1273 014405 1278 014413 1280 014436 1282 014443 1283 014454 1286 014466 1287 014476 1289 014506 ----------------------------------------------------------- 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