ascii_to_ebcdic_.alm 11/04/82 1931.3rew 11/04/82 1632.3 32211 " *************************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1975 by Massachusetts Institute of Technology * " * * " *************************************************************** "ALM subroutine to convert from 9 bit ASCII to 9 bit EBCDIC "input bytes must be valid ASCII characters whose octal values "fall in the range 000 <_ octal_value <_ 177 " "ARG 1: pointer to source string - data to be converted "ARG 2: pointer to target string - converted data " "PL/I Usage: " "dcl ascii_to_ebcdic_ ext entry (char (*), char (*)); " call ascii_to_ebcdic_ (input_string, output_string); " " "Note: the ASCII to EBCDIC mapping used is defined in the " text of this procedure. It is available to a user " program through the following declaration. " "dcl ascii_to_ebcdic_$ae_table char (128) external static; " "The table consists of 128 EBCDIC characters which "correspond to the 128 ASCII characters. The first character "corresponds to 000, the 2nd to 001, ....., the 128th "to 177. " " 0) Created by Ross E. Klinger, 02/14/74 " 1) Modified by R.E. Klinger, 03/13/75 name ascii_to_ebcdic_ segdef ascii_to_ebcdic_ segdef ae_table ascii_to_ebcdic_: epp1 ap|2,* address of source string to pr1 epp3 ap|4,* address of target string to pr3 ldx3 0,du set x3 not to skip parent pointer if none lxl2 ap|0 load argument list code value canx2 =o000004,du check for code 4 - no parent pointer tnz *+2 transfer if no parent pointer ldx3 2,du parent pointer - set x3 to skip it lda ap|6,x3* load source string descriptor ldq ap|8,x3* load target string descriptor ana mask drop all but string size bits anq mask ditto even mvt (pr,rl),(pr,rl),fill(040) translate ascii to ebcdic desc9a 1|0,al source string desc9a 3|0,ql target string arg ae_table short_return "exit mask: oct 000077777777 even " EBCDIC OUTPUT EBCDIC GRAPHIC HEXADECIMAL ae_table: oct 000001002003 NUL,SOH,STX,ETX 00,01,02,03 oct 067055056057 EOT,ENQ,ACK,BEL 37,2D,2E,2F oct 026005045013 BS,HT,NL,VT 16,05,25,0B oct 014015016017 NP,CR,SO,SI 0C,0D,0E,0F oct 020021022023 DLE,DC1,DC2,TM 10,11,12,13 oct 074075062046 DC4,NAK,SYN,ETB 3C,3D,32,26 oct 030031077047 CAN,EM,SUB,ESC 18,19,3F,27 oct 034035036037 IFS,IGS,IRS,IUS 1C,1D,1E,1F oct 100132177173 space,!,",# 40,5A,7F,7B oct 133154120175 $,%,&,apostrophe 5B,6C,50,7D oct 115135134116 (,),*,+ 4D,5D,5C,4E oct 153140113141 ",",-,.,/ 6B,60,4B,61 oct 360361362363 0,1,2,3 F0,F1,F2,F3 oct 364365366367 4,5,6,7 F4,F5,F6,F7 oct 370371172136 8,9,:,";" F8,F9,7A,5E oct 114176156157 <,=,>,? 4C,7E,6E,6F oct 174301302303 @,A,B,C 7C,C1,C2,C3 oct 304305306307 D,E,F,G C4,C5,C6,C7 oct 310311321322 H,I,J,K C8,C9,D1,D2 oct 323324325326 L,M,N,O D3,D4,D5,D6 oct 327330331342 P,Q,R,S D7,D8,D9,E2 oct 343344345346 T,U,V,W E3,E4,E5,E6 oct 347350351255 X,Y,Z,[ E7,E8,E9,AD oct 340275137155 \,],^,_ E0,BD,5F,6D oct 171201202203 `,a,b,c 79,81,82,83 oct 204205206207 d,e,f,g 84,85,86,87 oct 210211221222 h,i,j,k 88,89,91,92 oct 223224225226 l,m,n,o 93,94,95,96 oct 227230231242 p,q,r,s 97,98,99,A2 oct 243244245246 t,u,v,w A3,A4,A5,A6 oct 247250251300 x,y,z,{ A7,A8,A9,C0 oct 117320241007 solid bar,},~,DEL 4F,D0,A1,07 end  tape_ansi_attach_.pl1 12/17/86 0926.4r w 12/17/86 0829.4 248814 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-18,GWMay), approve(), audit(), install(): old history comments: 0) Created: 1) Modified: 04/11/79 C. D. Tavares for authentication and resource management. 2) Modified: 06/29/79 Rick Riley allow reading and writing ibm tapes in binary mode. 3) Modified: 9/79 R.J.C. Kissel to handle 6250 bpi tapes. 4) Modified: 10/01/80 C. D. Tavares allow ibm file names to be > 8 chars if they contain periods. 5) Modified: 9/81 M.R. Jordan to fix bugs whereby io_call attachments would fail and not report errors. 6) Modified: 4/82 by J. A. Bush to allow blocksizes > 8192 bytes. 2) change(86-08-18,GWMay), approve(86-09-09,MCR7536), audit(86-09-15,Dupuis), install(86-09-24,MR12.0-1162): Changed to accommodate error message lengths > 32 chars. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ tape_ansi_attach_: procedure; /* this entry not used */ return; /* parameters */ dcl iocbP ptr, /* pointer to iocb */ options (*) char (*) varying, /* array of attachment options */ comerr bit (1) aligned, /* "1"b if com_err_ can be called */ code fixed bin (35); /* error code */ %include iocb; %include tape_ansi_cseg; %include tape_ansi_fd; %include tape_ansi_fl; %include tape_attach_options; %include rcp_volume_formats; %include rcp_resource_types; /* automatic storage */ dcl 1 auto_tao like tao auto; /* tape attach options */ dcl area_size fixed bin (26), /* size of allocation area */ block_attribute bit (1), /* "0"b - unblocked | "1"b - blocked */ drop fixed bin, /* number of drives to be freed */ error_msg char (80) varying init (""),/* attach option error message */ format_code fixed bin init (0), /* format code */ (i, j) fixed bin, mask bit (36) aligned, /* IPS mask word */ part_file_name char (17) varying, /* temp for validating labels */ standard fixed bin, /* tape standard code */ temp_file_name char (17), /* temp for validating labels */ blocksize fixed bin, /* size of tseg buffers in chars */ tstring char (256) varying; /* temporary attach description */ /* builtin functions */ dcl (addr, after, before, index, length, min, mod, null, rtrim, size, string, substr, verify) builtin; /* conditions */ dcl (any_other, area, cleanup) condition; /* internal static */ dcl module_name (2) char (12) varying internal static init /* IO Module name */ ("tape_ansi_", "tape_ibm_"); dcl system_code (2) char (13) internal static init /* system code for HDR1 label */ ("MULTICS ANSI ", "MULTICS IBM "); dcl 1 format internal static, /* -format interpretation */ 2 type (2, 7) char (4) varying init /* possibilities */ ("u", "fb", "f", "db", "d", "sb", "s", "u", "fb", "f", "vb", "v", "vbs", "vs"), 2 fcode (2, 7) fixed bin init /* interpretation - format code */ (1, 2, 2, 3, 3, 4, 4, 1, 2, 2, 3, 3, 4, 4), 2 blkatrib (2, 7) bit (1) init /* interpretation - blocking attribute */ ("0"b, "1"b, "0"b, "1"b, "0"b, "1"b, "0"b, "0"b, "1"b, "0"b, "1"b, "0"b, "1"b, "0"b); dcl 1 ibm_verifies unaligned internal static options (constant), 2 ibm_verify1 char (55) init ("@#$ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), /* letters and national characters */ 2 ibm_verify2 char (11) init ("0123456789-"); /* numbers and hyphen */ /* external static */ dcl ( error_table_$noalloc, error_table_$noarg, error_table_$not_detached, error_table_$unable_to_do_io, error_table_$file_busy, error_table_$inconsistent, error_table_$invalid_cseg, error_table_$bad_arg ) fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) ext static; /* external procedures */ dcl area_ ext entry (fixed bin (26), ptr), canon_for_volume_label_ entry (char (*), char (*), char (*), fixed bin, fixed bin (35)), clock_ ext entry returns (fixed bin (71)), com_err_ ext entry options (variable), continue_to_signal_ ext entry (fixed bin (35)), tape_ansi_control_ ext entry (ptr, char (*), ptr, fixed bin (35)), datebin_ ext entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin), datebin_$dayr_clk ext entry (fixed bin (71), fixed bin), tape_ansi_detach_ ext entry (ptr, fixed bin (35)), tape_ansi_file_cntl_$open ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)), hcs_$delentry_seg ext entry (ptr, fixed bin (35)), hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$reset_ips_mask ext entry (bit (36) aligned, bit (36) aligned), hcs_$set_ips_mask ext entry (bit (36) aligned, bit (36) aligned), hcs_$truncate_seg ext entry (pointer, fixed bin (18), fixed bin (35)), iox_$propagate ext entry (ptr), tape_ansi_mount_cntl_$free ext entry (ptr, fixed bin, fixed bin (35)), tape_ansi_mount_cntl_$insert_rings ext entry (ptr, fixed bin (35)), tape_ansi_mount_cntl_$mount ext entry (ptr, fixed bin, fixed bin (35)), tape_ansi_mount_cntl_$write_permit ext entry (ptr, fixed bin (35)), tape_ansi_mount_cntl_$write_protect ext entry (ptr, fixed bin (35)), tape_ansi_nl_file_cntl_$open ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)), tape_ansi_parse_options_ ext entry (ptr, (*) char (*) varying, char (*) varying, fixed bin (35)), tape_ansi_attach_$no_user_routine ext entry options (variable), tape_ansi_tape_io_$attach ext entry (ptr), terminate_process_ ext entry (char (*), ptr); tape_ansi_attach: entry (iocbP, options, comerr, code); standard = 1; /* indicate tape_ansi_ entry */ go to common; tape_ibm_attach: entry (iocbP, options, comerr, code); standard = 2; /* indicate tape_ibm_ entry */ common: if iocbP -> iocb.attach_descrip_ptr ^= null then do; /* is iocb already attached? */ code = error_table_$not_detached; error_msg = iocbP -> iocb.name; goto bad_attopt; end; taoP = addr (auto_tao); /* base tao on automatic storage */ call tao_init; /* initialize the attach option structure */ call tape_ansi_parse_options_ (taoP, options, error_msg, code); /* evaluate attach options */ if code ^= 0 then do; /* did an error occur? */ bad_attopt: if comerr then call com_err_ (code, module_name (standard), "^a", error_msg); /* write msg if permitted */ return; end; call check_attopt (error_msg, code); /* check if all ok for this IO Module */ if code ^= 0 then go to bad_attopt; if tao.blklen <= 8192 then /* if standard block size.. */ blocksize = 8192; /* set buffer size for 2K words */ else do; /* non-standard block size wanted */ if standard = 1 then /* if tape_ansi_ attachment */ if tao.blklen > 99996 then do; /* if block size > max, complain */ error_msg = "Block size > 99996 bytes not allowed"; code = error_table_$bad_arg; go to bad_attopt; end; else ; else if tao.blklen > 32760 then do; /* tape_ibm_ block size > max, complain */ error_msg = "Block size > 32760 bytes not allowed"; code = error_table_$bad_arg; go to bad_attopt; end; blocksize = tao.blklen; /* set the desired block size */ end; cP = null; /* dont' try to cleanup non-existent stuff */ on cleanup call cleaner; /* don't leave segments and/or drives around */ i = min (length (rtrim (tao.volname (1))), 32 - length (rtrim (module_name (standard))) - length ("_.cseg")); call hcs_$make_seg ("", module_name (standard) || substr (tao.volname (1), 1, i) /* make cseg */ || "_.cseg", "", 01011b, cP, code); /* or initiate if already exists */ if cP = null then do; /* no cseg made or found - fatal */ error_msg = "Unable to initiate/create temporary data segment."; goto bad_attopt; end; if cseg.vcN > 0 then /* already exists */ if cseg.vl (1).volname ^= tao.volname (1) then /* but not the right one */ call hcs_$truncate_seg (cP, 0, code); /* this is possible because we cannot use the */ /* full name of the volume in the cseg name */ if tao.clear_cseg then call hcs_$truncate_seg (cP, 0, code); /* re-do cseg */ if cseg.vcN > 0 then do; /* cseg previously existed */ if cseg.file_set_lock then do; /* file set is locked */ code = error_table_$file_busy; error_msg = "The file set is locked."; goto er_exit; end; else cseg.file_set_lock = "1"b; code = 0; /* not an error */ go to re_attach; /* this is a re-attachment to the file set */ end; cseg.file_set_lock = "1"b; /* cseg made and locked */ cseg.standard = standard; cseg.no_labels = tao.no_labels; cseg.module = module_name (standard); cseg.ndrives = 1; cseg.nactive = 0; cseg.vcN = 0; cseg.fcP = null; cseg.write_ring = tao.write_ring; cseg.protect = "0"b; cseg.density = tao.density; cseg.rlP = null; cseg.buf_size = blocksize; /* set the tseg buffer size */ call cseg_init; /* initialize cseg with attach data */ cseg.invalid = "0"b; /* cseg is valid */ call tape_ansi_tape_io_$attach (cP); /* initialize IO */ on area begin; /* shouldn't occur, but handle if does */ code = error_table_$noalloc; go to er_exit; /* cleanup is necessary */ end; area_size = sys_info$max_seg_size - size (cseg); call area_ (area_size, addr (cseg.chain_area)); /* format chain area for link allocation */ allocate fd in (chain_area) set (cseg.fcP); /* allocate the dummy file chain link */ do i = 1 to tao.nvolumes; /* build the volume chain */ call vl_init (i); /* initialize all other values */ cseg.vcN = i; /* set the new volume chain count */ end; call tape_ansi_mount_cntl_$mount (cP, 1, code); /* mount the volume on a new drive */ if code ^= 0 then go to er_exit; /* success? */ call fd_init; /* initialize file data with attach and mount data */ attach_ok: cseg.attach_description.length = length (tstring);/* prepare attach description */ cseg.attach_description.string = tstring; if tao.DOS then cseg.standard = 3; /* up standard for ibm_lrec_io_ */ mask = "0"b; /* IPS interrupts not masked yet */ revert cleanup; /* cleanup no longer matters */ on any_other call handler; /* pick up any condition */ call hcs_$set_ips_mask ("0"b, mask); /* mask all IPS interrupts */ if cseg.no_labels then iocbP -> iocb.actual_iocb_ptr -> iocb.open = tape_ansi_nl_file_cntl_$open; else iocbP -> iocb.actual_iocb_ptr -> iocb.open = tape_ansi_file_cntl_$open; iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_; iocbP -> iocb.actual_iocb_ptr -> iocb.detach_iocb = tape_ansi_detach_; iocbP -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = addr (cseg.attach_description); iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr = cP; call iox_$propagate (iocbP -> iocb.actual_iocb_ptr); /* reflect changes to all iocb's */ call hcs_$reset_ips_mask (mask, mask); /* permit IPS interrupts */ return; re_attach: if tao.density ^= -1 then if tao.density ^= cseg.density then do; /* density changed from previous attach */ do i = 1 to cseg.vcN; /* see if all volumes demounted */ if vl (i).rcp_id ^= 0 then do; /* still mounted - can't change density */ error_msg = "Cannot change file set density."; bad_re_attach: code = error_table_$bad_arg; cseg.file_set_lock = "0"b; /* unlock the file set */ go to bad_attopt; end; end; cseg.density = tao.density; /* (re)set it */ end; if tao.no_labels ^= cseg.no_labels then do; /* can't change label standard */ error_msg = "Cannot change label standard."; go to bad_re_attach; end; if tao.ndrives = 0 then go to chain_ck; /* ndrives unspecified - maintain old value */ if tao.ndrives >= cseg.ndrives then do; /* necessary to free drives? */ cseg.ndrives = tao.ndrives; /* no - set new value */ go to chain_ck; /* check volume sequence validity */ end; else cseg.ndrives = tao.ndrives; /* yes - set new value */ if cseg.nactive <= cseg.ndrives then go to chain_ck; /* not necessary to free any drives */ else drop = cseg.nactive - cseg.ndrives; /* drives must be freed */ /* scan file chain to find requested file */ cseg.flP = cseg.fcP; /* start with dummy link */ if fd.nextP = null then go to no_chain; /* no file chain */ do cseg.flP = fl.nextP repeat fl.nextP; /* start with 1st real link */ if tao.sequence = 0 then do; /* search for fileid */ if tao.replace_id = fl.file_id then go to got_fl; /* match? */ if tao.file_id = fl.file_id then go to got_fl; /* match? */ end; else if tao.sequence = fl.sequence then go to got_fl; /* search for sequence */ if fl.nextP = null then go to got_fl; /* no more links - exit */ if fl.nextP -> fl.flX = -1 then go to got_fl; /* stop before eofsl */ end; got_fl: do i = 1 to fl.vlX - 1; /* search up to wanted volume */ if vl (i).rcp_id ^= 0 then do; /* active - free it */ call tape_ansi_mount_cntl_$free (cP, i, code); if code ^= 0 then go to er_exit; /* trouble */ drop = drop - 1; if drop = 0 then go to chain_ck; /* done? */ end; end; no_chain: do i = cseg.vcN to fl.vlX + 1 by -1; /* search down to wanted volume */ if vl (i).rcp_id ^= 0 then do; /* active - free it */ call tape_ansi_mount_cntl_$free (cP, i, code); if code ^= 0 then go to er_exit; /* trouble */ drop = drop - 1; if drop = 0 then go to chain_ck; end; end; code = error_table_$invalid_cseg; /* this is very very bad */ error_msg = "Control segment deleted."; go to er_exit; chain_ck: if tao.nvolumes = 1 then go to finish; /* no follow-on volumes specified */ do i = 2 to tao.nvolumes; /* loop to check each follow-on volume */ if i > cseg.vcN then do; /* links do not exist for the following volumes */ do j = i to tao.nvolumes; /* make a link for each new volume */ call vl_init (j); /* initialize all other values */ cseg.vcN = j; /* set the new volume chain count */ end; go to finish; end; if vl (i).volname ^= tao.volname (i) then do;/* link exists - mismatch? */ if vl (i).fflX ^= 0 then do; /* this volume is a volume set member */ error_msg = "Invalid volume set sequence."; code = error_table_$bad_arg; cseg.file_set_lock = "0"b; /* unlock the file set */ go to bad_attopt; end; else do; /* this volume is a volume set candidate */ if vl (i).rcp_id ^= 0 then do; /* mounted? */ call tape_ansi_mount_cntl_$free (cP, i, code); /* free it */ if code ^= 0 then go to er_exit; end; call vl_init (i); /* re-initialize the link */ end; end; end; finish: if tao.write_ring then do; /* user wants to write */ if ^cseg.write_ring then do; /* but no rings are in the volumes */ call tape_ansi_mount_cntl_$insert_rings (cP, code); /* so put them in */ if code ^= 0 then go to er_exit; end; if cseg.protect then do; /* but hardware protect is on */ call tape_ansi_mount_cntl_$write_permit (cP, code); /* so set hardware permit */ if code ^= 0 then go to er_exit; end; end; else do; /* user doesn't want to write */ if cseg.write_ring then do; /* but rings are in */ if ^cseg.protect then do; /* and hardware protect is off */ call tape_ansi_mount_cntl_$write_protect (cP, code); /* so turn it on */ if code ^= 0 then go to er_exit; end; end; end; call cseg_init; /* fill cseg with attach data */ call fd_init; /* fill file data with attach data */ go to attach_ok; check_attopt: procedure (msg, ecode); /* IO Module-specific attach option validation */ dcl msg char (*) varying, /* erroneous option */ ecode fixed bin (35); /* error code */ dcl ANSI char (18) internal static init ("ANSI standard and "); dcl IBM char (17) internal static init ("IBM standard and "); dcl NL char (17) internal static init ("""-no_labels"" and "); dcl NOUT char (22) internal static init (" and no output option."); msg = ""; /* initialize returned arguments */ ecode = 0; if tao.ntracks = 0 then tao.ntracks = 9; /* default is 9 track drives */ else if tao.ntracks ^= 9 then do; /* ANSI doesn't support any other tracks */ msg = "Only ""-track 9"" is valid."; go to bad; end; if tao.density = -1 then ; /* default is ok */ else if tao.density = 2 then ; /* 800 bpi is ok */ else if tao.density = 3 then ; /* 1600 bpi is ok */ else if tao.density = 4 then ; /* 6250 bpi is ok */ else do; /* any other is invalid */ msg = "Invalid ""-density"" option."; go to bad; end; if standard = 1 then do; /* ANSI standard checks */ if tao.DOS then do; msg = ANSI || """-dos""."; go to bad; end; if tao.no_labels then do; msg = ANSI || """-no_labels""."; go to bad; end; end; else do; /* IBM standard checks */ if tao.output_mode = 3 then do; /* -generate */ msg = IBM || """-generate""."; go to bad; end; if tao.output_mode > 0 then do; /* output option specified */ if tao.blklen ^= 0 then do; /* -block specified */ if mod (tao.blklen, 4) ^= 0 then do; /* blklen not word multiple */ msg = """-block"" not multiple of 4."; go to bad; end; end; end; if tao.no_labels then do; /* -no_labels specified */ if tao.DOS then do; /* -dos specified */ msg = NL || """-dos""."; go to bad1; end; if tao.file_id ^= "" then do; /* -name specified */ msg = NL || """-name""."; go to bad1; end; if tao.replace_id ^= "" then do; /* -replace specified */ msg = NL || """-replace""."; go to bad1; end; if tao.sequence = 0 then do; /* no sequence specified */ msg = """-no_labels"" requires ""-number""."; go to bad3; end; if tao.output_mode = 1 then do; /* -extend specified */ msg = NL || """-extend""."; go to bad1; end; else if tao.output_mode = 2 then do; /* -modify specified */ msg = NL || """-modify""."; go to bad1; end; if tao.expiration ^= "00000" then do; /* -expires specified */ msg = NL || """-expires""."; go to bad1; end; if tao.force then do; /* -force specified */ msg = NL || """-force""."; go to bad1; end; go to format_ck; end; end; if tao.output_mode = 4 then do; /* ANSI and IBM checks - create */ if tao.file_id = "" then do; /* no -name */ msg = """-create"" requires ""-name""."; go to bad3; end; if standard = 2 then do; /* validate file id if IBM */ temp_file_name = tao.file_id; msg = "Invalid ""-name"" identifier."; do while (temp_file_name ^= ""); part_file_name = rtrim (before (temp_file_name, ".")); temp_file_name = after (temp_file_name, "."); if length (part_file_name) = 0 then goto bad; /* must have name! */ if length (part_file_name) > 8 then goto bad; /* no component can be > 8 chars */ if index (ibm_verify1, substr (part_file_name, 1, 1)) = 0 then goto bad; /* first char must be from limited set */ if verify (part_file_name, string (ibm_verifies)) > 0 then goto bad; /* all chars must be from certain set */ end; msg = ""; end; end; else do; /* extend, modify, generate, or none */ if tao.replace_id ^= "" then do; /* -replace specified */ msg = """-replace"" requires ""-create""."; go to bad3; end; else if tao.output_mode = 0 then do; /* none specelse ified */ if tao.expiration ^= "00000" then do; msg = """-expires""" || NOUT; go to bad3; end; if tao.force then do; msg = """-force""" || NOUT; go to bad3; end; end; else if tao.output_mode < 3 then do; /* output mode is extend or modify */ if tao.expiration ^= "00000" then do; /* and expiration specified */ if tao.output_mode = 1 then msg = """-extend"" and ""-expires""."; else msg = """-modify"" and ""-expires""."; go to bad1; end; end; end; if tao.sequence = 0 then do; /* no explicit sequence */ if tao.file_id = "" then do; /* and no -name */ msg = """-name"" or ""-number"" needed."; go to bad3; end; end; format_ck: if tao.format = "" then do; /* default format */ format_code = 0; go to test (0); end; do i = 1 to 7; /* validate format */ if tao.format = format.type (standard, i) then do; /* match? */ format_code = format.fcode (standard, i); block_attribute = format.blkatrib (standard, i); go to test (format_code); end; end; msg = "Unsupported ""-format"" option."; go to bad; test (1): if tao.reclen ^= 0 then do; /* u format */ msg = """-record"" and ""-format""."; go to bad1; end; go to test (0); test (2): if tao.blklen ^= 0 then do; /* f format */ if tao.reclen ^= 0 then do; if block_attribute then do; if mod (tao.blklen, tao.reclen) ^= 0 then do; br_inc: msg = """-block"" and ""-record""."; go to bad1; end; end; else if tao.blklen ^= tao.reclen then go to br_inc; end; end; go to test (0); test (3): if tao.blklen ^= 0 then if tao.reclen ^= 0 then do; /* d/v format */ if standard = 1 then i = 0; /* don't allow for BDW if ANSI */ else i = 4; /* IBM - allow for 4 byte BDW */ if block_attribute then do; if tao.blklen < tao.reclen + i then go to br_inc; end; else if tao.blklen ^= tao.reclen + i then go to br_inc; end; test (0): test (4): tstring = module_name (standard); /* initialize attach description with module name */ do i = 1 to tao.noptions; /* append each option */ tstring = tstring || " " || options (i); end; return; bad: ecode = error_table_$bad_arg; return; bad1: ecode = error_table_$inconsistent; return; bad3: code = error_table_$noarg; return; end check_attopt; tao_init: procedure; /* initialize attach options */ tao.noptions, tao.ntracks, tao.retain, tao.output_mode, tao.sequence, tao.blklen, tao.reclen, tao.mode, tao.nvolumes, tao.ndrives = 0; tao.density = -1; tao.write_ring, tao.clear_cseg, tao.force, tao.user_labels, tao.DOS, tao.no_labels = "0"b; tao.format, tao.replace_id, tao.file_id, tao.volname (*), tao.comment (*) = ""; tao.expiration = "00000"; return; end tao_init; cseg_init: procedure; /* initializes cseg with attach data */ cseg.flP = null; cseg.open_mode = 0; cseg.force = tao.force; cseg.file_lock = "0"b; cseg.close_rewind = "0"b; cseg.user_labels = tao.user_labels; cseg.output_mode = tao.output_mode; cseg.replace_id = tao.replace_id; cseg.retain = tao.retain; if tao.ndrives ^= 0 then cseg.ndrives = tao.ndrives; /* set ndrives only if specified */ cseg.rlN = -1; cseg.user_label_routine (*) = tape_ansi_attach_$no_user_routine; return; end cseg_init; fd_init: procedure; /* initializes file data with attach and mount data */ fd.hdr1.file_id = tao.file_id; fd.hdr1.set_id = vl (1).volname; fd.hdr1.canonical_set_id = vl (1).canonical_volname; fd.hdr1.sequence = tao.sequence; fd.hdr1.creation = today (); fd.hdr1.expiration = tao.expiration; if standard = 1 then fd.access = " "; else fd.access = "0"; fd.hdr1.system = system_code (standard); fd.hdr2.format = format_code; fd.hdr2.blocked = block_attribute; fd.hdr2.blklen = tao.blklen; fd.hdr2.reclen = tao.reclen; fd.hdr2.mode = tao.mode; fd.hdr2.bo = 0; fd.cc = " "; end fd_init; vl_init: procedure (n); /* initialize a volume link */ dcl n fixed bin; /* link index */ dcl canon_std (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape); vl (n).volname = tao.volname (n); vl (n).comment = tao.comment (n); vl (n).fflX = 0; vl (n).cflX = 0; vl (n).pos = 0; vl (n).lflX = 0; vl (n).tracks = 0; vl (n).density = 0; vl (n).label_type = 0; vl (n).usage_count = 0; vl (n).read_errors = 0; vl (n).write_errors = 0; vl (n).rcp_id = 0; vl (n).event_chan = 0; vl (n).tape_drive = ""; vl (n).write_VOL1 = 0; vl (n).ioi_index = 0; call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), vl (n).volname, vl (n).canonical_volname, canon_std (standard), code); if code ^= 0 then do; error_msg = tao.volname (1); goto bad_attopt; end; return; end vl_init; er_exit: if comerr then call com_err_ (code, module_name (standard), "^a", error_msg); call cleaner; return; handler: procedure; /* intercept any faults during iocb manipulation */ dcl 1 ti aligned, 2 version fixed bin init (0), 2 code fixed bin (35); if mask ^= "0"b then do; /* IPS interrupts masked */ ti.code = error_table_$unable_to_do_io; /* very bad trouble */ call terminate_process_ ("fatal_error", addr (ti)); /* kill the process */ end; call continue_to_signal_ (0); return; end handler; cleaner: procedure; /* tidy up if bad trouble */ if cP ^= null then do; /* cseg exixts */ do i = 1 to cseg.vcN; /* check every link, if any */ if vl (i).rcp_id ^= 0 then call tape_ansi_mount_cntl_$free (cP, i, 0); /* active */ end; call hcs_$delentry_seg (cP, 0); /* delete cseg */ end; end cleaner; today: procedure returns (char (5)); /* returns today's date in Julian form */ dcl clock fixed bin (71), /* holds hardware clock value */ ddd picture "999", /* day of year */ yy picture "99", /* year */ temp fixed bin; /* temporary */ clock = clock_ (); /* get hardware clock value */ call datebin_$dayr_clk (clock, temp); /* get day of year */ ddd = temp; /* convert to characters */ call datebin_ (clock, 0, 0, 0, temp, 0, 0, 0, 0, 0); /* get year */ yy = temp - 1900; /* drop century and convert to characters */ return (yy || ddd); /* return formatted date */ end today; no_user_routine: entry; /* dummy entry point to indicate no user label routine */ end tape_ansi_attach_;  tape_ansi_control_.pl1 11/04/82 1931.3rew 11/04/82 1606.0 209394 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ tape_ansi_control_: procedure (iocbP, order, infoP, code); /* performs iox_$control function for tape_ansi_ */ /* Modified 08/17/76 by Janice Phillipps to handle io_call order requests. */ /* Modified 12/18/78 by Michael R. Jordan to add volume_density order as a temporary measure for list_tape_contents. */ /* Modified 04/11/79 by C. D. Tavares for resource management */ /* Modified 08/81 by M. R. Jordan for bug fixes */ /* arguments */ dcl iocbP ptr, /* pointer to iocb */ order char (*), /* control order name */ infoP ptr, /* pointer to information structure */ code fixed bin (35); /* error code */ /* based storage */ dcl hardware_status bit (72) aligned based (infoP); /* information for "hardware_status" order */ dcl retain_code fixed bin based (infoP); /* information for "retention" */ /* automatic storage */ dcl ret_code fixed bin (35); dcl io_order char (32) varying; dcl volume_density_ptr ptr; dcl volume_density fixed bin based (volume_density_ptr); dcl file_status_sw bit (1); dcl msg_sw bit (1); dcl state fixed bin; dcl event_code fixed bin (35); dcl lbl bit (1) aligned; dcl errmsg char (64) aligned; dcl short char (8) aligned; dcl long char (100) aligned; dcl i fixed bin; /* temporary */ dcl io_mod fixed bin; /* internal static */ dcl central_msg (0:7) char (55) internal static options (constant) init ( """000""b", "LPW tally runout", "two sequential TDCW's", "boundary violation", "invalid IOM central status - ""100""b", "IDCW in restricted mode", "character position/size discrepancy during list service", "parity error on I/O bus, data read from channel"), channel_msg (0:7) char (46) int static options (constant) init ( """000""b", "attempt to connect while busy", "illegal channel command in PCW", "incorrect DCW during list service", "incomplete instruction sequence", "invalid channel status - ""101""b", "parity error on PSIA", "parity error on I/O bus, data write to channel"), format (2, 8) char (3) int static options (constant) init ( "u", "f", "d", "s", "ub", "fb", "db", "sb", "u", "f", "v", "vs", "ub", "fb", "vb", "vbs"), mode (3) char (6) int static options (constant) init ( "ASCII", "EBCDIC", "binary"), State (0:3) char (32) int static options (constant) init ( "no information", "not open", "open", "open, but further I/O inhibited"); dcl 1 order_list (12) internal static options (constant), /* list of valid control orders */ 2 name char (32) varying init (/* orders */ "hardware_status", "status", "volume_status", "feov", "close_rewind", "retention", "file_status", "retain_none", "retain_all", "reset_error_lock", "volume_density", /* temp for MR7.0 for list_tape_contents */ "io_call"), 2 must_be_open bit (1) init ("1"b, "1"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b), 2 non_null_ptr bit (1) init ("1"b, "1"b, "1"b, "0"b, "0"b, "1"b, "1"b, "0"b, "0"b, "0"b, "1"b, "1"b); dcl 1 io_order_list (10) internal static options (constant), /* list of valid control orders foor use thru io_call */ 2 long_name char (32) varying init (/* orders */ "hardware_status", "status", "volume_status", "feov", "close_rewind", "retention", "file_status", "retain_none", "retain_all", "reset_error_lock"), 2 short_name char (4) varying init (/* orders */ "hst", "st", "vst", "feov", "crw", "ret", "fst", "retn", "reta", "rel"), 2 must_be_open bit (1) init ("1"b, "1"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b, "0"b, "1"b), 2 arguments bit (1) init ("0"b, "1"b, "0"b, "0"b, "0"b, "1"b, "0"b, "0"b, "0"b, "0"b); dcl 1 io_order_user_msg (10) internal static options (constant), /* list of valid order request syntax */ 2 msgs char (48) varying init (/* orders */ "hardware_status", "status {-all}", "volume_status", "feov", "close_rewind", "retention -all | -volume | -device | -none", "file_status", "retain_none", "retain_all", "reset_error_lock"); /* external procedures */ dcl tape_ansi_file_cntl_$data_eot ext entry (ptr, fixed bin (35)); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl tape_ansi_nl_file_cntl_$data_eot ext entry (ptr, fixed bin (35)); /* external static */ dcl (error_table_$action_not_performed, error_table_$wrong_no_of_args, error_table_$bad_arg, error_table_$undefined_order_request, error_table_$file_busy, error_table_$invalid_cseg, error_table_$no_operation, error_table_$no_next_volume, error_table_$not_open, error_table_$tape_error) fixed bin (35) external static; /* conditions and builtins */ dcl cleanup condition, (hbound, null, addr, binary, convert, substr) builtin; %page; %include iocb; %page; %include tape_ansi_cseg; %page; %include tape_ansi_fd; %page; %include tape_ansi_fl; %page; %include tape_file_status; %page; %include tape_volume_status; %page; %include device_status; %page; %include iom_stat; %page; %include io_call_info; %page; do i = 1 to hbound (order_list, 1); /* determine which order to execute */ if order = order_list.name (i) then do; /* got it - now check it */ if order_list.must_be_open (i) then do; if iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null () then do; code = error_table_$not_open; return; end; end; if order_list.non_null_ptr (i) then do; if infoP = null then do; code = error_table_$bad_arg; return; end; end; go to START; end; end; code = error_table_$no_operation; /* invalid order */ return; START: cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* all ok - get cseg pointer */ if cseg.invalid then do; code = error_table_$invalid_cseg; return; end; if cseg.file_lock then do; code = error_table_$file_busy; return; end; else do; on cleanup cseg.file_lock = "0"b; cseg.file_lock = "1"b; end; code = 0; /* initialize error code */ go to act (i); /* transfer to perform appropriate processing */ %page; act (1): /* hardware_status */ hardware_status = cseg.hdw_status.bits; /* give 72 bit IOM status */ go to exit; %skip (5); act (2): /* status */ dstat_ptr = infoP; /* set pointer to structure */ device_status = cseg.hdw_status; /* give entire status structure */ go to exit; %skip (5); act (3): /* volume_status */ tvstat_ptr = infoP; /* set pointer to structure */ call setup_for_vol_status; tape_volume_status.volume_name = vl (i).canonical_volname; /* fill status structure */ tape_volume_status.volume_id = substr (vl (i).volname, 1, 6); tape_volume_status.volume_seq = i; if vl (i).rcp_id = 0 then tape_volume_status.tape_drive = ""; else tape_volume_status.tape_drive = vl (i).tape_drive; tape_volume_status.read_errors = vl (i).read_errors; tape_volume_status.write_errors = vl (i).write_errors; go to exit; %page; act (4): /* feov */ if cseg.open_mode ^= 5 then do; /* opening must be sequential_output */ code = error_table_$action_not_performed; go to exit; end; call force_eov; go to exit; %skip (5); act (5): /* close_rewind */ cseg.close_rewind = "1"b; /* set the switch for next close operation */ go to exit; %skip (5); act (6): /* retention */ if retain_code < 0 | retain_code > 4 then do; /* check validity */ code = error_table_$bad_arg; go to exit; end; cseg.retain = retain_code; /* set the new retention */ go to exit; %page; act (7): /* file_status */ tfstat_ptr = infoP; /* set pointer to structure */ call setup_for_file_status; /* sets state and event code */ tape_file_status.state = state; tape_file_status.event_code = event_code; if cseg.no_labels then do; /* no file chain */ tape_file_status.file_id = ""; tape_file_status.file_seq = fd.sequence; tape_file_status.cur_section = fd.vlX; tape_file_status.cur_volume = vl (fd.vlX).canonical_volname; tape_file_status.generation = 0; tape_file_status.version = 0; tape_file_status.creation = "00000"; tape_file_status.expiration = "00000"; tape_file_status.format_code = fd.format; tape_file_status.blklen = fd.blklen; tape_file_status.reclen = fd.reclen; tape_file_status.blocked = fd.blocked; tape_file_status.mode = fd.mode; end; else do; /* file chain exists */ tape_file_status.file_id = fl.file_id; tape_file_status.file_seq = fl.sequence; tape_file_status.cur_section = fl.section; tape_file_status.cur_volume = vl (fl.vlX).canonical_volname; tape_file_status.generation = fl.generation; tape_file_status.version = fl.version; tape_file_status.creation = fl.creation; tape_file_status.expiration = fl.expiration; tape_file_status.format_code = fl.format; tape_file_status.blklen = fl.blklen; tape_file_status.reclen = fl.reclen; tape_file_status.blocked = fl.blocked; tape_file_status.mode = fl.mode; end; tape_file_status.cur_blkcnt = cseg.lrec.blkcnt; go to exit; %page; act (8): /* retain_none */ cseg.retain = 1; go to exit; %skip (5); act (9): /* retain_all */ cseg.retain = 4; go to exit; %skip (5); act (10): /* reset_error_lock */ call reset_error_lock; go to exit; %skip (5); act (11): /* volume_density temp for ltc */ volume_density_ptr = infoP; /* set pointer to variable */ volume_density = cseg.density; /* copy info */ goto exit; %page; act (12): /* io_call orders */ io_call_infop = infoP; if cseg.standard = 1 then io_mod = 1; /* tape_ansi_ io mod */ else io_mod = 2; /* tape_ibm_ io mod */ do i = 1 to hbound (io_order_list, 1); /* determine which order to execute */ io_order = io_call_info.order_name; if io_order = io_order_list.long_name (i) | io_order = io_order_list.short_name (i) then do; /* got it - now check it */ if io_order_list.must_be_open (i) then do; if iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null () then do; call io_call_info.error (error_table_$not_open, io_call_info.caller_name, "^/The ^a control operation requires that the I/O switch be open.", io_order_list.long_name (i)); go to exit; end; end; if io_call_info.nargs > 0 then do; /* some orders take args */ if io_order_list.arguments (i) then do; if io_call_info.nargs = 1 then ; else do; wrong_no_args: call io_call_info.error (error_table_$wrong_no_of_args, io_call_info.caller_name, "^/Usage: io control SWITCH ^a", io_order_user_msg.msgs (i)); go to exit; end; end; else go to wrong_no_args; end; go to ord (i); end; end; call io_call_info.error (error_table_$undefined_order_request, io_call_info.caller_name, "^a", io_order); go to exit; %page; ord (1): /* hardware_status call */ call print_hardware_status; go to exit; %skip (5); ord (2): /* status order call */ if io_call_info.nargs = 0 then do; file_status_sw = "0"b; call print_device_status; end; else if io_call_info.args (1) = "-all" | io_call_info.args (1) = "-a" then do; file_status_sw = "1"b; call print_device_status; call print_hardware_status; call setup_for_vol_status; call print_volume_status; call setup_for_file_status; call print_file_status; end; else do; call io_call_info.error (error_table_$bad_arg, io_call_info.caller_name, "^a^/Usage: io control SWITCH ^a", io_call_info.args (1), io_order_user_msg.msgs (i)); go to exit; end; go to exit; %skip (5); ord (3): /* volume_status order call */ call setup_for_vol_status; call print_volume_status; go to exit; %skip (5); ord (4): /* feov order call */ if cseg.open_mode ^= 5 then do; call io_call_info.error (error_table_$action_not_performed, io_call_info.caller_name, "^/I/O switch must be open for sequential_output."); end; else do; call force_eov; if code ^= 0 then call io_call_info.error (code, io_call_info.caller_name, "^/Unable to force volume switching."); end; go to exit; %skip (5); ord (5): /* close_rewind order call */ cseg.close_rewind = "1"b; go to exit; %skip (5); ord (6): /* retention order call */ if io_call_info.nargs = 0 then goto wrong_no_args; if io_call_info.args (1) = "-all" | io_call_info.args (1) = "-a" then ret_code = 4; else if io_call_info.args (1) = "-none" then ret_code = 1; else if io_call_info.args (1) = "-volume" | io_call_info.args (1) = "-vol" then ret_code = 2; else if io_call_info.args (1) = "-device" | io_call_info.args (1) = "-dv" then ret_code = 3; else do; bad_arg: call io_call_info.error (error_table_$bad_arg, io_call_info.caller_name, "^/Bad retention specification. ^a", io_call_info.args (1)); go to exit; end; cseg.retain = ret_code; /* set the new retention */ go to exit; %skip (5); ord (7): /* file_status order call */ call setup_for_file_status; if cseg.no_labels then call print_nl_file_status (); else call print_file_status (); go to exit; %skip (5); ord (8): /* retain_none order call */ cseg.retain = 1; go to exit; %skip (5); ord (9): /* retain_all order call */ cseg.retain = 4; go to exit; %skip (5); ord (10): /* reset_error_lock order call */ call reset_error_lock; if code ^= 0 then call io_call_info.error (code, io_call_info.caller_name, "^/Unable to reset lock. I/O switch must be open for sequential_input."); %skip (5); exit: cseg.file_lock = "0"b; return; %page; print_hardware_status: procedure; statp = addr (cseg.hdw_status.bits); /* set ptr to status structure */ if status.power then errmsg = "off or device disconnected"; else errmsg = "on"; call io_call_info.report ("Power:^2-^a", errmsg); call io_call_info.report ("Major status:^-""^4b""b", status.major); call io_call_info.report ("Substatus:^-""^6b""b", status.sub); call io_call_info.report ("Even/Odd:^2-""^1b""b", status.eo); if status.marker then errmsg = "yes"; else errmsg = "no, terminate status"; call io_call_info.report ("Marker status:^-^a", errmsg); call io_call_info.report ("Software status:^-""^2b""b", status.soft); call io_call_info.report ("Initiate:^2-""^1b""b", status.initiate); call io_call_info.report ("Software abort:^-""^1b""b", status.abort); call io_call_info.report ("IOM channel:^-^a", channel_msg (binary (status.channel_stat))); call io_call_info.report ("IOM central:^-^a", central_msg (binary (status.central_stat))); call io_call_info.report ("Rec count residue:^-^d (decimal)", binary (status.rcount)); call io_call_info.report ("DCW address:^-^6w (octal)", binary (status.address), 35); call io_call_info.report ("Character position:^-^d (decimal)", binary (status.char_pos)); if status.r then errmsg = "yes"; else errmsg = "no"; call io_call_info.report ("Reading:^2-^a", errmsg); call io_call_info.report ("Last DCW type:^-""^2b""b", status.type); call io_call_info.report ("DCW tally:^-^d (decimal)^/", binary (status.tally)); return; end print_hardware_status; %page; print_device_status: procedure; errmsg = "Device status"; if cseg.hdw_status.no_minor = 0 then do; /* no minor status entered */ call convert_status_code_ (cseg.hdw_status.major, short, long); call io_call_info.report ("^a:^-^a", errmsg, long); end; else do i = 1 to cseg.hdw_status.no_minor; call convert_status_code_ (cseg.hdw_status.minor (i), short, long); call io_call_info.report ("^a:^-^a", errmsg, long); errmsg = " and:"; end; if ^file_status_sw then /* only for not file_status */ call io_call_info.report ("Blocks processed:^-^d^/", cseg.lrec.blkcnt); else call io_call_info.report (""); return; end print_device_status; %page; print_volume_status: procedure; /* prints info from cseg: i = current volume number of volume set. */ call io_call_info.report ("Volume name:^-^a", vl (i).volname); call io_call_info.report ("Label ID:^-^a", vl (i).canonical_volname); call io_call_info.report ("Volume sequence no:^-^d", i); if vl (i).rcp_id = 0 then call io_call_info.report ("Tape drive:^-(Volume Not Mounted)"); else call io_call_info.report ("Tape drive:^-^a", vl (i).tape_drive); if vl (i).read_errors > 0 then call io_call_info.report ("Read errors:^-^d", vl (i).read_errors); if vl (i).write_errors > 0 then call io_call_info.report ("Write errors:^-^d", vl (i).write_errors); call io_call_info.report (""); return; end print_volume_status; %page; print_file_status: procedure; call io_call_info.report ("File state:^-^a", State (state)); if state = 0 then do; call io_call_info.report (""); return; end; if state = 3 then do; call convert_status_code_ (cseg.lrec.code, short, long); call io_call_info.report ("I/O inhibited because:^-^a", long); end; call io_call_info.report ("File name:^-^a", fl.file_id); call io_call_info.report ("File number:^-^d", fl.sequence); call io_call_info.report ("File section no:^-^d", fl.section); call io_call_info.report ("Current volume:^-^a", vl (fl.vlX).canonical_volname); call io_call_info.report ("File generation:^-^d", fl.generation); call io_call_info.report ("File version:^-^d", fl.version); if fl.creation ^= "00000" then call io_call_info.report ("Created on:^-^a", cv_date ((fl.creation))); if fl.expiration ^= "00000" then call io_call_info.report ("Expires on:^-^a", cv_date ((fl.expiration))); call io_call_info.report ("Format:^2-^a", format (io_mod, fl.format + (binary (fl.blocked, 1) * 4))); if fl.format ^= 1 then call io_call_info.report ("Record length:^-^d", fl.reclen); call io_call_info.report ("Block length:^-^d", fl.blklen); call io_call_info.report ("Encoding mode:^-^a", mode (fl.mode)); call io_call_info.report ("Blocks processed:^-^d^/", cseg.lrec.blkcnt); return; end print_file_status; %page; print_nl_file_status: procedure; call io_call_info.report ("File state:^-^a", State (state)); if state = 0 then do; call io_call_info.report (""); return; end; if state = 3 then do; call convert_status_code_ (cseg.lrec.code, short, long); call io_call_info.report ("I/O inhibited because:^-^a", long); end; call io_call_info.report ("File number:^-^d", fd.sequence); call io_call_info.report ("File section no:^-^d", fd.vlX); call io_call_info.report ("Current volume:^-^a", vl (fd.vlX).canonical_volname); call io_call_info.report ("Format:^2-^a", format (io_mod, fd.format + (binary (fd.blocked, 1) * 4))); if fd.format ^= 1 then call io_call_info.report ("Record length:^-^d", fd.reclen); call io_call_info.report ("Block length:^-^d", fd.blklen); call io_call_info.report ("Encoding mode:^-^a", mode (fd.mode)); call io_call_info.report ("Blocks processed:^-^d^/", cseg.lrec.blkcnt); return; end print_nl_file_status; %page; cv_date: proc (julian) returns (char (10) aligned); dcl julian char (5); /* date in form: yyddd */ dcl clock fixed bin (71), (month, day, year) fixed bin, (Cmonth, Cday, Cyear) pic "99", date_time char (10) aligned, code fixed bin (35); dcl decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35)), encode_clock_value_$offsets entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (71), fixed bin (35)); year = convert (year, substr (julian, 1, 2)); day = convert (day, substr (julian, 3, 3)); call encode_clock_value_$offsets (0, 0, day - 1, year - 1, 0, 0, 0, 0, 0, "gmt", clock, code); if code ^= 0 then return ("unknown"); call decode_clock_value_$date_time (clock, month, day, year, 0, 0, 0, 0, 0, "gmt", code); if code ^= 0 then return ("unknown"); Cmonth = month; Cday = day; Cyear = year - 1900; date_time = Cmonth || "/" || Cday || "/" || Cyear; return (date_time); end cv_date; %page; setup_for_vol_status: procedure; if cseg.no_labels then do; /* no file chain */ if fd.vlX = 0 then i = 1; /* file data not initializeed - use 1st volume */ else i = fd.vlX; end; else do; if cseg.flP = cseg.fcP | cseg.flP = null then i = 1; /* no file links - use 1st volume */ else i = fl.vlX; /* else use current volume */ end; return; /* i = number of current volume */ end setup_for_vol_status; %skip (10); force_eov: procedure; code = 0; if cseg.no_labels then call tape_ansi_nl_file_cntl_$data_eot (iocbP, code); else call tape_ansi_file_cntl_$data_eot (iocbP, code); /* force volume switch */ if code ^= 0 then do; /* trouble */ cseg.lrec.code = code; /* lock the logical record IO */ if code = error_table_$no_next_volume then code = 0; /* don't indicate now */ end; return; end force_eov; %page; setup_for_file_status: procedure; /* determine file state and event code */ code = 0; if cseg.no_labels then do; /* no file chain */ if fd.vlX = 0 then go to no_info; /* no information available */ else ; end; else do; if cseg.flP = cseg.fcP | cseg.flP = null then do; /* no file links */ no_info: state = 0; return; end; if fl.file_id ^= fd.file_id & fl.sequence ^= fd.sequence then go to no_info; /* wrong link */ end; if iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null then state = 1; else do; /* file is open */ event_code = cseg.lrec.code; /* set event code */ if cseg.lrec.code = 0 then state = 2; /* no event */ else state = 3; end; return; end setup_for_file_status; %page; reset_error_lock: procedure; code = 0; if cseg.open_mode = 4 then do; /* switch must be open for sequential_input */ if cseg.lrec.code = error_table_$tape_error then cseg.lrec.code = 0; /* unlock the lock */ if cseg.lrec.code = 0 then return; /* lock isn't (or wasn't) locked - we're done */ end; code = error_table_$action_not_performed; /* sequential_output or couldn't unlock */ return; end reset_error_lock; end tape_ansi_control_;  tape_ansi_detach_.pl1 11/04/82 1931.3rew 11/04/82 1606.0 56430 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* */ /* 1) Modified: 06/29/79 by Rick Riley */ /* (modify nonlabeled volume reporting) */ tape_ansi_detach_: procedure (iocbP, code); /* iox_$tape_ansi_detach_iocb entry point */ dcl iocbP ptr, /* pointer to iocb */ code fixed bin (35); /* error code */ %include iocb; %include tape_ansi_cseg; %include tape_ansi_fd; /* automatic storage */ dcl i fixed bin, /* temporary volume chain index */ (j, k) fixed bin, /* message temporaries */ mask bit (36) aligned, /* ips interrupt mask */ string char (96) varying; /* volume set string */ /* builtin functions and conditions */ dcl (addr, max, null) builtin, (any_other, cleanup) condition; /* error codes */ dcl (error_table_$file_busy, error_table_$unable_to_do_io) ext static fixed bin (35); /* external procedures */ dcl continue_to_signal_ ext entry (fixed bin (35)), hcs_$delentry_seg ext entry (ptr, fixed bin (35)), hcs_$reset_ips_mask ext entry (bit (36) aligned, bit (36) aligned), hcs_$set_ips_mask ext entry (bit (36) aligned, bit (36) aligned), hcs_$terminate_noname ext entry (ptr, fixed bin (35)), hcs_$truncate_seg ext entry (ptr, fixed bin, fixed bin (35)), ioa_ ext entry options (variable), iox_$propagate ext entry (ptr), tape_ansi_mount_cntl_$free ext entry (ptr, fixed bin, fixed bin (35)), terminate_process_ ext entry (char (*), ptr); code = 0; cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to control segment */ if cseg.file_lock then do; /* file in use? */ code = error_table_$file_busy; return; end; else do; on cleanup begin; if cP = null then go to force_detach; /* no more cseg - detach iocb */ else go to action (1); /* eliminate drives and volumes */ end; cseg.file_lock = "1"b; end; go to action (cseg.retain); /* perform appropriate detach retention */ action (0): /* CODE WHEN rcp_ IS USED */ action (1): /* retain none */ cseg.write_ring = "0"b; /* no rings */ cseg.protect = "0"b; /* no hardware protection */ do i = 1 to cseg.vcN; /* test every volume link */ if vl (i).rcp_id ^= 0 then do; /* active */ vl (i).cflX = 0; /* invalidate position info */ call tape_ansi_mount_cntl_$free (cP, i, code); /* unassign drive and volume */ if code ^= 0 then cseg.invalid = "1"b; /* invalidate control segment */ end; end; go to detach_exit; action (2): /* retain devices */ cseg.write_ring = "0"b; /* no rings */ cseg.protect = "0"b; /* no hardware protect (loading will cancel) */ go to action (1); /* VERSION ONE TEMPORARY */ action (3): /* retain volumes */ cseg.write_ring = "0"b; /* no rings */ cseg.protect = "0"b; /* no hardware protect */ go to action (1); /* VERSION ONE TEMPORARY */ action (4): /* retain all */ if cseg.invalid then go to action (1); /* retain none if invalid control segment */ detach_exit: if cseg.rlP ^= null then do; call hcs_$truncate_seg (cseg.rlP, 0, 0); cseg.rlN = -1; end; if cseg.invalid then do; /* cseg is invalid */ if cseg.rlP ^= null then do; /* if read length segment exists */ call hcs_$delentry_seg (cseg.rlP, 0); /* delete it */ cseg.rlP = null; /* and null ptr to avoid problems */ end; call hcs_$delentry_seg (cP, 0); /* delete cseg */ cP = null; end; else if cseg.retain < 3 then do; /* cseg valid - not retaining volumes */ if cseg.write_ring then do; /* if volume set could have changed */ if vl (cseg.vcN).fflX ^= 0 then go to force_detach; /* volume set is all volumes */ do i = 1 to cseg.vcN while (vl (i).fflX ^= 0); /* find 1st unused volume */ end; cseg.vcN = max (1, i - 1); /* get index of last used volume (but at least 1) */ /* and truncate volume chain */ if cseg.vcN = 1 then /* one (or no) volumes */ call ioa_ ("^a: The only member of the volume set is ^a.", cseg.module, vl (1).volname); else do; call ioa_ ("^a: The members of the volume set are:", cseg.module); string = ""; /* initialize volume set string */ k = 0; /* zero entries per line count */ do j = 1 to cseg.vcN; /* output name of each member volume */ string = string || vl (j).volname || " "; k = k + 1; if k = 8 then do; /* line full? */ call ioa_ ("^a", string); /* write it */ string = ""; k = 0; end; end; if k ^= 0 then call ioa_ ("^a", string); /* write last line */ end; end; end; force_detach: mask = "0"b; /* initialize ips mask */ on any_other call handler; /* pick up interrupts */ call hcs_$set_ips_mask ("0"b, mask); /* mask all */ iocbP -> iocb.actual_iocb_ptr -> iocb.attach_descrip_ptr = null; /* iocb now detached */ call iox_$propagate (iocbP -> iocb.actual_iocb_ptr); call hcs_$reset_ips_mask (mask, mask); if cP ^= null then do; /* cseg still around */ if cseg.rlP ^= null then do; /* read_length_ segment still around */ call hcs_$terminate_noname (cseg.rlP, 0); /* disappear it */ cseg.rlP = null; end; cseg.file_set_lock, cseg.file_lock = "0"b; /* so unlock it */ end; return; handler: procedure; /* intercept any faults during iocb manipulation */ dcl 1 ti aligned, 2 version fixed bin init (0), 2 code fixed bin (35); if mask ^= "0"b then do; /* IPS interrupts masked */ ti.code = error_table_$unable_to_do_io; /* very bad trouble */ call terminate_process_ ("fatal_error", addr (ti)); /* kill the process */ end; call continue_to_signal_ (0); return; end handler; end tape_ansi_detach_;  tape_ansi_file_cntl_.pl1 12/17/86 0926.4r w 12/17/86 0829.4 913473 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* tape_ansi_file_cntl_ */ /* */ /* Main logic module of tape_ansi_. See individual entries */ /* for details of use and calling sequence. */ /* */ /* 0) Created: 10/04/74 by Ross E. Klinger */ /* 1) Modified: 11/04/76 by Janice B. Phillipps */ /* 2) Modified: 04/11/79 by C. D. Tavares for authentication and */ /* resource management */ /* 3) Modified: 9/79 by R.J.C. Kissel for new tseg */ /* 4) Modified: 4/82 by J. A. Bush for block sizes > 8192 bytes */ /* and to remove tape_ibm_ HDR2 density check */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * */ /* format: style3,ind3,dclind6,idind32 */ tape_ansi_file_cntl_: procedure; /* This entry not used */ /* arguments */ dcl iocbP ptr, /* pointer to iocb */ open_mode fixed bin, /* opening mode */ extend_bit bit (1) aligned, /* extend at open time */ code fixed bin (35); /* error code */ %include iocb; %include tape_ansi_cseg; %include tape_ansi_fd; %include tape_ansi_fl; %include ansi_vol1; %include ibm_vol1; %include ansi_hdr1; %include ansi_hdr2; %include ibm_hdr1; %include ibm_hdr2; %include rcp_volume_formats; %include rcp_resource_types; /* automatic storage */ dcl answer char (128) varying, cc fixed bin, /* consistency code */ /* 0 - invalidate volume position */ /* 1 - invalidate volume position and current file link */ /* 2 - invalidate position, current file link, write EOV TM */ com_text char (64) varying, (eofs, close_eot, format_override, new_link) bit (1), mask bit (36) aligned, testP ptr, search_id char (17), /* search file chain/tape for this file id */ t fixed bin, t1 picture "9", t2 picture "99", t4 picture "9999", t5 picture "99999", t6 picture "999999", tstring char (32) varying, /* open description temporary */ vn char (32); /* volume name */ dcl 1 qi aligned, /* query info structure */ 2 version fixed bin init (2), 2 yes_no bit (1) unaligned, 2 suppress_name bit (1) unaligned, 2 scode fixed bin (35), 2 qcode fixed bin (35) init (0); /* internal static */ dcl ansi_format_chars char (4) internal static init ("UFDS"), ibm_format_chars char (4) internal static init ("UFVV"), ibm_block_codes char (4) internal static init (" BSR"), l1id (3) char (4) internal static init ("HDR1", "EOF1", "EOV1"), l2id (3) char (4) internal static init ("HDR2", "EOF2", "EOV2"), tag (4) char (12) varying internal static init (" -extend", " -modify", " -generate", " -create"); dcl dummy_label (2) char (76) internal static init ( "0000000000000000000000000000000000000000000000000000000000000000000000000000", /* IBM dummy HDR1 label */ "!!DUMMY FILE ID!!******00010001000100 00000 00000 000000MULTICS ANSI "); /* ANSI dummy HDR1/EOF1 label */ dcl max_reclen (3) fixed bin internal static init (99999, 32756, 32763); /* ANSI - OS/VS - DOS/VM */ dcl UL (2) char (3) internal static init ("UHL", "UTL"); /* user label id's */ dcl debug bit (1) internal static initial ("0"b); /* debug switch */ /* based storage */ dcl label_type char (3) based (addr (cseg.lbl_buf)); dcl sync_buf char (80) based (cseg.syncP); /* 80 character overlay on synchronous IO buffer */ /* conditions */ dcl (any_other, area, cleanup, conversion) condition; /* builtin functions */ dcl (addr, bit, char, fixed, index, length, ltrim, max, mod, null, prec, substr, verify) builtin; /* external procedures */ dcl tape_ansi_lrec_io_$close ext entry (ptr, fixed bin (35)), tape_ansi_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), tape_ansi_lrec_io_$write_record ext entry (ptr, ptr, fixed bin (21), fixed bin (35)), ascii_to_ebcdic_ ext entry (char (*), char (*)), command_query_ ext entry options (variable), continue_to_signal_ ext entry (fixed bin (35)), tape_ansi_control_ ext entry (ptr, char (*), ptr, fixed bin (35)), tape_ansi_detach_ ext entry (ptr, fixed bin (35)), ebcdic_to_ascii_ ext entry (char (*), char (*)), tape_ansi_file_cntl_$close ext entry (ptr, fixed bin (35)), tape_ansi_file_cntl_$open ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)), hcs_$reset_ips_mask ext entry (bit (36) aligned, bit (36) aligned), hcs_$set_ips_mask ext entry (bit (36) aligned, bit (36) aligned), tape_ansi_ibm_lrec_io_$close ext entry (ptr, fixed bin (35)), tape_ansi_ibm_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), tape_ansi_ibm_lrec_io_$write_record ext entry (ptr, ptr, fixed bin (21), fixed bin (35)), ioa_ ext entry options (variable), iox_$propagate ext entry (ptr), tape_ansi_mount_cntl_$mount ext entry (ptr, fixed bin, fixed bin (35)), tape_ansi_mount_cntl_$remount ext entry (ptr, fixed bin, fixed bin, fixed bin (35)), tape_ansi_position_ ext entry (ptr, fixed bin, fixed bin (21), fixed bin (35)), tape_ansi_read_length_ ext entry (ptr, fixed bin (21), fixed bin (35)), tape_ansi_tape_io_$get_buffer ext entry (ptr, ptr, fixed bin (35)), tape_ansi_tape_io_$open ext entry (ptr), tape_ansi_tape_io_$order ext entry (ptr, char (3), fixed bin, fixed bin (35)), tape_ansi_tape_io_$sync_read ext entry (ptr, fixed bin, fixed bin (35)), tape_ansi_tape_io_$sync_write ext entry (ptr, fixed bin, fixed bin (35)), terminate_process_ ext entry (char (*), ptr), canon_for_volume_label_ ext entry (char (*), char (*), char (*), fixed bin, fixed bin (35)), authenticate_ ext entry (char (*)) returns (char (3) aligned); /* external static */ dcl ( error_table_$device_limit_exceeded, error_table_$discrepant_block_count, error_table_$duplicate_file_id, error_table_$eof_record, error_table_$end_of_info, error_table_$eov_on_write, error_table_$file_aborted, error_table_$file_busy, error_table_$incompatible_attach, error_table_$incompatible_encoding_mode, error_table_$incompatible_file_attribute, error_table_$insufficient_open, error_table_$invalid_block_length, error_table_$invalid_cseg, error_table_$invalid_expiration, error_table_$invalid_file_set_format, error_table_$invalid_label_format, error_table_$invalid_record_length, error_table_$invalid_volume_sequence, error_table_$noalloc, error_table_$no_file, error_table_$no_next_volume, error_table_$positioned_on_bot, error_table_$unable_to_do_io, error_table_$unexpired_file, error_table_$unexpired_volume, error_table_$uninitialized_volume ) fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) external static; open: entry (iocbP, open_mode, extend_bit, code); cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to control segment */ if cseg.invalid then do; /* is control segment invalid? */ code = error_table_$invalid_cseg; return; end; if cseg.file_lock then do; /* is file in use (by previous invocation)? */ code = error_table_$file_busy; return; end; else do; cc = 0; /* minimal consistency requirement */ on cleanup begin; /* insure file chain <--> tape consistency */ call consistent; cseg.file_lock = "0"b; /* unlock the file */ end; cseg.file_lock = "1"b; /* not in use - now it is */ end; if extend_bit then do; /* extend at open time not allowed */ bad_open: code = error_table_$incompatible_attach; go to valid_exit; end; if open_mode = 4 then do; /* sequential input */ tstring = "sequential_input"; /* set for open description */ search_id = fd.file_id; /* set search identifier */ end; else do; /* sequential output */ if cseg.output_mode = 0 then go to bad_open; /* no output mode specified */ if open_mode = 5 then tstring = "sequential_output"; else go to bad_open; tstring = tstring || tag (output_mode); /* append output mode keyword */ if cseg.replace_id ^= "" then search_id = cseg.replace_id; /* search for the replace name */ else search_id = fd.file_id; /* otherwise, search for -name file_id */ end; cseg.open_mode = open_mode; /* save open mode in control segment */ on area begin; /* handle full control segment */ code = error_table_$noalloc; go to er_exit; end; new_link = "0"b; /* initialize for searching */ cseg.flP = cseg.fcP; /* start at beginning of chain */ do testP = fl.nextP repeat fl.nextP; /* loop through file chain */ if testP ^= null then cseg.flP = testP; /* link exists - use it */ else do; /* link does not exist - build it */ new_link = "1"b; /* this is a new link */ cc = 1; /* don't leave defective links */ call build1 (code); /* make the link */ if code ^= 0 then go to er_exit; end; if fl.flX = -1 then do; /* the link is an end-of-file-set link */ if append_file () then go to create_file; /* appending file to eofs */ else do; /* not appending, therefore file not found */ code = error_table_$no_file; go to valid_exit; end; end; if desired_file () then do; /* found our file */ if cseg.open_mode = 4 then do; /* opened for sequential_input */ if ^new_link then call desired_check; /* check chain-tape consistency */ go to input; end; else do; /* opened for sequential_output */ if cseg.output_mode = 1 then go to extend_chain; /* -extend - get to last section */ else do; /* -modify, -generate, or -create */ if ^new_link then call desired_check; /* check chain-tape consistency at 1st section */ if cseg.output_mode = 2 then go to extend_chain; /* need version # from last section */ else do; /* -generate or -create */ if fd.expiration > fl.backP -> fl.expiration then do; /* check expiration */ code = error_table_$invalid_expiration; go to valid_exit; end; go to output; end; end; end; end; if new_link then do; /* new link - only partially built */ call build2 (code); if code ^= 0 then go to er_exit; end; end; extend_chain: /* extend file chain to last section */ if debug then call debug_print ("extend_chain"); if new_link then do; /* complete link if just built */ call build2 (code); if code ^= 0 then go to er_exit; end; testP = cseg.flP; /* save pointer to first section's link */ do while (fl.eox = 2); /* get to last section */ if fl.nextP = null then do; /* next link doesn't exist */ new_link = "1"b; /* indicate new links in chain */ cc = 1; /* don't leave defective links */ call build1 (code); /* build it */ if code ^= 0 then go to er_exit; if fl.flX = -1 then do; /* trouble - need more sections, but eofs */ code = error_table_$invalid_file_set_format; go to valid_exit; /* an error, but all is consistent */ end; call build2 (code); if code ^= 0 then go to er_exit; end; else cseg.flP = fl.nextP; /* link exists */ end; if cseg.output_mode = 1 then do; /* extending chain for -extend */ if ^new_link then call desired_check; /* check chain-tape consistency */ go to output; end; else do; /* extended chain for -modify */ cseg.flP = testP; /* restore pointer to first section's link */ go to output; end; input: /* file is to be read */ if debug then call debug_print ("input"); cc = 0; /* minimal consistency requirement */ call setup_for_read; /* complete file data from file link */ call lrec_open; /* perform final checks and initialization */ /* INSERT USER LABEL PROCESSING HERE */ call move_tape_ (fl.vlX, fl.flX, 1, code); /* move to 1st data block */ if code ^= 0 then go to er_exit; go to done; /* set up iocb and exit */ output: if debug then call debug_print ("output"); /* extend, modify, generate, or create file */ cc = 0; /* minimal consistency requirement */ if ^cseg.force then do; /* check if file is expired */ if fl.expiration > fd.creation then do; /* file is not expired */ if ^write_permit () then do; /* user said don't overwrite */ code = error_table_$unexpired_file; go to valid_exit; end; end; end; call truncate_chains; /* truncate file and volume chains */ call build_eofsl; /* append an eofs link */ go to action_type (cseg.output_mode); /* process the file */ extend_file: modify_file: action_type (1): action_type (2): if debug then call debug_print ("extend/modify"); /* INSERT USER LABEL PROCESSING TO READ LABELS BEFORE WRITING DATA */ if cseg.output_mode = 1 then call move_to_EOD; /* position to end of data to extend */ else do; /* modify */ call move_tape_ (fl.vlX, fl.flX, 1, code); /* move to 1st data block */ if code ^= 0 then go to er_exit; end; cc = 1; /* don't leave defective file links */ call setup_for_extend_modify; /* load file data from file link */ call lrec_open; /* perform final checks and initialization */ if cseg.output_mode = 1 then call extend_check; /* should last block be re-written? */ go to done; generate_file: action_type (3): if debug then call debug_print ("generate_file"); cc = 1; /* don't leave defective file links */ call setup_for_generate; go to common; create_file: action_type (4): if debug then call debug_print ("create"); cc = 1; /* don't leave defective file links */ call setup_for_create; /* load file link from file data */ common: call lrec_open; /* perform final checks and initialization */ call move_tape_ (fl.vlX, fl.flX, 0, code); /* position to write header labels */ if code ^= 0 then go to er_exit; cc = 2; /* don't leave defective tape file */ call write_HDRs (code); /* write header labels */ if code ^= 0 then go to er_exit; /* trouble */ call write_TM (1, code); /* write header TM */ if code ^= 0 then if code ^= error_table_$eov_on_write then go to er_exit; /* trouble - (ignore EOT) */ call back_TM (1, code); /* back into headers */ if code ^= 0 then go to er_exit; /* trouble */ go to done; /* fill iocb and exit */ done: mask = "0"b; /* ips interrupts not masked yet */ cseg.open_description.length = length (tstring); /* prepare open description */ cseg.open_description.string = tstring; revert cleanup; on any_other call handler; /* pick up any condition */ call hcs_$set_ips_mask ("0"b, mask); /* mask all ips interrupts */ iocbP -> iocb.actual_iocb_ptr -> iocb.close = tape_ansi_file_cntl_$close; if cseg.open_mode = 5 then do; /* sequential output */ if cseg.standard = 1 then iocbP -> iocb.actual_iocb_ptr -> iocb.write_record = tape_ansi_lrec_io_$write_record; else iocbP -> iocb.actual_iocb_ptr -> iocb.write_record = tape_ansi_ibm_lrec_io_$write_record; end; else do; /* sequential input */ if cseg.standard = 1 then iocbP -> iocb.actual_iocb_ptr -> iocb.read_record = tape_ansi_lrec_io_$read_record; else iocbP -> iocb.actual_iocb_ptr -> iocb.read_record = tape_ansi_ibm_lrec_io_$read_record; iocbP -> iocb.actual_iocb_ptr -> iocb.read_length = tape_ansi_read_length_; iocbP -> iocb.actual_iocb_ptr -> iocb.position = tape_ansi_position_; end; iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_; iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (cseg.open_description); call iox_$propagate (iocbP -> iocb.actual_iocb_ptr); call hcs_$reset_ips_mask (mask, mask); /* permit ips interrupts */ cseg.file_lock = "0"b; /* open complete - unlock the file */ return; er_exit: call consistent; valid_exit: cseg.file_lock = "0"b; /* open complete - unlock the file */ return; abort_file: procedure; /* cleanup after defective file */ if debug then call debug_print ("abort_file"); vl (fl.vlX).cflX = 0; /* invalidate volume position */ qi.yes_no = "1"b; /* want yes or no answer */ qi.suppress_name = "0"b; /* print module name */ qi.scode = error_table_$file_aborted; qi.qcode = 0; call command_query_ (addr (qi), answer, cseg.module, /* query user */ "Error while writing labels of file ""^a"", section ^d. The defective section invalidates the structure of the entire file set. Do you want to delete the defective section?", fl.file_id, fl.section); if answer = "no" then do; /* volume format will be invalid */ call write_TM (2, 0); /* try to write 2 TM anyway */ go to abort_fail1; end; cseg.flP = fl.backP; /* back up to previous section or file */ call truncate_chains; /* truncate file and volume chains */ call build_eofsl; /* add an end of file set link */ if fl.flX = 0 then do; /* bad section was first of file set */ call initialize_volume (1, code); /* initialize the volume */ if code ^= 0 then go to abort_fail; end; else do; /* bad section wasn't first of file set */ if fl.eox = 1 then do; /* bad section was first section of file */ call move_tape_ (fl.vlX, fl.flX + 1, 0, code); /* position to write TM after EOF's */ if code ^= 0 then go to abort_fail; end; else do; /* bad section wasn't first section of file */ call move_tape_ (fl.vlX, fl.flX, 2, code);/* position to re-write trailers */ if code ^= 0 then go to abort_fail; cseg.blkcnt = fl.blkcnt; /* set block count to be recorded */ call write_EOFs (code); /* change EOV to EOF */ if code ^= 0 then go to abort_fail; end; end; call write_TM (2, code); /* write the TMs */ if code ^= 0 then if code ^= error_table_$eov_on_write then go to abort_fail; code = error_table_$file_aborted; return; abort_fail: call ioa_ ("^a: Deletion failed: unable to restore valid file set format.", cseg.module); abort_fail1: vl (fl.vlX).cflX = 0; /* invalidate volume position */ cseg.flP = cseg.fcP; /* set pointer to eliminate file and volume chains */ call truncate_chains; /* wipe the slate clean */ code = error_table_$invalid_file_set_format; return; end abort_file; another_volume: procedure returns (bit (1)); /* queries user for next volume name */ dcl msg char (80) varying; /* message to user */ dcl msg1 char (length (msg)) based (addr (substr (msg, 1))); /* char (*) overlay for command_query_ */ dcl L1 fixed bin; qi.yes_no = "1"b; /* want yes or no */ qi.suppress_name = "0"b; /* don't suppress module name */ qi.scode = error_table_$no_next_volume; qi.qcode = 0; msg = "Reached end of volume. Do you wish to terminate processing of this volume-set?"; call command_query_ (addr (qi), answer, cseg.module, msg1); if answer = "yes" then return ("0"b); /* finito */ qi.yes_no = "0"b; /* don't want yes or no */ qi.suppress_name = "1"b; ask: qi.scode = 0; /* no scode when asking for name */ msg = "Enter volume name of next volume (and optional comment).^/"; ask_raw: call command_query_ (addr (qi), answer, cseg.module, msg1); if answer = "" then go to ask; com_text = ""; /* initialize comment message */ L1 = index (answer, " ") - 1; /* scan for a blank */ if L1 < 0 then L1 = length (answer); call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), substr (answer, 1, L1), vn, 0, code); if code ^= 0 then do; qi.scode = code; msg = substr (answer, 1, L1) || "^/Enter volume name of next volume (and optional comment).^/"; go to ask_raw; end; answer = ltrim (substr (answer, L1 + 1)); if substr (answer, 1, 8) = "-comment" then do; answer = ltrim (substr (answer, 10)); go to comment; end; if substr (answer, 1, 4) = "-com" then do; answer = ltrim (substr (answer, 6)); comment: if length (answer) = 0 then ; /* no comment */ else com_text = answer; end; else if answer = "" then ; else do; /* invalid comment */ call ioa_ ("Comment is invalid."); go to ask; end; return ("1"b); /* volume name is ok - exit */ write_permit: entry returns (bit (1)); /* queries user for write permission */ qi.yes_no = "1"b; /* user must answer yes or no */ qi.suppress_name = "0"b; qi.scode = error_table_$unexpired_file; qi.qcode = 0; call command_query_ (addr (qi), answer, cseg.module, /* ask the user */ "Do you want to overwrite the unexpired file ""^a""?", fl.file_id); if answer = "yes" then return ("1"b); else return ("0"b); end another_volume; append_file: procedure returns (bit (1)); /* determines if a file is an append file */ if debug then call debug_print ("append_file"); /* If the file is an append file, set its sequence number in file */ /* data, and build an eofs link. */ /* */ /* A file is an append file if: */ /* */ /* 1) cseg.open_mode = 5 and cseg.output_mode = 4 */ /* AND */ /* 2) fd.sequence = 0 (-number not specified) or */ /* last sequence number of file set + 1. */ /* AND */ /* 3) -replace not specified */ if cseg.open_mode = 4 then return ("0"b); /* open mode is input */ if cseg.output_mode ^= 4 then return ("0"b); /* output mode is not create */ if cseg.replace_id ^= "" then return ("0"b); /* -replace specified therefore cannot append */ if fd.sequence = 0 then do; /* -number not specified */ if cseg.flP = fd.nextP then fd.sequence = 1; /* file is 1st of new file set */ else fd.sequence = fl.backP -> fl.sequence + 1; /* file is 2, 3, ..... */ end; else do; /* -number specified */ if cseg.flP = fd.nextP then do; /* file must be 1st of new file set */ if fd.sequence = 1 then go to yes; /* and it is */ else return ("0"b); /* isn't - error */ end; else do; /* file need not be first, but last + 1 */ if fd.sequence = fl.backP -> fl.sequence + 1 then go to yes; /* and it is */ else return ("0"b); /* isn't - error */ end; end; yes: if debug then call debug_print ("yes"); if fd.expiration > fl.backP -> fl.expiration then do; /* requested expiration > file set expiration */ code = error_table_$invalid_expiration; go to valid_exit; end; cc = 1; /* insure chain consistency */ call make_eofsl_real; /* make the eofs link a real link */ call build_eofsl; /* add a new eofs link */ return ("1"b); /* done! */ end append_file; back_TM: procedure (n, ecode); /* backs over 1 or 2 TM adjusting volume link */ if debug then call ioa_ ("back_TM ^d", n); dcl n fixed bin, cnt fixed bin, ecode fixed bin (35); do cnt = 1 to n; /* 1 or 2 */ call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode); /* backup over a TM */ if ecode ^= 0 then return; vl (fl.vlX).pos = vl (fl.vlX).pos - 1; if vl (fl.vlX).pos < 0 then do; /* adjust for mod3 */ vl (fl.vlX).pos = vl (fl.vlX).pos + 3; vl (fl.vlX).cflX = vl (fl.vlX).cflX - 1; end; end; return; end back_TM; build1: procedure (ecode); /* build a file link and initialize */ dcl ecode fixed bin (35); if debug then call debug_print ("build1"); call build_fl; /* build a file link */ call move_tape_ (fl.vlX, fl.flX, 0, ecode); /* position to read HDR1 */ if ecode ^= 0 then return; call read_HDR1 (eofs, ecode); /* read the header 1 label */ if ecode ^= 0 then return; if eofs then do; /* reached end of file set */ fl.flX = -1; /* make the link an eofs link */ vl (fl.vlX).lflX = vl (fl.vlX).lflX - 1; /* remove eofs link from volume link */ return; end; call fill_fl_from_HDR1 (ecode); /* validate and store HDR1 data */ if ecode ^= 0 then return; call read_HDR2 (ecode); /* try to read HDR2 label */ if ecode ^= 0 then return; if fl.HDR2 then do; /* if HDR2, validate and store its data */ call fill_fl_from_HDR2 (ecode); if ecode ^= 0 then return; end; return; end build1; build2: procedure (ecode); /* 2nd part of link building */ dcl ecode fixed bin (35); if debug then call debug_print ("build2"); call move_tape_ (fl.vlX, fl.flX, 2, ecode); /* position to trailer labels */ if ecode ^= 0 then return; call process_EOX (ecode); /* process the trailer labels */ return; end build2; build_eofsl: procedure; /* builds an end-of-file-set link */ if debug then call debug_print ("eofsl"); allocate fl in (chain_area) set (fl.nextP); /* build an eofs link */ fl.nextP -> fl.backP = cseg.flP; fl.nextP -> fl.flX = -1; return; end build_eofsl; build_fl: procedure; /* build a file link on end of file chain */ if debug then call debug_print ("build_fl"); allocate fl in (chain_area) set (fl.nextP); /* allocate the link */ fl.nextP -> fl.backP = cseg.flP; /* set new link's back ptr to current link */ cseg.flP = fl.nextP; /* make the new link current */ go to build_fl1; make_eofsl_real: entry; /* makes an eofs link a real link */ if debug then call debug_print ("make_eofsl_real"); build_fl1: fl.flX = fl.backP -> fl.flX + 1; /* set the link index */ if fl.backP -> fl.eox = 2 then do; /* this link will be 1st on new volume */ fl.vlX = fl.backP -> fl.vlX + 1; /* up volume link index for this file link */ vl (fl.vlX).fflX = fl.flX; /* first file link on new volume is this file link */ vl (fl.vlX).lflX = fl.flX; /* last file link on new volume is this file link */ end; else do; /* this link is not on a new volume */ fl.vlX = fl.backP -> fl.vlX; /* use same volume index as previous link */ vl (fl.vlX).lflX = vl (fl.vlX).lflX + 1; /* one more file link on volume */ end; return; end build_fl; consistent: procedure; /* insures file chain/tape consistency */ if debug then call debug_print ("consistent"); go to recovery (cc); /* perform appropriate consistency processing */ recovery (0): if cseg.flP ^= null then vl (fl.vlX).cflX = 0; /* invalidate volume position */ return; recovery (1): if cseg.flP = null then return; /* nothing can be done - exit */ vl (fl.vlX).cflX = 0; /* invalidate volume position */ cseg.flP = fl.backP; /* set pointer to previous link */ call truncate_chains; /* truncate file and volume chains */ return; recovery (2): if cseg.flP = null then return; /* nothing can be done - exit */ call abort_file; /* truncate file and volume chains, write TM */ return; end consistent; creating_first: procedure returns (bit (1)); /* determines if creating 1st file of new file set */ if debug then call debug_print ("creating_first?"); if cseg.open_mode = 4 then return ("0"b); if cseg.output_mode ^= 4 then return ("0"b); if fd.sequence ^= 1 then return ("0"b); if cseg.replace_id ^= "" then return ("0"b); return ("1"b); end creating_first; desired_check: procedure; /* insures that tape and file chain are consistent */ dcl can_retry bit (1) initial ("1"b); /* permits 1 retry after re-positioning */ if debug then call debug_print ("desired_check"); last_chance: call move_tape_ (fl.vlX, fl.flX, 0, code); /* position to HDR labels */ if code ^= 0 then go to er_exit; call read_HDR1 (eofs, code); /* read HDR1 label */ if code ^= 0 then go to er_exit; if eofs then do; /* end of file set - shouldn't happen */ chain_tape_error: if debug then call debug_print ("chain_tape_error"); if can_retry then do; /* re-position and try again */ can_retry = "0"b; /* can only re-try once */ vl (fl.vlX).cflX = 0; /* force rewind and re-position */ go to last_chance; /* try again */ end; code = error_table_$invalid_cseg; /* re-try failed - disaster */ cseg.invalid = "1"b; /* note for eventual deletion of cseg */ go to er_exit; end; if cseg.standard = 1 then do; /* ANSI */ if ansi_hdr1.file_id ^= fl.file_id then go to chain_tape_error; /* file id's must be identical */ on conversion go to chain_tape_error; if fixed (ansi_hdr1.section) ^= fl.section then go to chain_tape_error; /* and section */ revert conversion; end; else if ibm_hdr1.dataset_id ^= fl.file_id then go to chain_tape_error; /* IBM */ return; end desired_check; desired_file: procedure returns (bit (1)); /* determines if file wanted is current link */ if debug then call debug_print ("desired_file?"); if fl.section ^= 1 then do; /* don't investigate non-initial sections */ if debug then call debug_print ("sec ne 1"); return ("0"b); end; if fd.sequence ^= 0 then do; /* -number specified */ if search_id = "" then do; /* -name (or -replace) not specified */ if fd.sequence = fl.sequence then go to match; /* sequences match */ else go to no; /* sequences don't match */ end; else do; /* -name/replace specified */ if fd.sequence = fl.sequence then do; /* -number matches */ if cseg.replace_id ^= "" then do; /* -replace specified? */ if cseg.replace_id = fl.file_id then go to match; /* found it */ code = error_table_$no_file; /* file doesn't exist */ go to valid_exit; end; if fd.file_id = fl.file_id then go to match; /* -name specified */ if cseg.open_mode = 5 & cseg.output_mode = 4 then go to match; /* creation */ code = error_table_$no_file; /* file doesn't exist */ go to valid_exit; end; else go to no; /* -number doesn't match */ end; end; else do; /* -number not specified */ if search_id = fl.file_id then do; /* names match */ fd.sequence = fl.sequence; /* set sequence in case not specified */ match: if debug then call debug_print ("yes"); return ("1"b); end; no: if debug then call debug_print ("no"); if cseg.output_mode = 4 then do; /* if -create specified */ if cseg.open_mode = 5 then do; /* and actually opened for output */ if fd.file_id = fl.file_id then do; /* then names cannot be the same */ code = error_table_$duplicate_file_id; /* if not desired file */ go to valid_exit; end; end; end; return ("0"b); end; end desired_file; extend_check: procedure; /* checks if necessary to re-write last block */ dcl buf char (8192) based aligned; /* IO buffer overlay */ dcl (i, j) fixed bin; /* temporaries */ if debug then call debug_print ("extend_check"); if cseg.blkcnt = 0 then return; /* no last blockto re-write */ if fd.format ^= 2 then return; /* only FB format might need re-writing */ if ^fd.blocked then return; call tape_ansi_tape_io_$order (cP, "bsr", 0, code); /* position to read last block */ if code ^= 0 then go to er_exit; call tape_ansi_tape_io_$sync_read (cP, cseg.offset, code); if code ^= 0 then go to er_exit; if cseg.standard = 2 then do; /* IBM labeled tape */ if mod (cseg.offset, fd.reclen) ^= 0 then return; /* ^integral # of records */ if cseg.offset >= fd.blklen then return; /* block is full */ else go to rewrite; /* more records can fit in block */ end; if cseg.offset > fd.blklen then cseg.offset = fd.blklen; /* ANSI - eliminate obvious padding */ i = mod ((cseg.offset - fd.bo), fd.reclen); /* # of chars not in complete record */ if i ^= 0 then do; /* if any, see if all padding */ if verify (substr (cseg.syncP -> buf, cseg.offset - i + 1, i), "^") ^= 0 then return; /* not all padding, irregularity */ else cseg.offset = cseg.offset - i; /* all padding, must continue checking */ end; i = (cseg.offset - fd.bo) / fd.reclen; /* get # of complete records */ do j = i to 1 by -1; /* test each record for all "^" */ if verify (substr (cseg.syncP -> buf, fd.bo + ((j - 1) * fd.reclen) + 1, fd.reclen), "^") = 0 then cseg.offset = cseg.offset - fd.reclen; /* drop padding */ else go to rewrite_test; /* not padding - test if block full */ end; rewrite_test: if cseg.offset >= fd.blklen then return; /* block is full */ rewrite: call tape_ansi_tape_io_$order (cP, "bsr", 0, code); /* position to rewrite */ if code ^= 0 then go to er_exit; call tape_ansi_tape_io_$get_buffer (cP, cseg.lrec.bufP, code); /* getting an IO buffer causes */ if code ^= 0 then go to er_exit; /* iox_$close to call xxx_lrec_io_$close */ cseg.blkcnt = cseg.blkcnt - 1; /* so block count must now reflect tape position */ substr (cseg.lrec.bufP -> buf, 1, cseg.offset) = substr (cseg.syncP -> buf, 1, cseg.offset); return; end extend_check; fill_XXX1: procedure (x); /* formats labels for output */ dcl x fixed bin; /* 1 - HDR | 2 - EOF | 3 - EOV */ if debug then call debug_print ("fill_XXX1"); ansi_hdr1P, ibm_hdr1P = addr (lbl_buf); /* ANSI:IBM common - set pointer to label IO buffer */ ansi_hdr1.label_id = l1id (x); /* set label identifier */ ansi_hdr1.file_id = fl.file_id; /* IBM - dataset_id */ ansi_hdr1.set_id = fl.canonical_set_id; /* IBM - dataset_serial */ if cseg.standard = 1 then do; /* ANSI */ t4 = fl.section; ansi_hdr1.section = t4; end; else do; t4 = fl.vlX; ibm_hdr1.volume_sequence = t4; end; if fl.generation = 0 & cseg.standard ^= 1 then do; /* consider ANSI 0000 (=10000) case */ ibm_hdr1.generation = ""; ibm_hdr1.version = ""; end; else do; t4 = fl.generation; ansi_hdr1.generation = t4; t2 = fl.version; ansi_hdr1.version = t2; end; t4 = fl.sequence; ansi_hdr1.sequence = t4; ansi_hdr1.creation = " " || fl.creation; ansi_hdr1.expiration = " " || fl.expiration; ansi_hdr1.access = fl.access; if x = 1 then ansi_hdr1.blkcnt = "000000"; else do; t6 = cseg.lrec.blkcnt; ansi_hdr1.blkcnt = t6; end; ansi_hdr1.system = fl.system; ansi_hdr1.reserved = ""; return; end fill_XXX1; fill_XXX2: procedure (x); /* formats 2nd header/trailer label for writing */ dcl x fixed bin; if debug then call debug_print ("fill_XXX2"); if cseg.standard ^= 1 then go to IBM_fill_XXX2; ansi_hdr2P = addr (lbl_buf); /* set pointer to label IO buffer */ ansi_hdr2.label_id = l2id (x); ansi_hdr2.format = substr (ansi_format_chars, fl.format, 1); t5 = fl.blklen; ansi_hdr2.blklen = t5; t5 = fl.reclen; ansi_hdr2.reclen = t5; if fl.system = fd.system then do; /* fill these fields only on parochial file */ if x = 1 then ansi_hdr2.next_volname = ""; else ansi_hdr2.next_volname = fl.next_volname; ansi_hdr2.blocked = char (fl.blocked); t1 = fl.mode; ansi_hdr2.mode = t1; end; else do; ansi_hdr2.next_volname = ""; ansi_hdr2.blocked = ""; ansi_hdr2.mode = ""; end; ansi_hdr2.system_reserved = ""; t2 = fl.bo; ansi_hdr2.buffer_offset = t2; ansi_hdr2.reserved = ""; return; IBM_fill_XXX2: ibm_hdr2P = addr (cseg.lbl_buf); ibm_hdr2.label_id = l2id (x); ibm_hdr2.format = substr (ibm_format_chars, fl.format, 1); t5 = fl.blklen; ibm_hdr2.blksize = t5; t5 = fl.reclen; ibm_hdr2.lrecl = t5; t1 = cseg.density; ibm_hdr2.density = t1; if fl.section > 1 then ibm_hdr2.dataset_position = "1"; else ibm_hdr2.dataset_position = "0"; ibm_hdr2.jobstep_id = "MULTICS /" || fd.creation; ibm_hdr2.recording_technique = ""; ibm_hdr2.control_characters = fl.cc; ibm_hdr2.reserved1 = ""; if ^fl.blocked then t = 1; /* records not blocked */ else t = 2; /* records blocked */ if fl.format = 4 then t = t + 2; /* spanned records */ ibm_hdr2.block_attribute = substr (ibm_block_codes, t, 1); /* pick out block code */ ibm_hdr2.reserved2 = ""; return; end fill_XXX2; fill_fl_from_HDR1: procedure (ecode); /* fills file link from HDR1 data */ dcl ecode fixed bin (35); dcl nv fixed bin; if debug then call debug_print ("fill_fl_from_HDR1"); on conversion go to bad_hdr1; go to re_fill (cseg.standard); /* processing for ANSI or IBM */ re_fill (1): fl.file_id = ansi_hdr1.file_id; fl.set_id = cseg.vl (fl.vlX).volname; fl.canonical_set_id = ansi_hdr1.set_id; fl.section = fixed (ansi_hdr1.section, 17); if fl.section = 0 then go to bad_hdr1; fl.sequence = fixed (ansi_hdr1.sequence, 17); if fl.sequence = 0 then go to bad_hdr1; if fl.section = 1 then do; /* check volume sequence validity */ if fl.sequence = 1 then do; /* file 1, section 1 */ if fl.flX ^= 1 then do; /* must be first link in file chain */ bad_seq: ecode = error_table_$invalid_volume_sequence; return; end; end; else do; /* file n > 1, section 1 */ if fl.flX = 1 then do; /* cannot be first link in file chain */ new_file_set: if ^creating_first () then go to bad_seq; /* unless creating 1st file */ if substr (ansi_hdr1.expiration, 2, 5) <= fd.creation then go to re_init; if initialize_permitA (fl.vlX) then do; /* not expired - query user for permission */ re_init: call initialize_volume (fl.vlX, ecode); /* said ok (or expired) - do it */ if ecode ^= 0 then return; call move_tape_ (fl.vlX, fl.flX, 0, ecode); /* re-position to HDR1 */ if ecode ^= 0 then return; call read_HDR1 (eofs, ecode); /* read HDR1 - eof can't happen */ if ecode ^= 0 then return; go to re_fill (cseg.standard);/* processing for ANSI or IBM */ end; ecode = error_table_$unexpired_volume; /* user said no */ return; end; else if fl.backP -> fl.eox = 2 then go to bad_seq; /* previous file section must be last */ end; end; else do; /* file n >_ 1, section n > 1 */ if fl.flX = 1 then go to new_file_set; /* cannot be first link in file chain */ if fl.section ^= fl.backP -> fl.section + 1 then go to bad_seq; /* section must be 1 more than previous */ end; finish_up: fl.generation = fixed (ansi_hdr1.generation, 17); fl.version = fixed (ansi_hdr1.version, 17); fl.creation = substr (ansi_hdr1.creation, 2, 5); fl.expiration = substr (ansi_hdr1.expiration, 2, 5); fl.access = ansi_hdr1.access; fl.blkcnt = fixed (ansi_hdr1.blkcnt, 35); fl.system = ansi_hdr1.system; return; re_fill (2): re_fill (3): fl.file_id = ibm_hdr1.dataset_id; fl.set_id = cseg.vl (fl.vlX).volname; fl.canonical_set_id = ibm_hdr1.dataset_serial; nv = fixed (ibm_hdr1.volume_sequence, 17); if nv = 0 then do; /* volume sequence is 0 */ if substr (lbl_buf, 5, 76) = dummy_label (1) then do; /* HDR1 is a dummy */ if fl.flX = 1 then if ^creating_first () then do; /* if so, only creating 1st file */ ecode = error_table_$no_file; /* ...of new file set has meaning */ return; end; fl.section = 1; /* force meaningful values */ fl.sequence = 1; go to finish_up; end; else go to bad_hdr1; /* not dummy HDR1, an error */ end; if fl.flX = 1 then fl.section = 1; /* dummy up section number */ else do; /* tests can be made */ if fl.backP -> fl.file_id = fl.file_id then fl.section = fl.backP -> fl.section + 1; else fl.section = 1; end; fl.sequence = fixed (ibm_hdr1.dataset_sequence, 17); if fl.sequence = 0 then go to bad_hdr1; if nv = 1 then do; /* label says 1st volume */ if fl.vlX = 1 then ; /* and so it is */ else go to bad_seq; /* definite error */ end; else if fl.vlX ^= nv then go to new_file_set; /* volume isn't _nth - see why */ if fl.sequence = 1 then do; /* check file and volume sequences */ if nv = 1 then do; /* file 1 on volume 1 */ if fl.flX ^= 1 then go to bad_seq; /* must be 1st file link */ else ; /* it is, fine */ end; else do; /* file 1 on volume nv > 1 */ if nv = fl.backP -> fl.vlX + 1 then ; /* fine, volumes in sequence */ else go to bad_seq; end; end; else if fl.flX = 1 then go to new_file_set; /* perhaps error - find out */ go to finish_up; bad_hdr1: ecode = error_table_$invalid_label_format; return; end fill_fl_from_HDR1; fill_fl_from_HDR2: procedure (ecode); /* fills file link from HDR2 data */ dcl ecode fixed bin (35); dcl canon_std (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape); if debug then call debug_print ("fill_fl_from_HDR2"); on conversion go to bad_hdr2; if cseg.standard ^= 1 then go to IBM_fill_fl_from_HDR2; fl.format = index (ansi_format_chars, ansi_hdr2.format); if fl.format = 0 then go to bad_hdr2; fl.blklen = fixed (ansi_hdr2.blklen, 17); if fl.blklen = 0 then go to bad_hdr2; if fl.blklen > cseg.buf_size then do; /* we don't have enough room to read it */ fl.blklen = fl.blklen + mod (fl.blklen, 4); /* make it mod 4 */ call ioa_ ("^a^/Reattach with a ""-block ^d"" specification.", "Block size in HDR2 label > block size allowed for this attachment.", fl.blklen); go to bad_hdr2; end; if fl.format ^= 1 then fl.reclen = fixed (ansi_hdr2.reclen, 17); /* reclen only for F, D, and S */ if fl.system ^= "" then do; /* fields may be valid */ fl.bo = fixed (ansi_hdr2.buffer_offset, 17); if fl.system = fd.system then do; /* following is system specific */ if old_ansi_hdr2_system_use.system_reserved = "" then do; /* old-format hdr2 label */ fl.blocked = bit (old_ansi_hdr2_system_use.blocked); fl.mode = fixed (old_ansi_hdr2_system_use.mode, 17); fl.canonical_next_volname = old_ansi_hdr2_system_use.canonical_next_volname; fl.next_volname = ""; end; else do; fl.blocked = bit (ansi_hdr2.system_use.blocked); fl.mode = fixed (ansi_hdr2.system_use.mode, 17); fl.next_volname = ansi_hdr2.system_use.next_volname; if fl.next_volname ^= "" then do; call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), fl.next_volname, fl.canonical_next_volname, canon_std (cseg.standard), ecode); if ecode ^= 0 then goto bad_hdr2; end; else fl.canonical_next_volname = ""; end; end; end; return; IBM_fill_fl_from_HDR2: fl.format = index (ibm_format_chars, ibm_hdr2.format); if fl.format = 0 then go to bad_hdr2; fl.blklen = fixed (ibm_hdr2.blksize, 17); if fl.blklen = 0 then go to bad_hdr2; if fl.format ^= 1 then fl.reclen = fixed (ibm_hdr2.lrecl, 17); /* reclen only for F and V */ /* t = fixed (ibm_hdr2.density, 17); This is stupid. Since we are already */ /* if cseg.density ^= t reading the tape at the right density, who cares */ /* then go to bad_hdr2; what the HDR2 label says the density is. */ if ibm_hdr2.dataset_position = "1" then do; /* should not be 1st volume */ if fl.vlX = 1 then go to bad_hdr2; /* cant be 1st vol */ if fl.backP -> fl.eox ^= 2 then go to bad_hdr2; /* previous must have EOV labels */ end; if ibm_hdr2.recording_technique ^= "" then go to bad_hdr2; t = index (ibm_block_codes, ibm_hdr2.block_attribute); if t = 0 then go to bad_hdr2; if t > 2 then do; /* indicated spanned blocks */ t = t - 2; if fl.format = 3 then /* set it to V spanned only if hdr2.format is "V" */ fl.format = 4; end; if t = 1 then fl.blocked = "0"b; else fl.blocked = "1"b; fl.cc = ibm_hdr2.control_characters; return; bad_hdr2: ecode = error_table_$invalid_label_format; return; end fill_fl_from_HDR2; fill_fdhdr2_from_fl: procedure; /* fills fd hdr2 data from fl if section has HDR2 */ if debug then call debug_print ("fill_fdhdr2_from_fl"); if fl.HDR2 then do; /* fill only if HDR2 exists */ if fd.format ^= 0 then do; /* -format in attach description */ if fd.format ^= fl.format then do; /* incompatible file attribute specification */ mis_match: code = error_table_$incompatible_file_attribute; go to er_exit; end; else format_override = "1"b; /* -format's blocking attribute to be used */ end; else do; /* -format not specified */ fd.format = fl.format; /* use value from HDR2 */ format_override = "0"b; /* blocking attribute not specified */ end; if fd.blklen ^= 0 then do; if fd.blklen ^= fl.blklen then go to mis_match; else ; end; else fd.blklen = fl.blklen; if fd.format ^= 1 then do; /* record length undefined for U format */ if fd.reclen ^= 0 then do; /* only test if specified */ if fd.reclen <= max_reclen (cseg.standard) then do; /* fits in HDR2 reclen field */ if fd.reclen ^= fl.reclen then go to mis_match; /* must match */ else ; /* ok */ end; else if fl.reclen ^= 0 then go to mis_match; /* doesn't fit - 0 */ end; fd.reclen = fl.reclen; end; if cseg.standard = 1 then do; /* ANSI */ if fl.system ^= "" then do; /* certain HDR2 fields are valid */ fd.bo = fl.bo; /* CANNOT BE USER-SPECIFIED */ if fl.system = fd.system then do; /* system-defined data is valid */ if format_override then do; /* blocking attributes must match */ if fd.blocked ^= fl.blocked then go to mis_match; else ; end; else fd.blocked = fl.blocked; if fd.mode ^= 0 then do; if fd.mode ^= fl.mode then go to mis_match; else ; end; else fd.mode = fl.mode; end; end; else fd.bo = 0; /* must be 0 if fl.system = "" */ end; else do; /* IBM */ if format_override then do; if fd.blocked ^= fl.blocked then go to mis_match; else ; end; else fd.blocked = fl.blocked; fd.cc = fl.cc; /* CANNOT BE USER-SPECIFIED */ end; end; return; end fill_fdhdr2_from_fl; fill_flhdr2_from_fd: procedure; /* fill fl hdr2 data from fd and defaults */ if debug then call debug_print ("fill_flhdr2_from_fd"); if fd.format = 0 then do; /* apply defaults */ if cseg.output_mode ^= 4 then do; /* defaults permitted only for create */ no_defaults: code = error_table_$insufficient_open; go to er_exit; end; fd.format = 3; /* D or V format */ fd.blocked = "1"b; /* blocked */ end; fl.format = fd.format; fl.blocked = fd.blocked; if fd.blklen = 0 then do; /* apply defaults */ if cseg.output_mode ^= 4 then go to no_defaults; if cseg.standard = 1 then fd.blklen = 2048; /* ANSI */ else fd.blklen = 8192; /* IBM */ end; fl.blklen = fd.blklen; if fd.reclen = 0 then do; /* apply defaults */ if cseg.output_mode ^= 4 then go to no_defaults; go to default_reclen (fd.format); /* perform appropriate reclen default action */ default_reclen (2): fd.reclen = fd.blklen; /* F format */ go to set_fl_reclen; default_reclen (3): if cseg.standard = 1 then fd.reclen = fd.blklen; /* D format */ else fd.reclen = fd.blklen - 4; /* V format */ go to set_fl_reclen; default_reclen (4): fd.reclen = prec (sys_info$max_seg_size * 4, 21); /* S or VS format */ end; default_reclen (1): /* U format - 0 is correct */ set_fl_reclen: if fd.reclen > max_reclen (cseg.standard) then fl.reclen = 0; else fl.reclen = fd.reclen; if fd.mode = 0 then do; /* apply defaults */ if cseg.standard = 1 then fd.mode = 1; /* ANSI - ASCII */ else fd.mode = 2; /* IBM - EBCDIC */ end; fl.mode = fd.mode; fl.cc = fd.cc; fl.bo = 0; fl.next_volname, fl.canonical_next_volname = ""; return; end fill_flhdr2_from_fd; fill_new_section_fl: procedure; /* initializes new file section link */ if debug then call debug_print ("fill_new_section_fl"); fl.file_id = fl.backP -> fl.file_id; /* copy from previous link */ fl.set_id = fl.backP -> fl.set_id; fl.canonical_set_id = fl.backP -> fl.canonical_set_id; fl.section = fl.backP -> fl.section + 1; /* increment section number */ fl.sequence = fl.backP -> fl.sequence; fl.generation = fl.backP -> fl.generation; fl.version = fl.backP -> fl.version; fl.creation = fl.backP -> fl.creation; fl.expiration = fl.backP -> fl.expiration; fl.access = fl.backP -> fl.access; fl.blkcnt = 0; fl.system = fd.system; fl.hdr2 = fl.backP -> fl.hdr2; fl.next_volname, fl.canonical_next_volname = ""; /* initialize */ return; end fill_new_section_fl; handler: procedure; /* intercept any faults during iocb manipulation */ dcl 1 ti aligned, 2 version fixed bin init (0), 2 code fixed bin (35); if mask ^= "0"b then do; /* IPS interrupts masked */ ti.code = error_table_$unable_to_do_io; /* very bad trouble */ call terminate_process_ ("fatal_error", addr (ti)); /* kill the process */ end; call continue_to_signal_ (0); return; end handler; initialize_permit: procedure (vX) returns (bit (1)); /* query for permission to write VOL1 label */ dcl vX fixed bin; dcl msg char (120) varying; dcl (extra1, extra2) char (12) varying initial (""); qi.scode = error_table_$uninitialized_volume; /* set status code */ go to query (vl (vX).write_VOL1); /* issue appropriate query */ initialize_permitA: entry (vX) returns (bit (1)); /* query to initialize an unexpired volume */ qi.qcode = 0; qi.scode = error_table_$unexpired_volume; msg = "Volume ^a requires initialization, but contains an unexpired file.^/Do you want to initialize it?"; go to ip_com; query (2): qi.qcode = 1; /* unreadable 1st block */ msg = "Volume ^a requires initialization: first block is unreadable.^/Do you want to initialize it?"; go to ip_com; query (3): qi.qcode = 2; /* first block isn't VOL1 label */ msg = "Volume ^a requires initialization: first block is not VOL1 label.^/Do you want to initialize it?"; go to ip_com; query (4): qi.qcode = 3; /* VOL1 label has wrong volid */ extra1 = substr (cseg.lbl_buf, 5, 6); /* volid encountered */ extra2 = vl (vX).canonical_volname; /* volid expected */ msg = "Warning: Label for volume ^a contains identifier ^a instead of ^a.^/"; if cseg.open_mode = 4 then /* Volume is read-only */ msg = msg || "Do you really want to continue processing?"; else msg = msg || "Do you want to reinitialize it as the desired volume?"; /* can write to the tape */ go to ip_com; query (5): qi.qcode = 4; /* VOL1 label correct, but wrong density */ msg = "Volume ^a requires initialization: recorded at incorrect density.^/Do you want to re-initialize it?"; go to ip_com; query (6): qi.qcode = 5; /* VOL1 label correct, but invalid file-set format */ msg = "Volume ^a requires initialization: recorded in an invalid file-set format.^/Do you want to re-initialize it?"; ip_com: qi.yes_no = "1"b; qi.suppress_name = "0"b; call command_query_ (addr (qi), answer, cseg.module, (msg), vl (vX).volname, extra1, extra2); if answer = "yes" then return ("1"b); else return ("0"b); end initialize_permit; initialize_volume: procedure (vX, ecode); /* initializes a volume with VOL1 label and 1 dummy file */ dcl vX fixed bin, /* volume link index */ ecode fixed bin (35); /* error code */ dcl (i, j, k) fixed bin; /* temporary indices */ if debug then call debug_print ("initialize_volume"); vl (vX).auth_code = authenticate_ (vl (vX).volname); vl (vX).cflX = 0; call tape_ansi_tape_io_$order (cP, "rew", 0, ecode); /* get to beginning of tape */ if ecode ^= 0 then return; ansi_vol1P, ibm_vol1P = addr (cseg.lbl_buf); /* get pointer to label buffer */ ansi_vol1.label_id = "VOL1"; /* initialize VOL1 label */ ansi_vol1.volume_id = vl (vX).canonical_volname; if cseg.standard = 1 then do; /* ANSI */ ansi_vol1.access = " "; ansi_vol1.reserved1 = " "; ansi_vol1.owner_id = vl (vX).auth_code; ansi_vol1.reserved2 = " "; ansi_vol1.label_version = "3"; k = 2; /* set HDR loop limit */ end; else do; /* IBM */ ibm_vol1.reserved1 = "0"; ibm_vol1.VTOC_pointer = " "; ibm_vol1.reserved2 = " "; ibm_vol1.owner_id = vl (vX).auth_code; ibm_vol1.reserved3 = " "; k = 1; /* set HDR loop limit */ end; call write_label (ecode); /* write VOL1 label */ if ecode ^= 0 then return; do i = 1 to k; cseg.lbl_buf = l1id (i) || dummy_label (k); call write_label (ecode); /* write HDR1 / EOF1 label */ if ecode ^= 0 then return; do j = 1 to 2; call tape_ansi_tape_io_$order (cP, "eof", 0, ecode); /* write 2 TM */ if ecode ^= 0 then return; end; end; return; end initialize_volume; lrec_open: procedure; /* logical record IO initialization and final checks */ if debug then call debug_print ("lrec_open"); dcl i fixed bin; if cseg.open_mode > 4 then if fd.blklen < 18 then go to inv_blk; /* can't write < 18 chars */ if fd.mode = 3 then cseg.mode = 0; /* binary encoding */ else cseg.mode = 1; /* ascii, ebcdic 9 mode hardware */ if cseg.standard > 1 then go to ibm_open; i = fd.blklen - fd.bo; /* get usable portion of block */ go to test (fd.format); /* test the blocking */ test (2): if ^fd.blocked then if i ^= fd.reclen then go to inv_rec; /* F unblocked */ else go to ok; else if mod (i, fd.reclen) ^= 0 then go to inv_rec; /* F blocked */ else go to ok; test (3): if ^fd.blocked then if i ^= fd.reclen then go to inv_rec; /* D unblocked */ else go to ok; else if fd.reclen > i then go to inv_rec; /* D blocked */ else go to ok; test (4): match (4): if fd.reclen > sys_info$max_seg_size * 4 then go to inv_rec; /* S format */ test (1): match (1): ok: cseg.rlN = -1; /* invalidate anything in rl segment */ cseg.lrec.bufP = null; /* no active buffer */ if cseg.open_mode = 4 then cseg.lrec.blkcnt = 0; /* input - no blocks processed */ else cseg.lrec.blkcnt = fl.blkcnt; /* output - set to 0 or EOX blkcnt for extend */ cseg.lrec.reccnt = 0; /* not currently used */ cseg.lrec.code = 0; /* no errors encountered */ call tape_ansi_tape_io_$open (cP); /* initialize call to tape_ansi_tape_io_ */ return; /* exit */ inv_rec: code = error_table_$invalid_record_length; go to er_exit; inv_blk: code = error_table_$invalid_block_length; /* set error code */ go to er_exit; ibm_open: if cseg.open_mode > 4 then if mod (fd.blklen, 4) ^= 0 then go to inv_blk; /* can only write words */ go to match (fd.format); /* match the blocking */ match (2): if ^fd.blocked then if fd.blklen ^= fd.reclen then go to inv_rec; /* F unblocked */ else go to ok; else if mod (fd.blklen, fd.reclen) ^= 0 then go to inv_rec; /* F blocked */ else go to ok; match (3): if ^fd.blocked then if fd.blklen - 4 ^= fd.reclen then go to inv_rec; else go to ok; else if fd.reclen > fd.blklen - 4 then go to inv_rec; /* V blocked */ else go to ok; end lrec_open; move_to_EOD: procedure; /* position after last data block of last section */ if debug then call debug_print ("move_to_EOD"); do cseg.flP = cseg.flP repeat fl.nextP while (fl.eox = 2); /* set link pointer to last section */ end; call move_tape_ (fl.vlX, fl.flX, 2, code); /* move to trailers */ if code ^= 0 then go to er_exit; call back_TM (1, code); /* move back into data */ if code ^= 0 then go to er_exit; return; end move_to_EOD; move_tape_: procedure (vX, fX, posit, ecode); /* positions to file section and intra-section position */ dcl vX fixed bin, /* volume link index of desired volume */ fX fixed bin, /* file link index of desired file */ posit fixed bin, /* position within file section */ ecode fixed bin (35); /* error code */ dcl (i, j) fixed bin, can_retry bit (1) init ("0"b); dcl uninit_msg (6) char (40) init ("is blank", "is unreadable", "is not formatted according to standard", "has volume identifier of", "is recorded at incorrect density", "is recorded in invalid file-set format"); if debug then call debug_print ("move_tape_"); if vl (vX).rcp_id = 0 then do; /* volume is not mounted */ if cseg.nactive < cseg.ndrives then do; /* more drives available */ call tape_ansi_mount_cntl_$mount (cP, vX, ecode); /* mount the volume */ if ecode ^= 0 then do; /* maybe trouble */ if ecode = error_table_$device_limit_exceeded then do; cseg.ndrives = cseg.ndrives - 1; /* decrement maximum device count */ go to switch; end; else go to error; /* true trouble */ end; end; else do; /* no drive available */ switch: call find_candidate; /* get index (i) of volume to dismount */ call tape_ansi_mount_cntl_$remount (cP, i, vX, ecode); /* remount the volume */ if ecode ^= 0 then go to error; /* trouble */ end; end; cseg.tseg.drive_name = vl (vX).tape_drive; cseg.tseg.ev_chan = vl (vX).event_chan; if cseg.open_mode = 4 then /* open for read only */ vl (vX).write_VOL1 = max (vl (vX).write_VOL1, 0);/* bide time; don't try to update label now */ if vl (vX).write_VOL1 ^= 0 then do; /* VOL1 label missing or bad */ if (cseg.open_mode = 4) /* mounted read-only */ & (vl (vX).write_VOL1 ^= 4) /* and not just mismatched volid */ then do; /* volume needs relabeling and can't */ uninit_error: call ioa_ ("^a: Volume ^a ^a.", cseg.module, vl (vX).volname, uninit_msg (vl (vX).write_VOL1)); ecode = error_table_$uninitialized_volume; go to error; end; if vX = 1 & ^creating_first () then if vl (vX).write_VOL1 < 0 then vl (vX).write_VOL1 = 0; /* bide time, etc. */ else go to uninit_error; /* don't init 1st vol if not creating 1st file */ if vl (vX).write_VOL1 > 1 then if ^initialize_permit (vX) then do; /* tape isn't blank - no permission */ ecode = error_table_$uninitialized_volume; go to error; end; if vl (vX).write_VOL1 ^= 0 then /* needs better VOL1 label */ if cseg.open_mode ^= 4 then do; /* don't do if read only-- if we're here, */ /* problem is insignificant anyway */ call initialize_volume (vX, ecode); if ecode ^= 0 then go to error; end; vl (vX).write_VOL1 = 0; /* VOL1 written - cflX = 0 */ end; can_retry = "1"b; /* one retry permitted */ if vl (vX).cflX = 0 then do; /* volume position unknown or in VOL/UVL set */ retry: call move_to_first_HDR; /* position tape to 1st_HDR HDR group */ vl (vX).cflX = vl (vX).fflX; /* volume positioned to 1st file section */ vl (vX).pos = 0; end; if vl (vX).cflX < fX then do; /* volume positioned before desired file */ j = (fX - vl (vX).cflX) * 3; /* move over TM's */ j = j - vl (vX).pos + posit; /* adjust for intra-file offsets */ call move_forward; /* move j TM */ end; else if vl (vX).cflX > fX then do; /* volume positioned after desired file */ j = ((vl (vX).cflX - fX) * 3) + 1; /* move over TM's */ j = j + vl (vX).pos - posit; /* adjust for intra-file offsets */ call move_backward; /* move j TM */ end; else do; /* volume positioned at desired file */ if vl (vX).pos = posit then do; /* and at desired offset */ j = 1; /* really positions to 1st block after this TM */ call move_backward; /* really positions to beginning of TM group */ end; else if vl (vX).pos < posit then do; /* before desired offset */ j = posit - vl (vX).pos; call move_forward; /* move j TM */ end; else do; /* after desired section */ j = vl (vX).pos - posit + 1; /* move over TM's */ call move_backward; /* move j TM */ end; end; ok_exit: vl (vX).cflX = fX; /* new position info */ vl (vX).pos = posit; return; error: vl (vX).cflX = 0; /* we don't know where we are */ if can_retry then do; /* can we retry the move? */ can_retry = "0"b; /* yes - but only once */ go to retry; end; return; find_candidate: procedure; /* find a volume to dismount */ if debug then call debug_print ("find_candidate"); do i = 1 to vX - 1; /* search up to desired volume */ if vl (i).rcp_id ^= 0 then return; /* got one active */ end; /* none preceding current link */ do i = cseg.vcN to vX + 1 by -1; /* search down to desired volume */ if vl (i).rcp_id ^= 0 then return; /* got one active */ end; ecode = error_table_$invalid_cseg; /* something very wrong if no volume found */ go to error; end find_candidate; move_to_first_HDR: procedure; /* positions volume to 1st HDR label */ if debug then call debug_print ("move_to_first_HDR"); call tape_ansi_tape_io_$order (cP, "rew", 0, ecode); /* rewind the volume */ if ecode ^= 0 then go to error; HDR_search: call read_label (ecode); /* read a label */ if ecode ^= 0 then do; /* trouble */ if ecode = error_table_$eof_record then ecode = error_table_$invalid_file_set_format; go to error; end; if label_type ^= "HDR" then go to HDR_search; /* read until 1st HDR */ call tape_ansi_tape_io_$order (cP, "bsr", 0, ecode); /* get back to beginning of HDR */ if ecode ^= 0 then go to error; return; move_forward: entry; /* position j TM sections forward */ do i = 1 to j; call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode); /* move forward 1 TM */ if ecode ^= 0 then go to error; end; return; move_backward: entry; /* position j TM sections backward */ do i = 1 to j - 1; /* do all but last */ call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode); /* backspace 1 TM */ if ecode ^= 0 then go to error; end; call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode); /* do last */ if ecode = error_table_$positioned_on_bot then go to HDR_search; else if ecode ^= 0 then go to error; call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode); /* position to record after TM */ if ecode ^= 0 then go to error; return; move_to_first_UHL: entry; /* position to 1st UHL */ i = 1; go to UL_search; move_to_first_UTL: entry; /* position to 1st UTL */ i = 2; UL_search: call read_label (ecode); /* read a label */ if ecode = error_table_$eof_record then call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode); /* EOF */ else if ecode ^= 0 then go to error; else if label_type ^= UL (i) then go to UL_search; /* not a user label */ else call tape_ansi_tape_io_$order (cP, "bsr", 0, ecode); /* got it */ if ecode ^= 0 then go to error; return; end move_to_first_HDR; end move_tape_; next_volume: procedure returns (bit (1)); /* determines if volume switch possible */ dcl canon_std (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape); if debug then call debug_print ("next_volume"); if fl.vlX < cseg.vcN then return ("1"b); /* if current vlX < vcN then next exists */ if fl.vlX = 63 then do; /* volume chain full */ call ioa_ ("^a: Implementation limit of 63 volumes exceeded.", cseg.module); return ("0"b); end; if fl.system = fd.system then do; /* trailers could have next reel id */ if fl.next_volname ^= "" then do; /* they do */ vn = fl.next_volname; /* copy it */ go to got_volname; /* use it */ end; end; if another_volume () then vl (cseg.vcN + 1).comment = com_text; /* yes */ else return ("0"b); /* no */ got_volname: cseg.vcN = cseg.vcN + 1; /* increment volume link count */ call vl_init (cseg.vcN); vl (cseg.vcN).volname = vn; /* set reel id in volume link */ call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), vl (cseg.vcN).volname, vl (cseg.vcN).canonical_volname, canon_std (cseg.standard), code); if code ^= 0 then return ("0"b); return ("1"b); end next_volume; process_EOX: procedure (ecode); /* processes trailer labels for file chain */ dcl ecode fixed bin (35); dcl canon_std (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape); if debug then call debug_print ("process_EOX"); on conversion go to bad_EOX; fl.eox = 0; /* trailers not yet processed */ ansi_hdr1P, ansi_hdr2P = addr (lbl_buf); /* set pointers to label IO buffer */ call read_label (ecode); /* read EOX1 label */ if ecode ^= 0 then do; /* trouble */ if ecode = error_table_$eof_record then /* label missing */ bad: ecode = error_table_$invalid_file_set_format; return; end; if ansi_hdr1.label_id = "EOV1" then fl.eox = 2; /* indicate volume switch */ else if ansi_hdr1.label_id = "EOF1" then fl.eox = 1; /* no volume switch */ else go to bad; /* error if not EOF or EOV */ fl.creation = substr (ansi_hdr1.creation, 2, 5); /* update creation date to latest */ fl.version = fixed (ansi_hdr1.version, 17); /* update version to latest */ fl.blkcnt = fixed (ansi_hdr1.blkcnt, 35); /* save block count */ call read_label (ecode); /* read next label (EOX2 or otherwise) */ if ecode ^= 0 then do; /* investigate */ if ecode = error_table_$eof_record then do; /* no EOX2 label */ call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode); /* backspace into trailer set */ if ecode ^= 0 then return; no_EOX2: if fl.eox = 2 then do; /* EOV label */ if next_volume () then fl.next_volname = vl (fl.vlX + 1).volname; /* have volume */ else ecode = error_table_$no_next_volume; end; end; return; end; if label_type = "UTL" then go to no_EOX2; /* user label - no EOX2 */ if ansi_hdr2.label_id ^= l2id (fl.eox + 1) then go to bad; /* label not EOF2 or EOV2 */ if fl.eox = 2 then do; /* EOV labels */ if cseg.standard = 1 then if fl.system = fd.system then if old_ansi_hdr2_system_use.system_reserved ^= "" then do; fl.next_volname = ansi_hdr2.next_volname; call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), fl.next_volname, fl.canonical_next_volname, canon_std (cseg.standard), ecode); if ecode ^= 0 then goto bad_EOX; end; if next_volume () then do; /* allow for -volume override */ fl.next_volname = vl (fl.vlX + 1).volname; fl.canonical_next_volname = vl (fl.vlX + 1).canonical_volname; end; else ecode = error_table_$no_next_volume; end; return; bad_EOX: ecode = error_table_$invalid_label_format; return; end process_EOX; read_HDR1: procedure (eofsw, ecode); /* read HDR1 label (if any) */ dcl eofsw bit (1); /* end-of-file-set bit */ dcl ecode fixed bin (35); if debug then call debug_print ("read_HDR1"); eofsw = "0"b; /* initialize */ ansi_hdr1P, ibm_hdr1P = addr (cseg.lbl_buf); /* set pointer to label */ call read_label (ecode); /* read it */ if ecode = 0 then do; /* read something ok */ if ansi_hdr1.label_id ^= "HDR1" then do; /* the something wasn't what we wanted */ ecode = error_table_$invalid_file_set_format; return; end; end; else if ecode = error_table_$eof_record then do; /* read a TM */ vl (fl.vlX).pos = vl (fl.vlX).pos + 1; /* increment position count */ call back_TM (1, ecode); /* backup over it */ if ecode = 0 then eofsw = "1"b; /* set the eofs bit */ end; return; end read_HDR1; read_HDR2: procedure (ecode); /* read HDR2 label (if any) */ dcl ecode fixed bin (35); if debug then call debug_print ("read_HDR2"); fl.HDR2 = "0"b; /* HDR2 not yet processed */ ansi_hdr2P, ibm_hdr2P = addr (cseg.lbl_buf); /* get pointer to label */ call read_label (ecode); /* read it */ if ecode = 0 then do; /* read something ok */ if ansi_hdr2.label_id = "HDR2" then fl.HDR2 = "1"b; /* something was HDR2 */ else ; /* something wasn't */ end; else if ecode = error_table_$eof_record then do; /* went over TM */ vl (fl.vlX).pos = vl (fl.vlX).pos + 1; /* increment position count */ call back_TM (1, ecode); /* backup over it */ end; return; end read_HDR2; read_label: procedure (ecode); /* reads an 80 character label synchronously */ dcl ecode fixed bin (35), nchar fixed bin; call tape_ansi_tape_io_$sync_read (cP, nchar, ecode); /* read a block */ if ecode = 0 then do; /* read was uneventful */ if nchar < 80 then do; /* definitely not a label */ ecode = error_table_$invalid_label_format; return; end; else do; /* probably a label */ if cseg.standard = 1 then cseg.lbl_buf = sync_buf; /* move into label buffer */ else call ebcdic_to_ascii_ (sync_buf, cseg.lbl_buf); /* convert to ascii and move */ end; end; if debug then do; if ecode = 0 then call ioa_ ("^80a", lbl_buf); else call ioa_ ("^d", ecode); end; return; /* with ecode = 0, EOF, or error */ write_label: entry (ecode); if cseg.standard = 1 then sync_buf = cseg.lbl_buf; /* ascii - move it */ else call ascii_to_ebcdic_ (cseg.lbl_buf, sync_buf); /* ebcdic - convert and move */ call tape_ansi_tape_io_$sync_write (cP, 80, ecode); /* write it */ if debug then call ioa_ ("^d^-^80a", ecode, lbl_buf); return; /* with ecode = 0, EOT, or error */ end read_label; setup_for_create: procedure; /* fills file link from file data (mostly) */ if debug then call debug_print ("setup_for_create"); fl.file_id = fd.file_id; /* use creation name */ fl.set_id = fl.backP -> fl.set_id; fl.canonical_set_id = fl.backP -> fl.canonical_set_id; fl.section = 1; fl.sequence = fd.sequence; if cseg.standard = 1 then fl.generation = 1; else fl.generation = 0; fl.version = 0; fl.creation = fd.creation; fl.expiration = fd.expiration; fl.access = fd.access; fl.blkcnt = 0; fl.system = fd.system; call fill_flhdr2_from_fd; /* fill fl HDR2 from fd and defaults */ return; end setup_for_create; setup_for_extend_modify: procedure; /* fills file data from file link */ if debug then call ioa_ ("setup_for_extend_modify"); fd.file_id = fl.file_id; /* copy HDR1 data */ fd.sequence = fl.sequence; if cseg.standard = 1 then fl.version = mod (fl.version + 1, 100); /* if ANSI, up version */ fl.creation = fd.creation; if cseg.output_mode = 2 then fl.blkcnt = 0; /* zero block count for modify */ else ; /* maintain block count for extend */ call fill_fdhdr2_from_fl; /* put hdr2 data from fl, if any, into fd */ call fill_flhdr2_from_fd; /* put fd hdr2 data into fl, _n_o defaults */ return; end setup_for_extend_modify; setup_for_read: procedure; /* tries to complete file data from file link on input */ if debug then call debug_print ("setup_for_read"); fd.file_id = fl.file_id; /* copy HDR1 data */ fd.sequence = fl.sequence; if fd.format = 0 then do; /* no explicit format */ fd.format = fl.format; if fd.format = 0 then do; not_enough: code = error_table_$insufficient_open; go to er_exit; end; format_override = "0"b; /* file data does not override link data */ end; else format_override = "1"b; /* explicit format */ if fd.blklen = 0 then fd.blklen = fl.blklen; if fd.blklen = 0 then go to not_enough; if fd.reclen = 0 then fd.reclen = fl.reclen; if fd.reclen = 0 then do; /* this may be valid */ if fd.format = 4 then fd.reclen = sys_info$max_seg_size * 4; /* S or V(B)S */ else if fd.format = 1 then ; /* U format - reclen undefined */ else go to not_enough; end; if cseg.standard = 1 then do; /* ANSI */ if fl.system ^= "" then fd.bo = fl.bo; /* set buffer offset if HDR1 has it */ if fl.system = fd.system then do; /* file written by this system? */ if ^format_override then fd.blocked = fl.blocked; /* set blocked attribute from labels */ if fd.mode = 0 then fd.mode = fl.mode; /* set encoding mode from labels */ end; else do; /* system-defined fields are invalid - apply defaults */ if ^format_override then fd.blocked = "1"b; /* blocked */ if fd.mode = 0 then fd.mode = 1; /* ascii */ end; end; else do; /* IBM */ if ^format_override then fd.blocked = fl.blocked; if fd.mode = 0 then fd.mode = 2; /* EBCDIC */ end; return; end setup_for_read; setup_for_generate: procedure; /* updates file link and fills file data */ if debug then call debug_print ("setup_for_generate"); fd.file_id = fl.file_id; fd.sequence = fl.sequence; fl.generation = mod (fl.generation + 1, 10000); /* increment generation number */ fl.version = 0; fl.creation = fd.creation; /* use today's date */ fl.expiration = fd.expiration; /* use specified expiration date */ fl.access = fd.access; fl.blkcnt = 0; call fill_fdhdr2_from_fl; /* put fl hdr2 data, if any, into fd */ call fill_flhdr2_from_fd; /* put fd hdr2 data into fl, _n_o defaults */ fl.system = fd.system; /* set now to use system-defined HDR2 fields */ return; end setup_for_generate; truncate_chains: procedure; /* eliminate chain references to overwritten files */ if debug then call debug_print ("truncate_chains"); dcl i fixed bin, /* temporary index into volume chain */ saveP ptr, /* holds pointer to desired file link */ zaP ptr; /* file chain truncation pointer */ if fl.nextP = null then return; /* nothing to truncate */ on cleanup begin; /* don't leave chains inconsistent */ cseg.fcP -> fl.nextP = null; /* truncate file chain entirely (leave dummy) */ do i = 1 to cseg.vcN; /* wipe the volume chain clean of file link references */ vl (i).fflX = 0; vl (i).cflX = 0; vl (i).lflX = 0; end; end; saveP = cseg.flP; /* save pointer to desired file link */ cseg.flP = fl.nextP; /* begin truncation after current link */ fl.backP -> fl.nextP = null; /* step 1 - file chain logically truncated */ if fl.flX = -1 then go to free; /* only truncate an eofsl */ if vl (fl.vlX).fflX = fl.flX then do; /* truncated files start a volume */ vl (fl.vlX).fflX = 0; /* wipe that volume clean */ vl (fl.vlX).cflX = 0; vl (fl.vlX).lflX = 0; end; else vl (fl.vlX).lflX = fl.flX - 1; /* or, last valid reference is before truncation point */ do i = fl.vlX + 1 to cseg.vcN; /* all subsequent volumes must be emptied */ vl (i).fflX = 0; vl (i).cflX = 0; vl (i).lflX = 0; end; /* step 2 - volume chain adjusted */ revert cleanup; /* drastic measures no longer needed */ free: zaP = cseg.flP; /* set pointer to truncation point */ do cseg.flP = cseg.flP repeat zaP while (zaP ^= null);/* step 3 - free file chain storage */ zaP = fl.nextP; /* set pointer to next truncation point */ free fl in (chain_area); /* free link at current truncation point */ end; exit: cseg.flP = saveP; /* restore pointer to last valid link */ return; end truncate_chains; vl_init: procedure (n); /* initialize a volume link */ dcl n fixed bin; /* link index */ vl (n).fflX = 0; vl (n).cflX = 0; vl (n).pos = 0; vl (n).lflX = 0; vl (n).tracks = 0; vl (n).density = 0; vl (n).label_type = 0; vl (n).usage_count = 0; vl (n).read_errors = 0; vl (n).write_errors = 0; vl (n).rcp_id = 0; vl (n).event_chan = 0; vl (n).tape_drive = ""; vl (n).write_VOL1 = 0; vl (n).ioi_index = 0; return; end vl_init; write_HDRs: procedure (ecode); /* formats and writes HDR1 and HDR2 */ if debug then call debug_print ("write_HDRs"); dcl ecode fixed bin (35); /* error code */ dcl x fixed bin; /* entry index */ fl.eox = 0; /* trailers not yet written */ x = 1; go to write_labels; write_EOFs: entry (ecode); /* formats and writes EOF1 and EOF2 */ if debug then call debug_print ("write_EOFs"); fl.blkcnt = cseg.blkcnt; /* update block count */ fl.eox = 1; /* no volume switch */ x = 2; go to write_labels; write_EOVs: entry (ecode); /* formats and writes EOV1 and EOV2 */ if debug then call debug_print ("write_EOVs"); fl.blkcnt = cseg.blkcnt; /* update block count */ fl.eox = 2; /* volume switch */ x = 3; write_labels: call fill_XXX1 (x); /* format label as HDR1, EOF1, or EOV1 */ call write_label (ecode); /* write it */ if ecode ^= 0 then if ecode ^= error_table_$eov_on_write then return; /* check error code */ if x = 1 then fl.HDR2 = "1"b; /* request is for headers, so HDR2 exists */ else do; /* request is for trailers */ if ^fl.HDR2 then do; /* no HDR2 label */ ecode = 0; /* therefore, no EOX2 label */ return; end; end; call fill_XXX2 (x); /* format label as HDR2, EOF2, or EOV2 */ call write_label (ecode); /* write it */ if ecode = error_table_$eov_on_write then ecode = 0; /* ignore EOT */ return; /* with ecode = 0 or an error code */ end write_HDRs; write_TM: procedure (n, ecode); /* writes 1 or 2 TM and adjusts volume link */ dcl n fixed bin, /* number of TM - 1 or 2 */ cnt fixed bin, ecode fixed bin (35); if debug then call ioa_ ("write_TM ^d", n); do cnt = 1 to n; /* 1 or 2 */ call tape_ansi_tape_io_$order (cP, "eof", 0, ecode); /* write a TM */ if ecode ^= 0 then if ecode ^= error_table_$eov_on_write then return; /* error exit */ vl (fl.vlX).pos = vl (fl.vlX).pos + 1; /* increment for each TM */ if vl (fl.vlX).pos > 2 then do; /* adjust mod3 */ vl (fl.vlX).pos = vl (fl.vlX).pos - 3; vl (fl.vlX).cflX = vl (fl.vlX).cflX + 1; end; end; return; end write_TM; write_new_section: procedure (ecode); /* writes new section headers */ dcl ecode fixed bin (35); if debug then call debug_print ("write_new_section"); cseg.flP = fl.nextP; /* set pointer to next (eofs) link */ call make_eofsl_real; /* make it a real link */ call build_eofsl; /* add a new end-of-file-set link */ call move_tape_ (fl.vlX, fl.flX, 0, ecode); /* position to write headers */ if ecode ^= 0 then return; /* trouble */ ansi_hdr1P = addr (cseg.lbl_buf); /* set pointer to label buffer - move_tape_ read HDR1 */ if substr (ansi_hdr1.expiration, 2, 5) > fd.creation then do; /* volume has unexpired data */ if initialize_permitA (fl.vlX) then do; /* user said can re-initialize */ call initialize_volume (fl.vlX, ecode); /* do it */ if ecode ^= 0 then return; call move_tape_ (fl.vlX, fl.flX, 0, ecode); /* re-position to HDR1 */ if ecode ^= 0 then return; end; else do; /* user said can't */ ecode = error_table_$unexpired_volume; return; end; end; call fill_new_section_fl; /* initialize the link */ call write_HDRs (ecode); /* write HDR labels */ if ecode ^= 0 then return; /* if cseg.user_labels then call write_UHL; */ call write_TM (1, ecode); /* write header set TM */ return; end write_new_section; data_eof: entry (iocbP, code); /* called by lrec IO when encounters EOF */ if debug then call debug_print ("data_eof"); cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get control segment pointer */ cc = 0; /* minimal consistency requirement */ on cleanup go to data_eof_fail; on area begin; /* handle the condition */ code = error_table_$noalloc; go to data_eof_fail; end; vl (fl.vlX).pos = vl (fl.vlX).pos + 1; /* have moved over a TM - update position info */ if cseg.standard = 1 then call tape_ansi_lrec_io_$close (cP, code); /* close logical record IO */ else call tape_ansi_ibm_lrec_io_$close (cP, code); if code ^= 0 then do; data_eof_fail: call consistent; go to close_exit; end; if fl.eox = 0 then do; /* trailer labels have not been processed */ call process_EOX (code); /* process them */ if code ^= 0 then go to data_eof_fail; end; if cseg.blkcnt ^= -1 then do; /* block count is valid */ if cseg.blkcnt ^= fl.blkcnt then do; /* read and recorded don't agree */ code = error_table_$discrepant_block_count; return; end; end; /* if cseg.user_labels then call read_UTL */ if fl.eox = 1 then do; /* last (or only) section */ code = error_table_$end_of_info; return; end; if fl.nextP ^= null then cseg.flP = fl.nextP; /* next link exists - use it */ else do; /* link doesn't exist - make it */ cc = 1; /* insure chain consistency */ call build1 (code); /* process HDR labels */ if code ^= 0 then go to data_eof_fail; cc = 0; /* minimal consistency requirement */ end; if fl.flX = -1 then do; /* link is eofsl */ code = error_table_$invalid_file_set_format; cseg.flP = fl.backP; /* get back to last valid link */ go to data_eof_fail; end; if fl.file_id ^= fl.backP -> fl.file_id | /* file id's must be identical */ fl.section ^= fl.backP -> fl.section + 1 then do; /* section must be 1 > than previous */ code = error_table_$invalid_volume_sequence; cseg.flP = fl.backP; go to data_eof_fail; end; /* if cseg.user_labels then call read_UHL */ call move_tape_ (fl.vlX, fl.flX, 1, code); /* move to data of new section */ if code ^= 0 then go to data_eof_fail; cseg.blkcnt = 0; /* re-initialize block count for new section */ return; data_eot: entry (iocbP, code); /* called by lrec IO when encounters EOT */ if debug then call debug_print ("data_eot"); cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to control segment */ cc = 2; /* don't leave defective tape file */ on cleanup go to write_data_fail; eot_not_while_closing: close_eot = "0"b; /* eot doing data or positioning for output */ go to any_eot; eot_while_closing: close_eot = "1"b; /* eot writing HDR TM for null file */ any_eot: on area begin; /* common code - EOT doing data or HDR TM */ code = error_table_$noalloc; go to write_data_fail; end; if ^next_volume () then do; /* no next volume available */ code = error_table_$no_next_volume; if ^close_eot then return; /* exit gracefully */ else go to write_data_fail; /* abort the file fragment */ end; else do; /* volume available - set reel id in trailers */ fl.next_volname = vl (fl.vlX + 1).volname; fl.canonical_next_volname = vl (fl.vlX + 1).canonical_volname; end; /* finish current volume, switch to new file section on new volume */ call write_TM (1, code); /* write end-of-data TM */ if code ^= 0 then if code ^= error_table_$eov_on_write then do; write_data_fail: call consistent; go to close_exit; /* force close */ end; call write_EOVs (code); /* write EOV labels */ if code ^= 0 then go to write_data_fail; /* if cseg.user_labels then call write_UTL; */ call write_TM (2, code); /* write trailer and end of volume TMs */ if code ^= 0 then if code ^= error_table_$eov_on_write then go to write_data_fail; call write_new_section (code); /* begin new file section */ if code ^= 0 then go to write_data_fail; cseg.lrec.blkcnt = 0; /* initialize block count for new section */ if close_eot then go to continue_close; /* finish the close operation */ else return; position_for_output: entry (iocbP, code); /* called by 1st write_record to write HDR TM */ cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to control segment */ if debug then call debug_print ("position_for_output"); cc = 2; /* don't leave defective tape file */ on cleanup go to write_data_fail; /* if cseg.user_labels then call write_UHL; */ call write_TM (1, code); /* write HDR TM */ if code = 0 then return; /* fine - not even end-of-tape */ if code = error_table_$eov_on_write then go to eot_not_while_closing; /* end-of-tape */ go to write_data_fail; /* trouble */ beginning_of_file: entry (iocbP, code); /* positions to beginning of file */ cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to control segment */ cc = 0; /* minimal consistency requirement */ on cleanup go to bof_fail; if cseg.standard = 1 then call tape_ansi_lrec_io_$close (cP, code); /* close logical record I/O */ else call tape_ansi_ibm_lrec_io_$close (cP, code); if code ^= 0 then go to bof_fail; do cseg.flP = cseg.flP repeat fl.backP while (fl.section ^= 1); /* get back to first file section */ end; call move_tape_ (fl.vlX, fl.flX, 1, code); /* position to 1st data record */ if code ^= 0 then do; /* trouble - maintain consistency */ bof_fail: call consistent; go to close_exit; end; call lrec_open; /* open logical record I/O */ /* note: no error can occur */ return; end_of_file: entry (iocbP, code); /* positions to end of file */ cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get control segment pointer */ cc = 0; /* minimal consistency requirement */ on cleanup go to eof_fail; on area go to eof_fail; if cseg.standard = 1 then call tape_ansi_lrec_io_$close (cP, code); /* close logical record IO */ else call tape_ansi_ibm_lrec_io_$close (cP, code); if code ^= 0 then do; eof_fail: call consistent; go to close_exit; end; cseg.rlN = -1; /* invalidate read_length buffer */ cseg.blkcnt = -1; /* invalidate block count */ eof_loop: if fl.eox = 0 then do; /* trailer labels have not been processed */ call build2 (code); /* process them */ if code ^= 0 then go to eof_fail; end; if fl.eox = 1 then do; /* last (or only) section */ call move_tape_ (fl.vlX, fl.flX, 2, code); /* position to trailers */ if code ^= 0 then go to eof_fail; call back_TM (1, code); /* get back into data */ if code ^= 0 then go to eof_fail; return; end; if fl.nextP ^= null then cseg.flP = fl.nextP; /* next link exists - use it */ else do; /* link doesn't exist - make it */ cc = 1; /* insure chain consistency */ call build1 (code); /* process HDR labels */ if code ^= 0 then go to eof_fail; cc = 0; /* minimal consistency requirement */ end; if fl.flX = -1 then do; /* link is eofsl */ code = error_table_$invalid_file_set_format; cseg.flP = fl.backP; /* get back to last valid link */ go to eof_fail; end; if fl.file_id ^= fl.backP -> fl.file_id | /* file id's must be identical */ fl.section ^= fl.backP -> fl.section + 1 then do; /* section must be 1 > previous */ code = error_table_$invalid_volume_sequence; cseg.flP = fl.backP; go to eof_fail; end; go to eof_loop; close: entry (iocbP, code); /* iox_$close entry */ cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get control segment pointer */ if cseg.file_lock then do; /* file in use? */ code = error_table_$file_busy; return; end; else do; on cleanup cseg.file_lock = "0"b; cseg.file_lock = "1"b; end; if cseg.invalid then do; code = error_table_$invalid_cseg; on cleanup go to close_exit1; go to close_exit1; end; if cseg.open_mode = 4 then do; /* input mode */ cc = 0; /* minimal consistency requirement */ on cleanup go to close_fail; if cseg.standard = 1 then call tape_ansi_lrec_io_$close (cP, code); /* close logical record IO */ else call tape_ansi_ibm_lrec_io_$close (cP, code); if code ^= 0 then call consistent; go to close_exit; end; else do; /* output mode */ cc = 2; /* don't leave defective tape file */ on cleanup go to close_fail; if vl (fl.vlX).pos = 0 then do; /* still in HDRs, never wrote data */ call write_TM (1, code); /* re-write HDR TM (should be after last HDR label) */ if code ^= 0 then do; /* maybe trouble */ if code = error_table_$eov_on_write then go to eot_while_closing; /* return to continue_close */ else go to close_fail; /* real error, abort the file */ end; end; continue_close: if cseg.standard = 1 then call tape_ansi_lrec_io_$close (cP, code); /* close logical IO */ else call tape_ansi_ibm_lrec_io_$close (cP, code); if code ^= 0 then do; /* maybe trouble */ if code ^= error_table_$eov_on_write then do; /* EOT is ok */ close_fail: call consistent; /* delete the file */ go to close_exit; end; end; call write_TM (1, code); /* write the end-of-data TM */ if code ^= 0 then if code ^= error_table_$eov_on_write then go to close_fail; /* bad - ignore EOT */ call write_EOFs (code); /* write trailer labels */ if code ^= 0 then go to close_fail; /* trouble */ /* if cseg.user_labels then call write_UTL; */ call write_TM (2, code); /* write trailer and end-of-volume TMs */ if code ^= 0 then do; if code = error_table_$eov_on_write then code = 0; else go to close_fail; end; end; close_exit: if cseg.close_rewind then do; /* rewind volume at close time */ vl (fl.vlX).cflX = 0; /* invalidate volume position */ call tape_ansi_tape_io_$order (cP, "rew", 0, 0);/* issue the order */ cseg.close_rewind = "0"b; /* this is a one time switch */ end; close_exit1: mask = "0"b; revert cleanup; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbP -> iocb.actual_iocb_ptr -> iocb.detach_iocb = tape_ansi_detach_; iocbP -> iocb.actual_iocb_ptr -> iocb.open = tape_ansi_file_cntl_$open; iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_; iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null; call iox_$propagate (iocbP -> iocb.actual_iocb_ptr); call hcs_$reset_ips_mask (mask, mask); cseg.file_lock = "0"b; return; debug_on: entry; /* turns debug switch on */ debug = "1"b; return; debug_off: entry; /* truns debug switch off */ debug = "0"b; return; debug_print: procedure (text); /* prints debug text */ dcl text char (*); call ioa_ (text); return; end debug_print; end tape_ansi_file_cntl_;  tape_ansi_ibm_lrec_io_.pl1 11/04/82 1931.3rew 11/04/82 1606.0 247896 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* */ /* * * * * * * * * * * * * * */ /* */ /* 0) Created: */ /* 1) Modified: 06/29/79 by Rick Riley */ /* (to allow reading writing ibm tapes in binary mode */ /* 2) Modified: 4/82 by J. A. Bush for block sizes > 8192 bytes */ /* ****************************************************************** */ tape_ansi_ibm_lrec_io_: procedure; return; /* parameters */ dcl peel fixed bin, hold char (4) varying; dcl iocbP ptr, /* pointer to iocb */ ubP ptr, /* pointer to user buffer */ buf_len fixed bin (21), /* length of user buffer */ rec_len fixed bin (21), /* number of characters transmitted */ code fixed bin (35); %include iocb; %include tape_ansi_cseg; %include tape_ansi_fd; %include tape_ansi_fl; /* based storage */ dcl 1 BDW based (cseg.lrec.bufP), /* block descriptor word */ 2 length fixed bin (17) unaligned, /* block length */ 2 pad bit (18) unaligned;/* pad */ dcl buf char (cseg.buf_size) aligned based (cseg.lrec.bufP), /* one physical block */ data char (move) unaligned based, /* overlay for data move */ rpad char (1) based (addr (erp (fd.mode))); /* ASCII , BINARY, or EBCDIC space */ dcl 1 SDW based (dwP), /* segment descriptor word */ 2 length fixed bin (17) unaligned, /* length of segment */ 2 code fixed bin (8) unaligned, /* control code */ 2 pad bit (9) unaligned; dcl 1 RDW based (dwP), /* V-format rdw */ 2 length fixed bin (17) unaligned, /* record length */ 2 pad bit (18) unaligned;/* pad */ dcl ub char (buf_len) unaligned based (ubP); /* user buffer overlay */ /* error codes */ dcl (error_table_$tape_error, error_table_$eof_record, error_table_$eov_on_write, error_table_$file_busy, error_table_$fatal_error, error_table_$invalid_record_desc, error_table_$long_record) fixed bin (35) external static; /* builtin functions */ dcl (addr, copy, mod, null, substr, unspec) builtin; /* conditions */ dcl cleanup condition; /* automatic storage */ dcl i fixed bin, /* temporary storage */ csw bit (1) init ("0"b), /* indicates close or write_record entry */ total fixed bin (21) initial (0), /* total number of characters moved in this request */ move fixed bin initial (0), /* number of characters moved per segment/record */ left fixed bin (21), /* number of characters remaining to be moved */ long_record bit (1) initial ("0"b), /* long record switch */ parity_error bit (1) initial ("0"b), /* parity error switch */ req_off fixed bin, /* number of buffer characters processed by this request */ remain fixed bin, /* number of unprocessed characters in buffer */ ecode fixed bin (35) init (0), /* temporary error code */ data_len fixed bin initial (0), /* number of characters in varying length record */ first_span bit (1) initial ("1"b); /* first segment of spanned request switch */ /* pointers */ dcl dwP ptr, /* pointer to RDW - SDW */ fromP ptr, /* pointer to buffer for data move */ toP ptr; /* pointer to user buffer for data move */ /* static storage */ dcl 1 sdw internal static aligned, /* SDW data */ 2 complete fixed bin (8) initial (0), /* complete code */ 2 initial fixed bin (8) initial (1), /* initial code */ 2 medial fixed bin (8) initial (3), /* medial code */ 2 final fixed bin (8) initial (2); /* final code */ dcl erp (3) bit (9) internal static initial ("000100000"b, "001000000"b, "000100000"b); /* ASCII EBCDIC BINARY record pad */ dcl ebcdic fixed bin internal static init (2); dcl binary fixed bin internal static init (3); dcl DOS fixed bin initial (3) internal static; /* external procedures */ dcl ascii_to_ebcdic_ ext entry (char (*), char (*)), ebcdic_to_ascii_ ext entry (char (*), char (*)), tape_ansi_file_cntl_$data_eof ext entry (ptr, fixed bin (35)), tape_ansi_file_cntl_$data_eot ext entry (ptr, fixed bin (35)), tape_ansi_file_cntl_$position_for_output ext entry (ptr, fixed bin (35)), tape_ansi_nl_file_cntl_$data_eof ext entry (ptr, fixed bin (35)), tape_ansi_nl_file_cntl_$data_eot ext entry (ptr, fixed bin (35)), tape_ansi_tape_io_$close ext entry (ptr, fixed bin (35)), tape_ansi_tape_io_$get_buffer ext entry (ptr, ptr, fixed bin (35)), tape_ansi_tape_io_$read ext entry (ptr, ptr, fixed bin, fixed bin (35)), tape_ansi_tape_io_$release_buffer ext entry (ptr, ptr, fixed bin (35)), tape_ansi_tape_io_$write ext entry (ptr, ptr, fixed bin, fixed bin (35)); read_record: entry (iocbP, ubP, buf_len, rec_len, code); /* read_record entry point */ cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */ if cseg.file_lock then do; rec_len = 0; code = error_table_$file_busy; return; end; else do; on cleanup begin; cseg.file_lock = "0"b; cseg.code = error_table_$fatal_error; end; cseg.file_lock = "1"b; end; if cseg.code ^= 0 then do; /* was there a non-restartable error? */ code = cseg.code; /* set return code */ cseg.file_lock = "0"b; return; end; if cseg.rlN ^= -1 then do; /* data record is in read length segment */ if buf_len >= cseg.rlN then do; /* user wants as much as (or more than) we have */ code = 0; move = cseg.rlN; /* give only as much as we have */ end; else do; /* user wants less than we have */ code = error_table_$long_record; move = buf_len; /* give what s(he) wants */ end; ubP -> data = cseg.rlP -> data; /* move to user */ rec_len = move; /* indicate amount moved */ cseg.rlN = -1; /* read length buffer is now empty */ cseg.lrec.reccnt = cseg.lrec.reccnt + 1; cseg.file_lock = "0"b; return; end; go to r_format (fd.format); /* transfer to begin processing */ r_format (1): call get_record; /* U format - get a logical record */ move = remain; /* user gets all, even pad chars (if any) */ if buf_len < move then do; /* buffer < record */ long_record = "1"b; move = buf_len; /* move as much as can fit */ end; req_off = remain; /* this request processes the entire block */ call move_to_user; /* move data to user's buffer */ call read_release; /* release the record */ go to r_count; /* return to caller */ r_format (2): call get_record; /* get 1 record */ if fd.reclen > remain then move = remain; /* don't try to move more than we have */ else move = fd.reclen; /* move only up to 1 record's worth */ if buf_len < move then do; /* buffer < record */ long_record = "1"b; move = buf_len; /* move only what can fit */ end; req_off = fd.reclen; /* process one record */ call move_to_user; /* move data to user's buffer */ call read_release; /* release the record */ go to r_count; /* return to caller */ r_format (3): call get_record; /* V format - get a logical record */ dwP = addr (substr (buf, cseg.offset + 1)); /* get pointer to rdw */ if fd.mode ^= binary then /* if not already binary then make it */ substr (unspec (RDW.length), 1, 10) = "00"b || substr (unspec (RDW.length), 2, 8); /* shift byte right to form valid binary value reading 9 mode */ data_len = RDW.length - 4; /* subtract rdw length to get data length */ if data_len > remain - 4 then go to inv_desc; /* block bigger than block size? */ move = data_len; /* move up to 1 record */ if buf_len < move then do; /* buffer < record */ long_record = "1"b; move = buf_len; /* move only what can fit */ end; cseg.offset = cseg.offset + 4; /* the rdw has been processed */ req_off = data_len; /* process one logical record */ call move_to_user; /* move data to user's buffer */ call read_release; /* release the record */ go to r_count; /* return to caller */ r_format (4): call get_record; /* VBS format - get a logical record */ left = buf_len; /* save request for decrementing */ r_sw_check: call process_sw; /* process the SDW - get type and data length */ if left >= data_len then move = data_len; /* give user the entire segment..... */ else do; /* user doesn't want all the data */ long_record = "1"b; /* buffer < record */ move = left; /* move only as much as can fit */ end; call move_to_user; /* move the data to the user's buffer */ left = left - move; /* keep track of remainder of request */ if SDW.code = sdw.complete | SDW.code = sdw.final then do; /* segment is last (or only) of record */ call read_release; /* release it */ go to r_count; /* and we're done */ end; else call read_release; /* release the record and continue */ if left ^= 0 then do; /* user wants more, and more segments are available */ call get_record; /* get the next segment */ go to r_sw_check; /* transfer to process the SDW/SDW, etc. ..... */ end; call skip_segments; /* request satisfied, but more segments remain - skip them */ long_record = "1"b; /* buffer < record */ go to r_count; /* return to caller */ inv_desc: ecode = error_table_$invalid_record_desc; /* set error code */ go to r_exit; r_count: cseg.lrec.reccnt = cseg.lrec.reccnt + 1; r_exit: if parity_error then code = error_table_$tape_error; else code = ecode; cseg.code = code; if code = 0 then if long_record then code = error_table_$long_record; rec_len = total; /* return total number of characters moved */ cseg.file_lock = "0"b; return; /* and return to the caller */ get_record: procedure; /* internal procedure to get 1 logical record */ if cseg.lrec.bufP = null then do; /* get a block if inactive buffer */ restart: call tape_ansi_tape_io_$read (cP, cseg.lrec.bufP, cseg.nc_buf, ecode); /* get 1 physical block */ if ecode ^= 0 then do; /* was there an error or EOF? */ if ecode = error_table_$eof_record then do; /* EOF detected */ if cseg.no_labels then call tape_ansi_nl_file_cntl_$data_eof (iocbP, ecode); else call tape_ansi_file_cntl_$data_eof (iocbP, ecode); if ecode = 0 then go to restart; /* switched to new file section */ else go to r_exit; /* no next volume or error */ end; else do; /* parity or fatal error */ if ecode = error_table_$tape_error then parity_error = "1"b; /* process the block */ else go to r_exit; /* fatal error - terminate processing */ end; end; cseg.blkcnt = cseg.blkcnt + 1; /* keep track of physical blocks read */ if cseg.nc_buf > fd.blklen then cseg.nc_buf = fd.blklen; /* use only as much as wanted */ if fd.format > 2 then do; /* check BDW against block size if V,VB,VS,VBS format */ if fd.mode ^= binary then substr (unspec (BDW.length), 1, 10) = "00"b || substr (unspec (BDW.length), 2, 8); /* shift to get valid binary value when reading in 9 mode */ if BDW.length > cseg.nc_buf then go to inv_desc; /* block is too short */ cseg.nc_buf = BDW.length; /* use all in block */ cseg.offset = 4; /* BDW has been processed */ end; else cseg.offset = 0; /* U, F, or FB format */ end; remain = cseg.nc_buf - cseg.offset; /* get number of characters to be processed */ return; /* exit */ end get_record; process_sw: procedure; /* internal procedure to process SDW's */ dwP = addr (substr (buf, cseg.offset + 1)); /* get pointer to SDW */ if fd.mode ^= binary then /* if not already binary then */ substr (unspec (SDW.length), 1, 10) = "00"b || substr (unspec (SDW.length), 2, 8); /* shift byte right valid binary reading 9 mode */ if cseg.standard = DOS then substr (unspec (SDW.length), 3, 1) = "0"b; /* zero the bit if DOS */ data_len = SDW.length - 4; /* get length of data */ if data_len > remain - 4 then go to inv_desc; if SDW.code < 0 then go to inv_desc; /* error if type < 0 */ if SDW.code > 3 then go to inv_desc; /* error if type > 3 */ cseg.offset = cseg.offset + 4; /* SDW has been processed */ req_off = data_len; /* the entire segment will be processed */ return; /* exit */ end process_sw; skip_segments: procedure; /* internal procedure to skip to beginning of spanned record */ s_get: call get_record; /* get a segment */ call process_sw; /* process its SDW */ if SDW.code = sdw.final then do; /* is this the final segment? */ call read_release; /* release it */ return; /* and exit */ end; call read_release; /* release the segment */ go to s_get; /* get the next segment */ end skip_segments; move_to_user: procedure; /* internal procedure to move data to user's buffer */ if move = 0 then return; fromP = addr (substr (buf, cseg.offset + 1)); /* set pointer to data to be moved */ toP = addr (substr (ub, total + 1)); /* set pointer to user buffer */ if fd.mode = ebcdic then call ebcdic_to_ascii_ (fromP -> data, toP -> data); else toP -> data = fromP -> data; total = total + move; /* sum each move */ return; /* exit */ end move_to_user; read_release: procedure; /* internal procedure to release a record and/or block */ cseg.offset = cseg.offset + req_off; /* the request has been processed */ remain = cseg.nc_buf - cseg.offset; /* get number of characters not yet processed */ if remain < 4 then do; /* if so, the block may have been exhausted */ if fd.format = 2 then if fd.reclen <= remain then return; /* another record? */ call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* block exhausted */ end; return; /* exit */ end read_release; write_record: entry (iocbP, ubP, buf_len, code); /* write_record entry point */ cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */ if cseg.file_lock then do; code = error_table_$file_busy; return; end; else do; on cleanup begin; cseg.file_lock = "0"b; cseg.code = error_table_$fatal_error; end; cseg.file_lock = "1"b; end; if cseg.code ^= 0 then do; /* was there a non-restartable error? */ code = cseg.code; /* set return code */ cseg.file_lock = "0"b; return; end; if ^cseg.no_labels then do; /* only for labeled volumes */ if vl (fl.vlX).pos ^= 1 then do; /* not positioned for output */ call tape_ansi_file_cntl_$position_for_output (iocbP, ecode); if ecode ^= 0 then go to w_exit; /* error */ end; end; go to w_format (fd.format); /* transfer to begin processing */ w_format (1): if buf_len > fd.blklen then go to w_long; /* U format - check buf_len */ call get_buf; /* get a buffer */ move = buf_len; /* move the requested amount of data */ req_off = buf_len; /* number of characters to be processed */ call move_to_buf; /* move the data to the write buffer */ call write_buf; /* write one block */ go to w_count; /* return to caller */ w_format (2): if buf_len > fd.reclen then go to w_long; /* F format - check buf_len validity */ call get_buf; /* get a buffer */ move = buf_len; /* transfer the request as stated */ remain = fd.reclen - buf_len; /* get difference between buf_len and reclen for padding */ if remain ^= 0 then substr (buf, cseg.offset + buf_len + 1, remain) = copy (rpad, remain); /* pad the record */ req_off = fd.reclen; /* process one logical record */ call move_to_buf; /* move the data to the write buffer */ if ^fd.blocked then call write_buf; /* unblocked: write 1 record per block */ else if cseg.offset = fd.blklen then call write_buf; /* blocked: write if block full */ go to w_count; /* return to caller */ w_format (3): data_len = buf_len + 4; /* V format - data length = buf_len + RDW length */ if data_len > fd.reclen then go to w_long; /* check data_len validity */ call get_buf; /* get a buffer */ if fd.blocked then if data_len > fd.blklen - cseg.offset then do; /* record won't fit in this block */ call write_buf; /* write the current buffer contents */ call get_buf; /* get another write buffer */ end; /* request validity has been verified, so just continue */ dwP = addr (substr (buf, cseg.offset + 1)); /* locate rdw position */ cseg.saveP = dwP; /* save the RDW location for pad incrementing */ RDW.length = data_len; /* store the record length */ if fd.mode ^= binary then /* if not already binary */ substr (unspec (RDW.length), 2, 9) = substr (unspec (RDW.length), 3, 8) || "0"b; /* shift high order byte to allow writing in 9 mode */ RDW.pad = "0"b; /* zero the pad field */ cseg.offset = cseg.offset + 4; /* the rdw has been processed */ req_off = buf_len; /* process buf_len characters */ move = buf_len; /* move buf_len characters */ call move_to_buf; /* move the data to the write buffer */ if ^fd.blocked then call write_buf; /* unblocked: write 1 record per block */ else if fd.blklen - cseg.offset < 4 then call write_buf; /* write block if even null record can't fit */ go to w_count; /* return to caller */ w_format (4): if buf_len > fd.reclen then go to w_long; /* VBS format - check buf_len validity */ call get_buf; /* get a buffer */ peel = 0; /* initialize character count */ left = buf_len; /* save request for decrementing */ remain = fd.blklen - cseg.offset; /* get number of characters left in block */ dwP = addr (substr (buf, cseg.offset + 1)); w_fit_check: cseg.saveP = dwP; /* save SDW location for pad incrementing */ if left + 4 <= remain then do; /* will entire request fit in remainder of block? */ if left + 4 > remain - 5 then do; /* Will request be last segment of block? */ i = 4 - (remain - (left + 4));/* get nbr of chars in last word of block */ if i = 0 then move = left; /* 0 in last work: write all this segment */ else if i = 4 then move = left; /* last word full: write all this segment */ /* this segment wont be word aligned; have to back track to previous segment and see how many characters have to be peeled off to make last segment of block word aligned */ else do; peel = mod (cseg.offset, 4); if peel ^= 0 then do; hold = substr (buf, cseg.offset - peel + 1, peel); /* save the unaligned characters */ if SDW.code = sdw.initial then ; else SDW.code = sdw.medial; SDW.length = SDW.length - peel; /* rewrite length - peeled chars in descriptor word */ SDW.code = sdw.medial; substr (unspec (SDW.length), 2, 9) = substr (unspec (SDW.length), 3, 8) || "0"b; cseg.offset = cseg.offset - peel; /* update count to reflect peeled characters */ total = total - peel; /* adjust for characters peeled also */ end; go to w_now; /* segment is word aligned; write out buffer */ end; end; else move = left; /* not last segment of block - move all */ end; else move = remain - 4; /* entire request won't fit - move what will */ left = left - move; /* decrement data to be moved count */ if first_span then do; /* first segment of the record */ first_span = "0"b; /* one time only */ if left = 0 then SDW.code = sdw.complete; /* whole record in one segment */ else SDW.code = sdw.initial; /* only part of record fits */ end; else do; /* not first segment of record */ if left = 0 then SDW.code = sdw.final; /* last segment of record */ else SDW.code = sdw.medial; /* still more to come */ end; data_len = move + peel + 4; /* compute segment length */ if peel > 0 then peel = 0; SDW.length = data_len; /* store segment length */ if fd.mode ^= binary then /* if not binary move right to binary from 9 mode */ substr (unspec (SDW.length), 2, 9) = substr (unspec (SDW.length), 3, 8) || "0"b; if cseg.standard = DOS then if data_len = 4 then substr (unspec (SDW.length), 2, 1) = "1"b; SDW.pad = "0"b; /* zero pad field */ cseg.offset = cseg.offset + 4; /* SDW has been processed */ req_off = move; /* process the data move */ call move_to_buf; /* move data to write buffer */ remain = remain - data_len; /* get number of characters left after request */ if ^fd.blocked then go to w_now; /* ^blocked: write each segment */ if remain < 5 then do; /* another segment can't fit in the block? */ w_now: call write_buf; /* write the block */ call get_buf; /* get another buffer */ remain = fd.blklen - cseg.offset; /* initialize number of remaining characters */ end; dwP = addr (substr (buf, cseg.offset + 1)); /* locate current SDW position */ if peel ^= 0 then do; /* pick up chars had to peel off */ substr (buf, cseg.offset + 5, peel) = substr (hold, 1, peel); /* move chars into buffer */ cseg.offset = cseg.offset + peel; total = total + peel; remain = fd.blklen - cseg.offset; end; if left ^= 0 then go to w_fit_check; /* if more segments need be written, continue processing */ go to w_exit; /* .... or return to caller */ w_long: code = error_table_$long_record; /* set return code */ go to w_exit1; /* csw can't be "1"b, shouldn't lock logical I/O */ w_count: cseg.lrec.reccnt = cseg.lrec.reccnt + 1; w_exit: code = ecode; /* set return code */ cseg.code = code; if csw then go to c_exit; /* if close entry, go to close exit */ w_exit1: cseg.file_lock = "0"b; /* unlock the file */ return; /* return to caller */ get_buf: procedure; /* internal procedure to get a write buffer for data transfer */ if cseg.lrec.bufP = null then do; /* get a buffer if necessary */ call tape_ansi_tape_io_$get_buffer (cP, cseg.lrec.bufP, 0); /* get the buffer */ if fd.format > 2 then cseg.offset = 4; /* set offset for BDW */ else cseg.offset = 0; /* initialize buffer offset */ end; return; /* exit */ end get_buf; move_to_buf: procedure; /* internal procedure to move data from user's buffer */ if move = 0 then go to move_nothing; /* return if no data to be moved */ fromP = addr (substr (ub, total + 1)); /* set pointer to data to be moved */ toP = addr (substr (buf, cseg.offset + 1)); /* set pointer to buffer */ if fd.mode = ebcdic then call ascii_to_ebcdic_ (fromP -> data, toP -> data); else toP -> data = fromP -> data; /* move as is */ total = total + move; /* sum each move */ move_nothing: cseg.offset = cseg.offset + req_off; /* the request has been processed (char offset) */ return; /* return to caller */ end move_to_buf; write_buf: procedure; /* internal procedure to write one physical block */ if cseg.offset < 20 then if fd.format ^= 2 then do; /* pad to 20 bytes if not F format */ remain = 20 - cseg.offset; /* get pad requirement */ go to w_pad; /* pad the block */ end; remain = 4 - mod (cseg.offset, 4); /* block length must be integral multiple of 4 */ if remain ^= 4 then do; /* not multiple - pad to word boundry */ w_pad: substr (buf, cseg.offset + 1, remain) = copy (rpad, remain); /* pad with blanks */ cseg.offset = cseg.offset + remain; /* increment to reflect padding */ end; else remain = 0; /* multiple - indicate no padding performed */ if fd.format > 2 then do; /* should a BDW be included? */ BDW.length = cseg.offset; /* store the block length */ if fd.mode ^= binary then substr (unspec (BDW.length), 2, 9) = substr (unspec (BDW.length), 3, 8) || "0"b; /* shift high order byte to allow writing in 9 mode */ BDW.pad = "0"b; /* zero the pad field */ if remain ^= 0 then do; /* the block was padded: the last rdw must be incremented */ dwP = cseg.saveP; /* get the pointer to the last RDW used */ if fd.mode ^= binary then substr (unspec (RDW.length), 1, 10) = "00"b || substr (unspec (RDW.length), 2, 8); /* pack */ if cseg.standard = DOS then substr (unspec (RDW.length), 3, 1) = "0"b; /* DOS 0 length seg bit */ RDW.length = RDW.length + remain; /* increment to reflect added pad characters */ if fd.mode ^= binary then substr (unspec (RDW.length), 2, 9) = substr (unspec (RDW.length), 3, 8) || "0"b; /* unpack */ end; end; call tape_ansi_tape_io_$write (cP, cseg.lrec.bufP, cseg.offset, ecode); /* write the block */ if ecode = 0 then cseg.blkcnt = cseg.blkcnt + 1; /* OK: up block count */ else if ecode = error_table_$eov_on_write then do;/* EOT detected */ cseg.blkcnt = cseg.blkcnt + 1; /* block was written */ if csw then return; /* ignore EOT if closing */ else do; if cseg.no_labels then call tape_ansi_nl_file_cntl_$data_eot (iocbP, ecode); else call tape_ansi_file_cntl_$data_eot (iocbP, ecode); /* switch to next volume */ if ecode ^= 0 then do; /* terminate if switching failed */ if fd.format = 4 & left ^= 0 then go to w_exit; /* VS/VBS record only partially written */ else do; /* not VS/VBS format, or VS/VBS record completely written */ cseg.code = ecode; /* inhibit further iox_$write_record calls */ code = 0; /* but this call is ok */ cseg.lrec.reccnt = cseg.lrec.reccnt + 1; /* so increment record count */ go to w_exit1; /* and return to caller */ end; end; end; end; else do; /* IO error (occurred on previous block) */ cseg.blkcnt = cseg.blkcnt - cseg.soft_status.nbuf + 1; /* decrement block count */ cseg.lrec.reccnt = -cseg.lrec.reccnt; /* make record count unreliable */ go to w_exit; /* terminate processing */ end; return; /* return to caller */ end write_buf; close: entry (acP, code); /* close entry to synchronize and terminate io */ dcl acP ptr; /* pointer to control segment */ cP = acP; /* set pointer to control segment */ csw = "1"b; /* indicate close entry in case write error */ if cseg.open_mode = 4 then do; /* opened for input */ if cseg.lrec.bufP ^= null then go to close2; /* release an active buffer */ go to c_exit; /* synchronize and finish up io */ end; else do; /* file was opened for output */ if cseg.lrec.bufP = null then go to c_exit; /* no active buffer - synchronize and close */ if cseg.offset = 0 then go to close2; /* active empty buffer - release, synch., and close */ if fd.format > 2 then if cseg.offset = 4 then go to close2; /* active buffer has only a BDW */ call write_buf; /* active buffer with data - write the buffer */ go to c_exit; /* synchronize and close io */ end; close2: call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* release the buffer */ c_exit: call tape_ansi_tape_io_$close (cP, code); /* terminate the tape_ansi_tape_io_ set up */ return; /* exit */ end tape_ansi_ibm_lrec_io_;  tape_ansi_interpret_status_.pl1 11/04/82 1931.3rew 11/04/82 1617.4 80676 /* *************************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1975 by Massachusetts Institute of Technology * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *************************************************************** */ tape_ansi_interpret_status_: procedure (hP); /* interprets MTS500 hardware status bits */ /* hP points to a hardware status structure which contains the MTS500 status bits */ /* to be interpreted. The error codes resulting from the interpretation of this string are */ /* returned in the structure. Created May 3, 1974 by R.E. Klinger. */ /* Modified March 5, 1976 to add a new Command Reject substatus, Invalid Density */ dcl hP pointer; /* argument: pointer to hdw_status structure */ dcl 1 hdw_status based (hP), /* hardware status structure */ 2 hard_stat bit (72) aligned, /* tape status in bits 3-12 (from 1) (Input) */ 2 no_minor fixed bin, /* number of minor status codes (Output) */ 2 major fixed bin (35), /* major status code (Output) */ 2 minor (10) fixed bin (35); /* minor status codes (Output) - 10 is arbitrary */ dcl maj bit (4) unal based (addr (substr (hdw_status.hard_stat, 3))); /* major status portion of hardware status */ dcl min bit (6) unal based (addr (substr (hdw_status.hard_stat, 7))); /* minor status portion of hardware status string */ /* automatic storage */ dcl (i, j) fixed bin; /* temporary indices */ /* static storage */ dcl init_req bit (1) internal static aligned init ("1"b); /* initialization required bit */ dcl major_bits (9) bit (4) internal static aligned init /* major status bit possibilities */ ("0101"b, "1101"b, "0100"b, "0011"b, "1011"b, "0010"b, "1010"b, "0001"b, "0000"b); dcl first_minor_index (9) fixed bin internal static init /* lowest index into minor status mask and result arrays */ (1, 8, 12, 16, 23, 35, 40, 50, 54); dcl last_minor_index (9) fixed bin internal static init /* highest index into minor status mask and result arrays */ (7, 11, 15, 22, 34, 39, 49, 53, 61); dcl mask (61) bit (6) internal static aligned init /* minor status bit masks */ ("111111"b, "111001"b, "111010"b, "111100"b, (10) (1) "111111"b, "000000"b, "111111"b, "111111"b, "000011"b, "000100"b, "001000"b, "010000"b, "100000"b, (12) (1) "111111"b, "110011"b, "111111"b, "100110"b, "101010"b, "110011"b, (15) (1) "111111"b, "001001"b, "111010"b, "000100"b, "110010"b, "110010"b, "110010"b, "111011"b); dcl result (61) bit (6) internal static aligned init /* minor status match results */ ("000000"b, "000001"b, "000010"b, "000100"b, "001000"b, "010000"b, "100000"b, "000001"b, "000010"b, "000011"b, "000100"b, "001111"b, "010011"b, "111111"b, "000000"b, "000001"b, "000010"b, "000011"b, "000100"b, "001000"b, "010000"b, "100000"b, "000001"b, "000010"b, "000011"b, "000100"b, "001000"b, "001001"b, "100000"b, "010000"b, "010001"b, "010010"b, "010011"b, "010100"b, "000001"b, "000010"b, "000100"b, "001000"b, "010000"b, "000001"b, "000010"b, "000011"b, "001000"b, "001100"b, "001101"b, "001110"b, "001111"b, "010000"b, "010001"b, "000001"b, "100000"b, "000010"b, "000100"b, "000000"b, "000001"b, "000010"b, "000100"b, "010000"b, "100000"b, "110000"b, "001000"b); dcl major_code (9) fixed bin (35) internal static; /* major status codes */ dcl minor_code (61) fixed bin (35) internal static; /* minor status codes */ %include tape_status_codes; dcl (addr, substr) builtin; if init_req then do; /* initialize code arrays if necessary */ init_req = "0"b; major_code (1) = tape_status_$command_reject; major_code (2) = tape_status_$mpc_command_reject; major_code (3) = tape_status_$end_of_file; major_code (4) = tape_status_$device_data_alert; major_code (5) = tape_status_$mpc_device_data_alert; major_code (6) = tape_status_$device_attention; major_code (7) = tape_status_$mpc_device_attention; major_code (8) = tape_status_$device_busy; major_code (9) = tape_status_$subsystem_ready; minor_code (1) = tape_status_$invalid_density; minor_code (2) = tape_status_$invalid_opcode; minor_code (3) = tape_status_$invalid_device_code; minor_code (4) = tape_status_$invalid_idcw_parity; minor_code (5) = tape_status_$reject_at_bot; minor_code (6) = tape_status_$read_after_write; minor_code (7) = tape_status_$nine_track_error; minor_code (8) = tape_status_$illegal_procedure; minor_code (9) = tape_status_$illegal_lc_number; minor_code (10) = tape_status_$illegal_susp_lc_number; minor_code (11) = tape_status_$continue_not_set; minor_code (12) = tape_status_$seven_track_eof; minor_code (13) = tape_status_$nine_track_eof; minor_code (14) = tape_status_$data_alert; minor_code (15) = tape_status_$single_char_record; minor_code (16) = tape_status_$transfer_timing; minor_code (17) = tape_status_$blank_tape_on_read; minor_code (18) = tape_status_$bit_during_erase; minor_code (19) = tape_status_$transmission_parity; minor_code (20) = tape_status_$lateral_parity; minor_code (21) = tape_status_$longitudinal_parity; minor_code (22) = tape_status_$end_of_tape; minor_code (23) = tape_status_$transmission_alert; minor_code (24) = tape_status_$inconsistent_command; minor_code (25) = tape_status_$sum_check_error; minor_code (26) = tape_status_$byte_locked_out; minor_code (27) = tape_status_$pe_burst_error; minor_code (28) = tape_status_$preamble_error; minor_code (29) = tape_status_$marginal_condition; minor_code (30) = tape_status_$multitrack_error; minor_code (31) = tape_status_$skew_error; minor_code (32) = tape_status_$postamble_error; minor_code (33) = tape_status_$nrzi_ccc_error; minor_code (34) = tape_status_$code_alert; minor_code (35) = tape_status_$write_protect_attention; minor_code (36) = tape_status_$no_such_device; minor_code (37) = tape_status_$device_in_standby; minor_code (38) = tape_status_$device_check; minor_code (39) = tape_status_$blank_tape_on_write; minor_code (40) = tape_status_$configuration_error; minor_code (41) = tape_status_$multiple_devices; minor_code (42) = tape_status_$illegal_device_id; minor_code (43) = tape_status_$incompatible_mode; minor_code (44) = tape_status_$tca_malfunction_port0; minor_code (45) = tape_status_$tca_malfunction_port1; minor_code (46) = tape_status_$tca_malfunction_port2; minor_code (47) = tape_status_$tca_malfunction_port3; minor_code (48) = tape_status_$mth_malfunction; minor_code (49) = tape_status_$multiple_bot; minor_code (50) = tape_status_$in_rewind; minor_code (51) = tape_status_$device_reserved; minor_code (52) = tape_status_$alternate_channel; minor_code (53) = tape_status_$device_loading; minor_code (54) = tape_status_$device_ready; minor_code (55) = tape_status_$write_protected; minor_code (56) = tape_status_$ready_at_bot; minor_code (57) = tape_status_$nine_track_handler; minor_code (58) = tape_status_$two_bit_fill; minor_code (59) = tape_status_$four_bit_fill; minor_code (60) = tape_status_$six_bit_fill; minor_code (61) = tape_status_$ascii_alert; end; do i = 1 to 9; /* look for the major status bits */ if maj = major_bits (i) then go to found; end; found: hdw_status.major = major_code (i); /* set the major status code */ hdw_status.no_minor = 0; /* initialize the minor status count */ do j = first_minor_index (i) to last_minor_index (i); /* look for minor status bits */ if (min & mask (j)) = result (j) then do; /* test */ hdw_status.no_minor = hdw_status.no_minor + 1; /* increment the minor status count */ hdw_status.minor (hdw_status.no_minor) = minor_code (j); /* set the minor status code */ end; end; if i = 3 then hdw_status.no_minor = 1; /* EOF major status - drop multiple SCR code */ return; end tape_ansi_interpret_status_;  tape_ansi_lrec_io_.pl1 11/04/82 1931.3rew 11/04/82 1606.0 214452 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Modified: 4/82 by J. A. Bush for block sizes > 8192 bytes */ tape_ansi_lrec_io_: procedure; /* argument list */ dcl iocbP ptr, /* pointer to IO control block */ ubP ptr, /* pointer to user buffer */ buf_len fixed bin (21), /* number of characters requested for IO */ rec_len fixed bin (21), /* number of characters read */ code fixed bin (35); /* error code */ %include iocb; %include tape_ansi_cseg; %include tape_ansi_fd; %include tape_ansi_fl; /* based overlays */ dcl buf char (cseg.buf_size) aligned based (cseg.lrec.bufP), /* one physical block */ data char (move) unaligned based, /* overlay for data move */ RCW char (4) unaligned based (dwP); /* D-format rdw */ dcl 1 SCW based (dwP), /* segment control word */ 2 code char (1) unaligned,/* control code */ 2 length char (4) unaligned;/* length of segment */ dcl ub char (buf_len) unaligned based (ubP); /* user buffer overlay */ /* error codes */ dcl (error_table_$eov_on_write, error_table_$file_busy, error_table_$invalid_record_desc, error_table_$long_record, error_table_$tape_error, error_table_$fatal_error, error_table_$eof_record) fixed bin (35) external static; /* builtin functions */ dcl (addr, binary, decimal, mod, null, substr, verify) builtin; /* conditions */ dcl (cleanup, conversion) condition; /* automatic storage */ dcl (i, j) fixed bin, /* temporary storage */ csw bit (1) init ("0"b), /* indicates close entry */ total fixed bin (21) initial (0), /* number of characters moved in this request */ move fixed bin initial (0), /* number of characters moved per segment/record */ left fixed bin (21), /* number of characters remaining for this request */ long_record bit (1) initial ("0"b), /* long record switch */ parity_error bit (1) initial ("0"b), /* parity error switch */ req_off fixed bin, /* number of buffer characters processed by this request */ remain fixed bin, /* number of unprocessed characters in buffer */ ecode fixed bin (35) init (0), /* temporary error code */ data_len fixed bin initial (0), /* number of characters in varying length record */ cwl picture "9999", /* control word length for RCW and SCW */ first_span bit (1) initial ("1"b); /* first segment of spanned request switch */ /* pointers */ dcl dwP ptr, /* pointer to RCW - SCW */ fromP ptr, /* pointer to buffer for data move */ toP ptr; /* pointer to user buffer for data move */ /* static storage */ dcl 1 scw internal static aligned, /* SCW data */ 2 complete char (1) initial ("0"), /* complete code - ASCII 0 */ 2 initial char (1) initial ("1"), /* initial code - ASCII 1 */ 2 medial char (1) initial ("2"), /* medial code - ASCII 2 */ 2 final char (1) initial ("3"); /* final code - ASCII 3 */ dcl bpad char (20) internal static init ((20)"^"); dcl ebcdic init (2) fixed bin internal static; /* subroutine calls */ dcl ascii_to_ebcdic_ ext entry (char (*), char (*)), ebcdic_to_ascii_ ext entry (char (*), char (*)), tape_ansi_file_cntl_$data_eof ext entry (ptr, fixed bin (35)), tape_ansi_file_cntl_$data_eot ext entry (ptr, fixed bin (35)), tape_ansi_file_cntl_$position_for_output ext entry (ptr, fixed bin (35)), tape_ansi_tape_io_$close ext entry (ptr, fixed bin (35)), tape_ansi_tape_io_$get_buffer ext entry (ptr, ptr, fixed bin (35)), tape_ansi_tape_io_$read ext entry (ptr, ptr, fixed bin, fixed bin (35)), tape_ansi_tape_io_$release_buffer ext entry (ptr, ptr, fixed bin (35)), tape_ansi_tape_io_$write ext entry (ptr, ptr, fixed bin, fixed bin (35)); read_record: entry (iocbP, ubP, buf_len, rec_len, code); /* read_record entry point */ cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */ if cseg.file_lock then do; rec_len = 0; code = error_table_$file_busy; return; end; else do; on cleanup begin; cseg.file_lock = "0"b; cseg.code = error_table_$fatal_error; end; cseg.file_lock = "1"b; end; if cseg.code ^= 0 then do; /* was there a non-restartable error? */ code = cseg.code; /* set return code */ cseg.file_lock = "0"b; return; end; if cseg.rlN ^= -1 then do; /* data record is in read length segment */ if buf_len >= cseg.rlN then do; /* user wants as much as (or more than) we have */ code = 0; move = cseg.rlN; /* give only as much as we have */ end; else do; /* user wants less than we have */ code = error_table_$long_record; move = buf_len; /* give what s(he) wants */ end; ubP -> data = cseg.rlP -> data; /* move to user */ rec_len = move; /* indicate amount moved */ cseg.rlN = -1; /* read length buffer is now empty */ cseg.lrec.reccnt = cseg.lrec.reccnt + 1; cseg.file_lock = "0"b; return; end; go to r_format (fd.format); /* transfer to begin processing */ r_format (1): call get_record; /* U format - get a logical record */ move = remain; /* user gets all, even pad chars (if any) */ if buf_len < move then do; /* buffer < record */ long_record = "1"b; move = buf_len; /* move as much as can fit */ end; req_off = remain; /* this request processes the entire block */ call move_to_user; /* move data to user's workspace */ call read_release; /* release the record */ go to r_count; /* return to caller */ r_format (2): call get_record; /* get 1 record */ if fd.reclen > remain then move = remain; /* don't try to move more than we have */ else move = fd.reclen; /* move only up to 1 record's worth */ if buf_len < move then do; /* buffer < record */ long_record = "1"b; move = buf_len; /* move only what can fit */ end; req_off = fd.reclen; /* process one record */ call move_to_user; /* move data to user's workspace */ call read_release; /* release the record */ go to r_count; /* return to caller */ r_format (3): call get_record; /* D format - get a logical record */ if substr (buf, cseg.offset + 1, 1) = "^" then do;/* pad RCW? */ call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* pad rcw is last in block */ go to r_format (3); /* try again */ end; dwP = addr (substr (buf, cseg.offset + 1)); /* get pointer to rcw */ on conversion go to inv_desc; /* detect invalid descriptor */ data_len = binary (RCW, 17) - 4; /* get length of data */ revert conversion; /* stop handling the condition */ if data_len > remain - 4 then go to inv_desc; /* block bigger than block size? */ move = data_len; /* move up to 1 record */ if buf_len < move then do; /* buffer < record */ long_record = "1"b; move = buf_len; /* move only what can fit */ end; cseg.offset = cseg.offset + 4; /* the rdw has been processed */ req_off = data_len; /* process one logical record */ call move_to_user; /* move data to user's workspace */ call read_release; /* release the record */ go to r_count; /* return to caller */ r_format (4): call get_record; /* S format - get a logical record */ left = buf_len; /* save request for decrementing */ r_sw_check: call process_sw; /* process the SCW - get type and data length */ if left >= data_len then move = data_len; /* give user the entire segment..... */ else do; /* user doesn't want all the data */ long_record = "1"b; /* buffer < record */ move = left; /* move only as much as can fit */ end; call move_to_user; /* move the data to the user's workspace */ left = left - move; /* keep track of remainder of request */ if SCW.code = scw.complete | SCW.code = scw.final then do; /* segment is last (or only) of record */ call read_release; /* release it */ go to r_count; /* and we're done */ end; else call read_release; /* release the record and continue */ if left ^= 0 then do; /* user wants more, and more segments are available */ call get_record; /* get the next segment */ go to r_sw_check; /* transfer to process the SCW/SDW, etc. ..... */ end; call skip_segments; /* request satisfied, but more segments remain - skip them */ long_record = "1"b; /* buffer < record */ go to r_count; /* return to caller */ inv_desc: ecode = error_table_$invalid_record_desc; /* set error ecode */ go to r_exit; r_count: cseg.lrec.reccnt = cseg.lrec.reccnt + 1; r_exit: if parity_error then code = error_table_$tape_error; else code = ecode; cseg.code = code; if code = 0 then if long_record then code = error_table_$long_record; rec_len = total; /* return total number of characters moved */ cseg.file_lock = "0"b; return; /* and return to the caller */ get_record: procedure; /* internal procedure to get 1 logical record */ if cseg.lrec.bufP = null then do; /* get a block if inactive buffer */ restart: call tape_ansi_tape_io_$read (cP, cseg.lrec.bufP, cseg.nc_buf, ecode); /* get 1 physical block */ if ecode ^= 0 then do; /* was there an error or EOF? */ if ecode = error_table_$eof_record then do; /* EOF detected */ call tape_ansi_file_cntl_$data_eof (iocbP, ecode); /* see if follow-on volume */ if ecode = 0 then go to restart; /* switched to new file section */ else go to r_exit; /* no next volume or error */ end; else do; /* not EOF - some sort of error */ if ecode = error_table_$tape_error then parity_error = "1"b; /* process this block */ else go to r_exit; /* terminate processing */ end; end; cseg.blkcnt = cseg.blkcnt + 1; /* keep track of physical blocks read */ cseg.offset = fd.bo; /* skip ANSI block prefix, if any */ if cseg.nc_buf - cseg.offset < 0 then do; /* fatal error */ ecode = error_table_$fatal_error; go to r_exit; end; if cseg.nc_buf > fd.blklen then cseg.nc_buf = fd.blklen; /* eliminate obvious padding */ if fd.format = 2 then do; /* F/FB - strip pad characters */ i = (cseg.nc_buf - fd.bo) / fd.reclen; /* # of records */ j = mod (cseg.nc_buf - fd.bo, fd.reclen); /* # of extra chars */ if j ^= 0 then do; /* if any, test them */ if verify (substr (buf, cseg.nc_buf - j + 1, j), "^") = 0 then cseg.nc_buf = cseg.nc_buf - j; /* all pad - eliminate */ else go to out; /* keep all - treat as short record */ end; do j = i to 1 by -1; /* test records for all "^" */ if verify (substr (buf, fd.bo + ((j - 1) * fd.reclen) + 1, fd.reclen), "^") = 0 then cseg.nc_buf = cseg.nc_buf - fd.reclen; else go to out; /* reached end of pad characters */ end; end; end; out: remain = cseg.nc_buf - cseg.offset; /* get number of characters to be processed */ return; /* exit */ end get_record; process_sw: procedure; /* internal procedure to process SCW's */ ck_dw: if substr (buf, cseg.offset + 1, 1) = "^" then do;/* pad SCW? */ call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* all pad chars - release block */ call get_record; /* get another record */ go to ck_dw; /* try again */ end; dwP = addr (substr (buf, cseg.offset + 1)); /* get pointer to SDW/SCW */ on conversion go to inv_desc; /* handle the conversion condition */ data_len = binary (SCW.length, 17) - 5; /* get length of data */ if binary (SCW.code) > 3 then go to inv_desc; /* error if SCW.code > 3 */ if data_len > remain - 5 then go to inv_desc; /* block greater than block size? */ revert conversion; /* disable the condition handler */ cseg.offset = cseg.offset + 5; /* SCW has been processed */ req_off = data_len; /* the entire segment will be processed */ return; /* exit */ end process_sw; skip_segments: procedure; /* internal procedure to skip to beginning of spanned record */ s_get: call get_record; /* get a segment */ call process_sw; /* process its SCW/SDW */ if SCW.code = scw.final then do; /* is this the final segment? */ call read_release; /* release it */ return; /* and exit */ end; call read_release; /* release the segment */ go to s_get; /* get the next segment */ end skip_segments; move_to_user: procedure; /* internal procedure to move data to user's workspace */ if move = 0 then return; fromP = addr (substr (buf, cseg.offset + 1)); /* set pointer to data to be moved */ toP = addr (substr (ub, total + 1)); /* set pointer to user buffer */ if fd.mode ^= ebcdic then toP -> data = fromP -> data; /* ascii/binary */ else call ebcdic_to_ascii_ (fromP -> data, toP -> data); /* ebcdic */ total = total + move; /* sum each move */ return; /* exit */ end move_to_user; read_release: procedure; /* internal procedure to release a record and/or block */ cseg.offset = cseg.offset + req_off; /* the request has been processed */ remain = cseg.nc_buf - cseg.offset; /* get number of characters not yet processed */ if fd.format = 4 then if remain < 5 then go to release_it; /* S format and SCW can't fit */ else return; /* S format and SCW can fit */ if remain < 4 then do; /* if so, the block may have been exhausted */ if fd.format = 2 then if fd.reclen <= remain then return; /* save if another record could fit */ release_it: call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* block exhausted */ end; return; /* exit */ end read_release; write_record: entry (iocbP, ubP, buf_len, code); /* write_record entry point */ cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */ if cseg.file_lock then do; code = error_table_$file_busy; return; end; else do; on cleanup begin; cseg.file_lock = "0"b; cseg.code = error_table_$fatal_error; end; cseg.file_lock = "1"b; end; if cseg.code ^= 0 then do; /* was there a non-restartable error? */ code = cseg.code; /* set return code */ cseg.file_lock = "0"b; return; end; if vl (fl.vlX).pos ^= 1 then do; /* not positioned for output */ call tape_ansi_file_cntl_$position_for_output (iocbP, ecode); if ecode ^= 0 then go to w_exit; /* error */ end; go to w_format (fd.format); /* transfer to begin processing */ w_format (1): if buf_len > fd.blklen - fd.bo then go to w_long; /* U format - check buf_len */ call get_buf; /* get a buffer */ move = buf_len; /* move the requested amount of data */ req_off = buf_len; /* number of characters to be processed */ call move_to_buf; /* move the data to the write buffer */ call write_buf; /* write one block */ go to w_count; /* return to caller */ w_format (2): if buf_len > fd.reclen then go to w_long; /* F format - check buf_len validity */ call get_buf; /* get a buffer */ move = buf_len; /* transfer the request as stated */ remain = fd.reclen - buf_len; /* get difference between buf_len and reclen for padding */ if remain ^= 0 then substr (buf, cseg.offset + buf_len + 1, remain) = " "; /* pad the record */ req_off = fd.reclen; /* process one logical record */ call move_to_buf; /* move the data to the write buffer */ if ^fd.blocked then call write_buf; /* unblocked: write 1 record per block */ else if cseg.offset = fd.blklen then call write_buf; /* blocked: write if block full */ go to w_count; /* return to caller */ w_format (3): data_len = buf_len + 4; /* D format - record length = buf_len + rdw length */ if data_len > fd.reclen then go to w_long; /* check data_len validity */ call get_buf; /* get a buffer */ if fd.blocked then if data_len > fd.blklen - cseg.offset then do; /* record won't fit in this block */ call write_buf; /* write the current buffer contents */ call get_buf; /* get another write buffer */ end; /* request validity has been verified, so just continue */ dwP = addr (substr (buf, cseg.offset + 1)); /* locate rdw position */ cwl = decimal (data_len, 4); /* convert length to ASCII characters */ RCW = cwl; /* store in RCW */ cseg.offset = cseg.offset + 4; /* the rdw has been processed */ req_off = buf_len; /* process buf_len characters */ move = buf_len; /* move buf_len characters */ call move_to_buf; /* move the data to the write buffer */ if ^fd.blocked then call write_buf; /* unblocked: write 1 record per block */ else if fd.blklen - cseg.offset < 4 then call write_buf; /* write block if even null record can't fit */ go to w_count; /* return to caller */ w_format (4): if buf_len > fd.reclen then go to w_long; /* S format - check buf_len validity */ call get_buf; /* get a buffer */ left = buf_len; /* save request for decrementing */ remain = fd.blklen - cseg.offset; /* get number of characters left in block */ w_fit_check: dwP = addr (substr (buf, cseg.offset + 1)); /* locate SCW position */ if left + 5 <= remain then do; /* will the request fit entirely? */ if first_span then SCW.code = scw.complete; /* if first segment then code is complete */ else SCW.code = scw.final; /* else code is final */ move = left; /* move all the data */ end; else do; /* request will not fit in block */ if first_span then do; /* if first segment then this is initial */ SCW.code = scw.initial; /* set code */ first_span = "0"b; /* set switch to indicate medial/final segments to follow */ end; else SCW.code = scw.medial; /* not first segment, won't fit -- medial segment */ move = remain - 5; /* move as much data as will fit */ end; left = left - move; /* decrement data to be moved count */ data_len = move + 5; /* compute segment length */ cwl = decimal (data_len, 4); /* convert length to ASCII characters */ SCW.length = cwl; /* store in SCW */ cseg.offset = cseg.offset + 5; /* SCW has been processed */ req_off = move; /* process the data move */ call move_to_buf; /* move data to write buffer */ remain = remain - data_len; /* get number of characters left after request */ if ^fd.blocked then go to w_now; /* write each segment if not blocked */ if remain < 6 then do; /* blocked: could another segment fit? */ w_now: call write_buf; /* write the block */ call get_buf; /* get another buffer */ remain = fd.blklen - cseg.offset; /* initialize number of remaining characters */ end; if left ^= 0 then go to w_fit_check; /* if more segments need be written, continue processing */ go to w_count; /* .... or return to caller */ w_long: code = error_table_$long_record; /* set return code */ go to w_exit1; /* csw can't be "1"b and shouldn't lock file */ w_count: cseg.lrec.reccnt = cseg.lrec.reccnt + 1; /* increment record count */ w_exit: code = ecode; /* return error code (if any) */ cseg.code = code; /* set logical record I/O lock (if any) */ if csw then go to c_exit; /* if close entry, go to close exit */ w_exit1: cseg.file_lock = "0"b; /* unlock the file */ return; /* return to caller */ get_buf: procedure; /* internal procedure to get a write buffer for data transfer */ if cseg.lrec.bufP = null then do; /* get a buffer if necessary */ call tape_ansi_tape_io_$get_buffer (cP, cseg.lrec.bufP, 0); /* get the buffer */ cseg.offset = fd.bo; /* initialize buffer offset */ if cseg.offset ^= 0 then substr (buf, 1, cseg.offset) = ""; /* set to blanks */ end; return; /* exit */ end get_buf; move_to_buf: procedure; /* internal procedure to move data from user's buffer */ if move = 0 then go to move_nothing; /* return if no data to be moved */ fromP = addr (substr (ub, total + 1)); /* set pointer to data to be moved */ toP = addr (substr (buf, cseg.offset + 1)); /* set pointer to buffer */ if fd.mode ^= ebcdic then toP -> data = fromP -> data; /* ascii/binary */ else call ascii_to_ebcdic_ (fromP -> data, toP -> data); /* ebcdic */ total = total + move; /* sum each move */ move_nothing: cseg.offset = cseg.offset + req_off; /* the request has been processed */ return; /* return to caller */ end move_to_buf; write_buf: procedure; /* internal procedure to write one physical block */ if cseg.offset < 20 then do; /* pad to 20 bytes if < 20 bytes */ remain = 20 - cseg.offset; /* get pad requirement */ go to w_pad; /* pad the block */ end; w_mod: remain = 4 - mod (cseg.offset, 4); /* get difference between actual and desired blklen */ if remain = 4 then go to w_put; /* length is correct - do not pad */ w_pad: substr (buf, cseg.offset + 1, remain) = substr (bpad, 1, remain); /* pad with circumflex */ cseg.offset = cseg.offset + remain; /* increment to reflect padding */ w_put: call tape_ansi_tape_io_$write (cP, cseg.lrec.bufP, cseg.offset, ecode); /* write the block */ if ecode = 0 then cseg.blkcnt = cseg.blkcnt + 1; /* OK: up block count */ else if ecode = error_table_$eov_on_write then do;/* EOT detected */ cseg.blkcnt = cseg.blkcnt + 1; /* block was written */ if csw then return; /* ignore EOT if closing */ else do; call tape_ansi_file_cntl_$data_eot (iocbP, ecode); /* switch to next volume */ if ecode ^= 0 then do; /* terminate if switching failed */ if fd.format = 4 & left ^= 0 then go to w_exit; /* S format record only partially written */ else do; /* not S format, or S and completely written */ cseg.code = ecode; /* inhibit further iox_$write_record calls */ code = 0; /* but return no error on this call */ cseg.lrec.reccnt = cseg.lrec.reccnt + 1; /* increment record count */ go to w_exit1; /* return to caller */ end; end; end; end; else do; /* IO error (occurred on a previous block) */ cseg.blkcnt = cseg.blkcnt - cseg.soft_status.nbuf + 1; /* decrement block count */ cseg.lrec.reccnt = -cseg.lrec.reccnt; /* make record count unreliable */ go to w_exit; /* terminate processing */ end; return; /* return to caller */ end write_buf; close: entry (acP, code); /* close entry to synchronize and terminate io */ dcl acP ptr; /* pointer to control segment */ cP = acP; /* set pointer to control segment */ csw = "1"b; /* indicate close entry in case write error */ if cseg.open_mode = 4 then do; /* opened for input */ if cseg.lrec.bufP ^= null then go to close2; /* release an active buffer */ go to c_exit; /* synchronize and finish up io */ end; else do; /* file was opened for output */ if cseg.lrec.bufP = null then go to c_exit; /* no active buffer - synchronize and close */ if cseg.offset = 0 then go to close2; /* active empty buffer - release, synch., and close */ if cseg.offset = fd.bo then go to close2; /* buffer has only a block prefix */ call write_buf; /* active buffer with data - write the buffer */ go to c_exit; /* synchronize and close io */ end; close2: call tape_ansi_tape_io_$release_buffer (cP, cseg.lrec.bufP, 0); /* release the buffer */ c_exit: call tape_ansi_tape_io_$close (cP, code); /* terminate the tape_ansi_tape_io_ set up */ return; /* exit */ end tape_ansi_lrec_io_;  tape_ansi_mount_cntl_.pl1 12/17/86 0926.4r w 12/17/86 0829.4 200538 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-18,GWMay), approve(), audit(), install(): old history comments: 0) Created: 09/25/74 by Ross E. Klinger 1) Modified: 11/06/74 by Ross E. Klinger 2) Modified: 10/26/76 by Janice B. Phillipps 3) Modified: 04/05/77 by Janice B. Phillipps 4) Modified: 04/11/78 by C. D. Tavares 5) Modified: 04/28/78 by Michael R. Jordan 6) Modified: 4/79 by R.J.C. Kissel 7) Modified: 4/82 by J. A. Bush for block sizes > 8192 bytes 8) Modified: 9/83 by J. A. Bush to compile with modified include files, (ansi ibm)_vol1.incl.pl1 2) change(86-08-18,GWMay), approve(86-09-09,MCR7536), audit(86-09-17,Dupuis), install(86-09-24,MR12.0-1162): Changed the use of the cseg.wait_switch array. Rather than assigning the 6th and 7th chars of the tape device name as an index into the array, the index will be set to the index of the cseg.vl array which is a one to one correspondence. END HISTORY COMMENTS */ /* * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* N__a_m_e: tape_ansi_mount_cntl_ */ /* */ /* This module performs the following functions: */ /* 1) mount - assigns drive and mounts volume; */ /* 2) remount - demounts volume, mounts new volume on assigned drive; */ /* 3) free - unassigns a drive, demounting volume (if any); */ /* 4) insert_rings - inserts write rings in every mounted volume; */ /* 5) write_protect - sets every active drive to inhibit writing; */ /* 6) write_permit - sets every active drive w/ring to permit writing */ /* */ /* U__s_a_g_e */ /* */ /* dcl tape_ansi_mount_cntl_$mount ext entry */ /* (ptr, fixed bin, fixed bin (35)), */ /* tape_ansi_mount_cntl_$remount ext entry */ /* (ptr, ptr, fixed bin, fixed bin (35)), */ /* tape_ansi_mount_cntl_$free ext entry */ /* (ptr, fixed bin, fixed bin (35)), */ /* tape_ansi_mount_cntl_$insert_rings ext entry */ /* (ptr, fixed bin (35)), */ /* tape_ansi_mount_cntl_$write_protect ext entry */ /* (ptr, fixed bin (35)), */ /* tape_ansi_mount_cntl_$write_permit ext entry */ /* (ptr, fixed bin (35)); */ /* */ /* call tape_ansi_mount_cntl_$mount (cP, vlX, code); */ /* call tape_ansi_mount_cntl_$remount (cP, down_vlX, vlX, code); */ /* call tape_ansi_mount_cntl_$free (cP, vlX, code); */ /* call tape_ansi_mount_cntl_$insert_rings (cP, code); */ /* call tape_ansi_mount_cntl_$write_protect (cP, code); */ /* call tape_ansi_mount_cntl_$write_permit (cP, code); */ /* */ /* 1) cP is a pointer to tape_ansi_cseg. (Input) */ /* */ /* 2) vlX is the index of the volume link array element of the */ /* volume to be mounted or freed. (Input) */ /* */ /* 3) down_vlX is the index of the volume link of the volume to be */ /* dismounted. (Input) */ /* */ /* 4) code is a standard Multics status code. (Output) */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ tape_ansi_mount_cntl_: procedure; /* parameters */ dcl vlX fixed bin, down_vlX fixed bin, code fixed bin (35); %include tape_ansi_cseg; %include ibm_vol1; %include ansi_vol1; %include rcp_volume_formats; %include rcp_resource_types; /* automatic storage */ dcl can_retry bit (1) init ("1"b), den fixed bin, /* density code for tape_ansi_tape_io_$order */ drive_name char (32), /* drive name for user mount message */ i fixed bin, /* label length */ op char (3), /* operation for protect/permit entries */ part char (2) varying, /* particle for user mount message */ vX fixed bin; /* index of current volume link */ /* based storage */ dcl VOL1_label_id char (4) based (addr (cseg.lbl_buf)); /* label identifier of VOL1 label (ANSI or IBM) */ dcl VOL1_80th_char char (1) based (addr (substr (cseg.lbl_buf, 80))); /* 80th character of VOL1 label */ /* conditions */ dcl cleanup condition; /* builtin functions */ dcl (addr, before, binary, divide, rtrim, substr) builtin; /* external procedures */ dcl authenticate_ ext entry (char (*)) returns (char (3) aligned), cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)), canon_for_volume_label_ entry (char (*), char (*), char (*), fixed bin, fixed bin (35)), ebcdic_to_ascii_ ext entry (char (*), char (*)), ioa_ ext entry options (variable), ipc_$block ext entry (ptr, ptr, fixed bin (35)), ipc_$create_ev_chn ext entry (fixed bin (71), fixed bin (35)), ipc_$delete_ev_chn ext entry (fixed bin (71), fixed bin (35)), tape_ansi_tape_io_$order ext entry (ptr, char (3), fixed bin, fixed bin (35)), tape_ansi_tape_io_$sync_read ext entry (ptr, fixed bin, fixed bin (35)), tdcm_$tdcm_attach ext entry (ptr, fixed bin (35)), tdcm_$tdcm_set_buf_size ext entry (ptr, fixed bin, fixed bin (35)), tdcm_$tdcm_detach ext entry (ptr, fixed bin (35)), tdcm_$tdcm_iocall ext entry (ptr, fixed bin (35)), tdcm_$tdcm_message ext entry (ptr, char (*), fixed bin, fixed bin (35)), tdcm_$tdcm_reset_signal ext entry (ptr, fixed bin (35)), tdcm_$tdcm_set_signal ext entry (ptr, fixed bin (35)); /* external static */ dcl ( error_table_$bad_mount_request, error_table_$eof_record, error_table_$blank_tape ) ext static fixed bin (35); mount: entry (cP, vlX, code); /* assign a drive and mount a volume */ vX = vlX; /* set index of current volume link */ on cleanup call cleaner; /* don't leave event channels or drives */ call ipc_$create_ev_chn (tseg.ev_chan, code); /* get an event channel */ if code ^= 0 then return; tseg.version_num = cseg_tseg_version_2; tseg.tracks = 0; /* nine-track drive */ tseg.speed = cseg.speed; if cseg.density = -1 then do; if cseg.standard = 1 then tseg.density = "00100"b; /* 800 bpi */ else tseg.density = "00010"b; /* 1600 bpi */ end; else do; if cseg.density = 2 then tseg.density = "00100"b; /* 800 bpi */ else if cseg.density = 3 then tseg.density = "00010"b; /* 1600 bpi */ else if cseg.density = 4 then tseg.density = "00001"b; /* 6250 bpi */ else tseg.density = "00100"b; /* 800 bpi */ end; tseg.buffer_count = 0; /* attach call */ tseg.get_size = 1; /* all IO to return block lengths */ call tdcm_$tdcm_attach (addr (tseg), code); /* assign a drive */ if code ^= 0 then go to er_exit; /* trouble */ else cseg.nactive = cseg.nactive + 1; /* ok - up active count */ if cseg.buf_size > 8192 then do; /* if user requesting large block size... */ call tdcm_$tdcm_set_buf_size (addr (tseg), divide (cseg.buf_size, 4, 17, 0), code); if code ^= 0 then /* if could'nt assign it.. */ go to er_exit; end; up: call mount_request; /* issue message to operator and wait */ vl (vX).rcp_id = vX; /* fill volume link */ vl (vX).tape_drive = tseg.drive_name; vl (vX).event_chan = tseg.ev_chan; vl (vX).ws_segno = tseg.ws_segno; /* save IOI wks segno */ vl (vX).cflX = 0; call VOL1_check (code); /* verify status of VOL1 label */ if code ^= 0 then go to er_exit; /* trouble */ /* only if VOL label looks good do we check the file labels for valid standard */ /* if vl (vX).write_VOL1 = 0 then call hdr_eox_check (code); */ if code ^= 0 then do; vl (vX).write_VOL1 = 6; /* not standard file set */ code = 0; end; return; remount: entry (cP, down_vlX, vlX, code); /* switches volumes on an active drive */ vX = down_vlX; /* first work with down volume */ tseg.drive_name = vl (vX).tape_drive; /* set tseg to use this drive */ tseg.ev_chan = vl (vX).event_chan; tseg.ws_segno = vl (vX).ws_segno; on cleanup call cleaner; /* exit with consistency */ vl (vX).cflX = 0; /* invalidate position */ call unload; vl (vX).rcp_id = 0; /* invalidate volume link */ vX = vlX; /* now work with volume to go up */ go to up; /* mount the new volume */ insert_rings: entry (cP, code); /* dismount, insert rings, and remount */ on cleanup call cleaner; /* don't leave event channel or drive */ cseg.write_ring = "1"b; /* rings will be in */ do vX = 1 to cseg.vcN; /* test each volume */ if vl (vX).rcp_id ^= 0 then do; /* mounted */ tseg.drive_name = vl (vX).tape_drive; /* set-up for insertion */ tseg.ev_chan = vl (vX).event_chan; tseg.ws_segno = vl (vX).ws_segno; vl (vX).cflX = 0; /* invalidate position */ call unload; call mount_request; /* tell operator to mount */ end; end; return; write_protect: entry (cP, code); /* set file protect */ op = "pro"; /* operatio is file _p_r_otect */ cseg.protect = "1"b; go to com; write_permit: entry (cP, code); /* set file permit */ op = "per"; /* operation is _p_e_rmit */ cseg.protect = "0"b; com: on cleanup call cleaner; /* maintain consistency */ do vX = 1 to cseg.vcN; /* test each volume */ if vl (vX).rcp_id ^= 0 then do; /* mounted */ tseg.drive_name = vl (vX).tape_drive; /* set-up to use this volume */ tseg.ws_segno = vl (vX).ws_segno; tseg.ev_chan = vl (vX).event_chan; call tape_ansi_tape_io_$order (cP, op, 0, code); /* set protect or permit */ if code ^= 0 then go to er_exit; end; end; return; free: entry (cP, vlX, code); /* unassign a drive */ vX = vlX; /* copy index of current volume link */ tseg.drive_name = vl (vX).tape_drive; /* set-up for detach */ tseg.ev_chan = vl (vX).event_chan; tseg.ws_segno = vl (vX).ws_segno; vl (vX).cflX = 0; /* invalidate volume position */ on cleanup call cleaner; /* don't leave event channel or drive */ call tdcm_$tdcm_reset_signal (addr (tseg), 0); cseg.wait_switch (vl (vX).rcp_id) = "0"b; call tdcm_$tdcm_detach (addr (tseg), code); /* unassign the drive */ vl (vX).tape_drive = ""; vl (vX).rcp_id = 0; vl (vX).ws_segno = "0"b; if code ^= 0 then go to er_exit; /* trouble */ else cseg.nactive = cseg.nactive - 1; /* ok - down active count */ call ipc_$delete_ev_chn (tseg.ev_chan, code); /* delete event channel */ if code ^= 0 then go to er_exit; /* trouble */ vl (vX).event_chan = 0; tseg.ev_chan = 0; return; er_exit: call cleaner; /* cleanup if error */ code = error_table_$bad_mount_request; return; cleaner: procedure; /* cleanup and error exit procedure */ dcl ecode fixed bin (35); if tseg.drive_name ^= "" then do; /* detach drive if attached */ call tdcm_$tdcm_reset_signal (addr (tseg), 0); cseg.wait_switch (vl (vX).rcp_id) = "0"b; call tdcm_$tdcm_detach (addr (tseg), ecode); if ecode = 0 then cseg.nactive = cseg.nactive - 1; /* down active count */ tseg.drive_name = ""; vl (vX).ws_segno = "0"b; vl (vX).tape_drive = ""; vl (vX).rcp_id = 0; end; if tseg.ev_chan ^= 0 then do; /* delete event channel if created */ call ipc_$delete_ev_chn (tseg.ev_chan, 0); tseg.ev_chan = 0; vl (vX).event_chan = 0; end; vl (vX).cflX = 0; return; end cleaner; wait: procedure (ecode); /* waits for tdcm_ interrupt */ dcl ecode fixed bin (35); dcl 1 wait_list, /* ipc_$block parameters */ 2 n fixed bin, 2 chn fixed bin (71); dcl 1 message, 2 channel fixed bin (71), 2 msg fixed bin (71), 2 sender bit (36), 2 origin, 3 dev_sig bit (18) unaligned, 3 ring bit (18) unaligned, 2 channel_index fixed bin; again: wait_list.n = 1; /* waiting for only 1 interrupt */ wait_list.chn = tseg.ev_chan; /* set ID */ call ipc_$block (addr (wait_list), addr (message), ecode); /* wait */ if ecode ^= 0 then go to reset; /* always reset the signal */ tseg.sync = 1; /* do a synchronous reset status */ tseg.command_count = 1; tseg.buffer_count = 0; tseg.command_queue (1) = 100000b; call tdcm_$tdcm_iocall (addr (tseg), ecode); if tseg.completion_status ^= 1 then go to again; reset: call tdcm_$tdcm_reset_signal (addr (tseg), 0); /* no more signalling */ if vl (vX).rcp_id ^= 0 then cseg.wait_switch (vl (vX).rcp_id) = "0"b; return; end wait; VOL1_check: procedure (ecode); /* verify VOL1 label */ dcl ecode fixed bin (35), data char (80) unaligned based (cseg.syncP); /* 80 characters of synchronous IO buffer */ do den = 2 to 4; /* try to read at 800, 1600, or 6250 bpi */ call tape_ansi_tape_io_$order (cP, "rew", 0, ecode); if ecode ^= 0 then return; call tape_ansi_tape_io_$order (cP, "sdn", den, ecode); /* set density */ if ecode = 0 /* if read ok, then ... */ then do; call tape_ansi_tape_io_$sync_read (cP, i, ecode); /* try to read VOL1 label */ if ecode = 0 then do; /* read was uneventful */ if i >= 80 then do; /* could be a label */ if cseg.standard = 1 then cseg.lbl_buf = data; /* ascii - put in lbl_buf */ else call ebcdic_to_ascii_ (data, cseg.lbl_buf); /* ebcdic - convert move to lbl_buf */ go to got_it; /* check whatever we got */ end; else do; /* can't be a VOL1 label */ invalid_VOL1: vl (vX).write_VOL1 = 3; /* indicate not valid VOL1 label */ go to wvol1; end; end; else if ecode = error_table_$eof_record then goto invalid_VOL1; else if ecode = error_table_$blank_tape then do; /* tape is blank */ vl (vX).write_VOL1 = 1; /* indicate blank tape */ go to wvol1; end; end; end; vl (vX).write_VOL1 = 2; /* can't read it (error or 200 or 556 bpi) */ wvol1: if cseg.density = -1 then do; /* no density specified */ if cseg.standard = 1 then cseg.density = 2; /* ANSI default is 800 cpi */ else cseg.density = 3; /* IBM default is 1600 bpi */ end; if cseg.density ^= den then do; /* must set density again */ call tape_ansi_tape_io_$order (cP, "rew", 0, ecode); /* rewind to set density */ if ecode ^= 0 then return; call tape_ansi_tape_io_$order (cP, "sdn", (cseg.density), ecode); /* set density) */ end; else ecode = 0; return; got_it: if VOL1_label_id ^= "VOL1" then go to invalid_VOL1; /* not VOL1 label */ if cseg.standard = 1 then do; /* ANSI - test 80th character */ i = cv_dec_check_ (VOL1_80th_char, ecode); /* convert to binary */ if ecode ^= 0 then go to invalid_VOL1; /* not number - invalid */ if i < 1 then go to invalid_VOL1; /* must be 1 <_ i <_ 3 */ if i > 3 then go to invalid_VOL1; end; /* if VOL1_volume_id ^= vl (vX).canonical_volname then do; /* identifiers don't match * / vl (vX).write_VOL1 = 4; /* indicate wrong volume identifier * / go to wvol1; end; */ if (cseg.density = -1) | (cseg.density = den) then do; /* all seems well */ cseg.density = den; /* set it to that of the tape */ /* check the format of the VOL1 label for earlier Multics format */ ibm_vol1P, ansi_vol1P = addr (cseg.lbl_buf); vl (vX).auth_code = authenticate_ (vl (vX).volname); if cseg.standard = 1 then if ansi_vol1.owner_id.auth_code = vl (vX).auth_code then vl (vX).write_VOL1 = 0; else vl (vX).write_VOL1 = -1; else if ibm_vol1.owner_id.auth_code = vl (vX).auth_code then vl (vX).write_VOL1 = 0; else vl (vX).write_VOL1 = -1; ecode = 0; /* and no errors */ return; /* so just exit */ end; vl (vX).write_VOL1 = 5; /* density doesn't match */ go to wvol1; /* change tape density to specified value */ end VOL1_check; /* hdr_eox_check: procedure (ecode); dcl label_id char (4) based (addr (cseg.lbl_buf)); dcl data char (80) unaligned based (cseg.syncP), i fixed bin, j fixed bin, ecode fixed bin (35), nchar fixed bin; /* Enter here after successfully read and verified the VOL1 label. * / /* check for file header and trailer labels to complete the tape verification for the ANSI standard * / ecode = 0; /* initialize * / do j = 1 to 2; /* read an 80 char label synchronously: 1st HDR1 then EOX1 * / call tape_ansi_tape_io_$sync_read (cP, nchar, ecode); /* read a block looking for HDR1 * / if ecode ^= 0 then go to non_standard; /* trouble already * / else do; /* read was uneventful * / if nchar < 80 then go to non_standard; /* definitely not a label * / else do; if cseg.standard = 1 then cseg.lbl_buf = data; /* move into buffer * / else call ebcdic_to_ascii_ (data, cseg.lbl_buf); /* translate to ascii * / end; if j = 1 then do; /* looking for HDR1 * / if label_id ^= "HDR1" then go to non_standard; do i = 1 to 2; /* get to trailer label position * / call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode); /* 1st space past header labels; then past file * / if ecode ^= 0 then do; /* might be eof: that's ok * / end; end; end; end; end; if label_id = "EOF1" | label_id = "EOV1" then return; non_standard: ecode = error_table_$invalid_file_set_format; return; end hdr_eox_check; */ mount_request: procedure; /* issues mount message to operator and waits */ dcl msg_temp char (66) varying, (tdcm_reel_name, save_tdcm_reel_name) char (168), /* reel name)to/from tdcm_$tdcm_message */ canon_std (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape); once_again: call tdcm_$tdcm_set_signal (addr (tseg), code); /* interrupt when mounted */ if code ^= 0 then go to er_exit; /* trouble */ if cseg.write_ring then part = "a"; else part = "no"; call ioa_ ("Mounting volume ^a with ^a write ring.", /* write message to user */ vl (vX).volname, part); if vl (vX).comment = "" then msg_temp = ""; else msg_temp = ",*" || vl (vX).comment; save_tdcm_reel_name, tdcm_reel_name = rtrim (vl (vX).volname) || msg_temp; call tdcm_$tdcm_message (addr (tseg), tdcm_reel_name, binary (cseg.write_ring, 17), code); if code ^= 0 then go to er_exit; /* trouble */ if save_tdcm_reel_name ^= tdcm_reel_name then do; vl (vX).volname = before (tdcm_reel_name, ","); call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), vl (vX).volname, vl (vX).canonical_volname, canon_std (standard), code); if code ^= 0 then goto er_exit; end; call wait (code); /* wait for mount */ if code ^= 0 then go to er_exit; /* trouble */ if cseg.write_ring then call ring_check; /* did ring get in?? */ drive_name = tseg.drive_name; call ioa_ ("^a mounted on ^a.", /* inform user */ vl (vX).volname, drive_name); return; ring_check: procedure; /* insures that ring is in tape */ /* reset status op in wait procedure set status bits */ if substr (hardware_status, 3, 4) = "0000"b then if substr (hardware_status, 12, 1) = "1"b then do; /* if write protected still... */ if can_retry then do; /* try to remount with ring only once */ can_retry = "0"b; call ioa_ ("^a mounted without ring - retrying.", /* tell user */ vl (vX).volname); call unload; go to once_again; /* retry the mount */ end; else do; /* 2nd try failed as well */ code = error_table_$bad_mount_request; go to er_exit; end; end; return; /* ring is in tape */ end ring_check; end mount_request; unload: procedure; /* unloads a drive */ call tape_ansi_tape_io_$order (cP, "run", 0, code); /* will wait for, but not set, signal */ if code ^= 0 then go to er_exit; call tdcm_$tdcm_reset_signal (addr (tseg), 0); /* redundant, but just in case... */ cseg.wait_switch (vl (vX).rcp_id) = "0"b; return; end unload; end tape_ansi_mount_cntl_;  tape_ansi_nl_file_cntl_.pl1 12/17/86 0926.4r w 12/17/86 0829.4 383580 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* tape_ansi_nl_file_cntl_ */ /* */ /* Main logic module of tape_ansi_ for unlabeled volumes. See */ /* individual entries for details of use and calling sequence. */ /* */ /* 0) Created: 10/04/74 by Ross E. Klinger */ /* 1) Modified: 10/04/74 by C. D. Tavares for resource management */ /* 2) Modified: 06/29/79 by Rick Riley */ /* (to allow reading/writing unlabeled ibm file sets */ /* 3) Modified: 9/79 by R.J.C. Kissel for new tseg. */ /* 4) Modified: 4/82 by J. A. Bush for block sizes > 8192 bytes */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * */ /* format: style3,ind3,dclind6,idind32 */ tape_ansi_nl_file_cntl_: procedure; /* This entry not used */ /* arguments */ dcl iocbP ptr, /* pointer to iocb */ open_mode fixed bin, /* opening mode */ extend_bit bit (1) aligned, /* extend at open time */ code fixed bin (35); /* error code */ %include iocb; %include tape_ansi_cseg; %include tape_ansi_fd; %include ibm_hdr1; %include rcp_volume_formats; %include rcp_resource_types; /* automatic storage */ dcl answer char (128) varying, com_text char (64) varying, vn char (32), cc fixed bin, /* consistency code */ /* 0 - invalidate volume position */ /* 1 - invalidate volume position and current file link */ /* 2 - invalidate position, current file link, write EOV TM */ mask bit (36) aligned, tstring char (32) varying; /* open description temporary */ dcl 1 qi aligned, /* query info structure */ 2 version fixed bin init (2), 2 yes_no bit (1) unaligned, 2 suppress_name bit (1) unaligned, 2 scode fixed bin (35), 2 qcode fixed bin (35) init (0); /* internal static */ dcl debug bit (1) internal static initial ("0"b); /* debug switch */ /* conditions */ dcl (any_other, cleanup) condition; /* builtin functions */ dcl (addr, index, length, ltrim, mod, null, substr) builtin; /* external procedures */ dcl canon_for_volume_label_ ext entry (char (*), char (*), char (*), fixed bin, fixed bin (35)), command_query_ ext entry options (variable), continue_to_signal_ ext entry (fixed bin (35)), tape_ansi_control_ ext entry (ptr, char (*), ptr, fixed bin (35)), tape_ansi_detach_ ext entry (ptr, fixed bin (35)), tape_ansi_nl_file_cntl_$close ext entry (ptr, fixed bin (35)), tape_ansi_nl_file_cntl_$open ext entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)), hcs_$reset_ips_mask ext entry (bit (36) aligned, bit (36) aligned), hcs_$set_ips_mask ext entry (bit (36) aligned, bit (36) aligned), tape_ansi_ibm_lrec_io_$close ext entry (ptr, fixed bin (35)), tape_ansi_ibm_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), tape_ansi_ibm_lrec_io_$write_record ext entry (ptr, ptr, fixed bin (21), fixed bin (35)), ioa_ ext entry options (variable), iox_$propagate ext entry (ptr), tape_ansi_mount_cntl_$mount ext entry (ptr, fixed bin, fixed bin (35)), tape_ansi_mount_cntl_$remount ext entry (ptr, fixed bin, fixed bin, fixed bin (35)), tape_ansi_position_ ext entry (ptr, fixed bin, fixed bin (21), fixed bin (35)), tape_ansi_read_length_ ext entry (ptr, fixed bin (21), fixed bin (35)), tape_ansi_tape_io_$open ext entry (ptr), tape_ansi_tape_io_$order ext entry (ptr, char (3), fixed bin, fixed bin (35)), terminate_process_ ext entry (char (*), ptr); /* external static */ dcl ( error_table_$blank_tape, error_table_$device_limit_exceeded, error_table_$end_of_info, error_table_$eov_on_write, error_table_$file_aborted, error_table_$file_busy, error_table_$incompatible_attach, error_table_$incompatible_encoding_mode, error_table_$insufficient_open, error_table_$invalid_block_length, error_table_$invalid_cseg, error_table_$invalid_file_set_format, error_table_$invalid_record_length, error_table_$no_file, error_table_$no_next_volume, error_table_$positioned_on_bot, error_table_$unable_to_do_io, error_table_$uninitialized_volume ) fixed bin (35) ext static; dcl sys_info$max_seg_size fixed bin (35) external static; open: entry (iocbP, open_mode, extend_bit, code); cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to control segment */ if cseg.invalid then do; /* is control segment invalid? */ code = error_table_$invalid_cseg; return; end; if cseg.file_lock then do; /* is file in use (by previous invocation)? */ code = error_table_$file_busy; return; end; else do; cc = 0; /* minimal consistency requirement */ on cleanup begin; /* insure file chain <--> tape consistency */ call consistent; cseg.file_lock = "0"b; /* unlock the file */ end; cseg.file_lock = "1"b; /* not in use - now it is */ end; if extend_bit then do; /* extend at open time not allowed */ bad_open: code = error_table_$incompatible_attach; go to valid_exit; end; if open_mode = 4 then tstring = "sequential_input"; /* set for sequential input */ else do; /* sequential output or input_output */ if cseg.output_mode = 0 then go to bad_open; /* no output mode specified */ if open_mode = 5 then tstring = "sequential_output -create"; else go to bad_open; end; cseg.open_mode = open_mode; /* save open mode in control segment */ /* OLD */ cseg.flP = null; fd.vlX = 1; /* OLD */ /* NEW * / cseg.flP = null; /* set the file index pointer no there are none * / if fd.vlX = 0 then do; /* if the vol index not set then set it * / fd.vlX = 1; /* set to initial vol and first file * / vl (1).fflX = 1; go to found_it; end; if append_file () then do; /* when writeing a file we need to find the file * / do i = 1 to cseg.vcN; /* search forward for the file * / if vl (i).fflX ^= 0 then /* only searching vols that have files * / if (fd.sequence >= vl (i).fflX & (fd.sequence <= vl (i).lflX + 1 | vl (i).lflX = 0)) then do; /* then test for a file fit on the volume * / fd.vlX = i; if vl (i).lflX = 0 | fd.sequence <= vl (i).lflX then go to found_it; /* if a new file keep looking * / else do j = i to cseg.vcN; /* look until you find the volume. New files can only be 1+ the last written * / if vl (j).fflX ^= 0 then if (fd.sequence >= vl (j).fflX & (fd.sequence <= vl (j).lflX + 1 | vl (j).lflX = 0)) then fd.vlX = j; end; go to found_it; end; end; code = error_table_$no_file; go to er_exit; end; else do i = 1 to cseg.vcN; /* check for the desired file in the volume index list and first and last of the vols * / if vl (i).fflX = 0 then go to no_find; if (fd.sequence >= vl (i).fflX & fd.sequence <= vl (i).lflX) | (fd.sequence >= vl (i).fflX & vl (i).lflX = 0) then do; /* want volume file first appears on * / fd.vlX = i; go to found_it; end; end; no_find: code = error_table_$no_file; go to er_exit; found_it: /* NEW */ if cseg.open_mode = 4 then do; /* input */ if fd.format = 0 then do; not_enough: code = error_table_$insufficient_open; go to valid_exit; end; if fd.blklen = 0 then go to not_enough; if fd.reclen = 0 then do; if fd.format = 1 then ; else go to not_enough; end; if fd.mode = 0 then fd.mode = 2; call move (fd.vlX, fd.sequence, code); /* move to the file */ if code ^= 0 then go to er_exit; call lrec_open; end; else do; /* output */ if fd.format = 0 then do; fd.format = 3; fd.blocked = "1"b; end; if fd.blklen = 0 then fd.blklen = 8192; if fd.reclen = 0 then do; if fd.format = 1 then ; else if fd.format = 2 then fd.reclen = fd.blklen; else if fd.format = 3 then fd.reclen = 8188; else fd.reclen = sys_info$max_seg_size * 4; end; if fd.mode = 0 then fd.mode = 2; call move (fd.vlX, fd.sequence, code); /* move to the file */ if code ^= 0 then go to er_exit; /* NEW * / do i = fd.vlX + 1 to cseg.vcN; /* reinit the vol indexes above this last file * / call vl_init (i); end; /* NEW */ call lrec_open; end; done: mask = "0"b; /* ips interrupts not masked yet */ cseg.open_description.length = length (tstring); /* prepare open description */ cseg.open_description.string = tstring; revert cleanup; on any_other call handler; /* pick up any condition */ call hcs_$set_ips_mask ("0"b, mask); /* mask all ips interrupts */ iocbP -> iocb.actual_iocb_ptr -> iocb.close = tape_ansi_nl_file_cntl_$close; if cseg.open_mode = 5 then iocbP -> iocb.actual_iocb_ptr -> iocb.write_record = tape_ansi_ibm_lrec_io_$write_record; else do; /* sequential input */ iocbP -> iocb.actual_iocb_ptr -> iocb.read_record = tape_ansi_ibm_lrec_io_$read_record; iocbP -> iocb.actual_iocb_ptr -> iocb.read_length = tape_ansi_read_length_; iocbP -> iocb.actual_iocb_ptr -> iocb.position = tape_ansi_position_; end; iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_; iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = addr (cseg.open_description); call iox_$propagate (iocbP -> iocb.actual_iocb_ptr); call hcs_$reset_ips_mask (mask, mask); /* permit ips interrupts */ cseg.file_lock = "0"b; /* open complete - unlock the file */ return; er_exit: call consistent; go to valid_exit; no_next_volume: code = error_table_$no_next_volume; valid_exit: cseg.file_lock = "0"b; /* open complete - unlock the file */ return; /* NEW * / append_file: procedure returns (bit (1)); if debug then call debug_print ("append_file"); if cseg.open_mode ^= 5 then return ("0"b); if cseg.output_mode ^= 4 then return ("0"b); return ("1"b); end append_file; /* NEW */ abort_file: procedure; /* cleanup after defective file */ if debug then call debug_print ("abort_file"); vl (fd.vlX).cflX = 0; /* invalidate volume position */ /* OLD */ call write_TM (2, code); /* write the TMs */ /* OLD */ /* NEW * / call write_TM (3, code); /* write the TMs * / /* NEW */ if code ^= 0 then if code ^= error_table_$eov_on_write then go to abort_fail; /* OLD */ call ioa_ ("^a: Unrecoverable error while writing file; double TM written.", cseg.module); /* OLD */ /* NEW * / call ioa_ ("^a: Unrecoverable error while writing file; triple TM written.", cseg.module); /* NEW */ code = error_table_$file_aborted; return; abort_fail: call ioa_ ("^a: Unrecoverable error while writing file; unable to write double TM.", cseg.module); code = error_table_$invalid_file_set_format; return; end abort_file; consistent: procedure; /* insures file chain/tape consistency */ if debug then call debug_print ("consistent"); go to recovery (cc); /* perform appropriate consistency processing */ recovery (0): return; recovery (1): if fd.vlX ^= 0 then vl (fd.vlX).cflX = 0; /* invalidate volume position */ return; recovery (2): if fd.vlX = 0 then return; /* nothing can be done - exit */ call abort_file; /* write end of volume TMs */ return; end consistent; handler: procedure; /* intercept any faults during iocb manipulation */ dcl 1 ti aligned, 2 version fixed bin init (0), 2 code fixed bin (35); if mask ^= "0"b then do; /* IPS interrupts masked */ ti.code = error_table_$unable_to_do_io; /* very bad trouble */ call terminate_process_ ("fatal_error", addr (ti)); /* kill the process */ end; call continue_to_signal_ (0); return; end handler; initialize_permitA: procedure (vX) returns (bit (1)); /* query to initialize unexpired volume */ dcl vX fixed bin; dcl msg char (120) varying; dcl msg1 char (length (msg)) based (addr (substr (msg, 1))); msg = "Volume ^a has a valid VOL1 label.^/Do you want to use this volume for unlabeled output?"; go to ip_com; initialize_permitB: entry (vX) returns (bit (1)); /* query to initialize an unreadable volume */ msg = "Cannot determine if volume ^a has a VOL1 label.^/Do you want to use this volume for unlabeled output?"; ip_com: qi.yes_no = "1"b; qi.suppress_name = "0"b; qi.scode = error_table_$uninitialized_volume; call command_query_ (addr (qi), answer, cseg.module, msg1, vl (vX).volname); if answer = "yes" then return ("1"b); else return ("0"b); end initialize_permitA; lrec_open: procedure; /* logical record IO initialization and final checks */ if debug then call debug_print ("lrec_open"); if cseg.open_mode > 4 then if fd.blklen < 18 then go to inv_blk; /* can't write < 18 chars */ if cseg.open_mode > 4 then if mod (fd.blklen, 4) ^= 0 then go to inv_blk; /* can only write words */ if fd.mode = 3 then cseg.mode = 0; /* binary mode is set */ else cseg.mode = 1; /* ascii, ebcdic encoding 9 mode */ go to match (fd.format); /* match the blocking */ match (2): if ^fd.blocked then if fd.blklen ^= fd.reclen then go to inv_rec; /* F unblocked */ else go to ok; else if mod (fd.blklen, fd.reclen) ^= 0 then go to inv_rec; /* F blocked */ else go to ok; match (3): if ^fd.blocked then if fd.blklen - 4 ^= fd.reclen then go to inv_rec; else go to ok; else if fd.reclen > fd.blklen - 4 then go to inv_rec; /* V blocked */ else go to ok; match (4): if fd.reclen > sys_info$max_seg_size * 4 then go to inv_rec; /* S format */ match (1): ok: cseg.rlN = -1; /* invalidate anything in rl segment */ cseg.lrec.bufP = null; /* no active buffer */ cseg.blkcnt = 0; cseg.lrec.reccnt = 0; /* not currently used */ cseg.lrec.code = 0; /* no errors encountered */ call tape_ansi_tape_io_$open (cP); /* initialize call to tape_ansi_tape_io_ */ return; /* exit */ inv_rec: code = error_table_$invalid_record_length; go to er_exit; inv_blk: code = error_table_$invalid_block_length; go to er_exit; bad_mode: code = error_table_$incompatible_encoding_mode; go to er_exit; end lrec_open; move: procedure (vX, fX, ecode); if debug then call debug_print ("move"); dcl vX fixed bin, /* volume link index of desired volume */ fX fixed bin, /* sequence number of desired file */ ecode fixed bin (35); /* error code */ dcl i fixed bin, uninit_msg char (28) varying; cc = 0; if vl (vX).rcp_id = 0 then do; /* volume is not mounted */ if cseg.nactive < cseg.ndrives then do; /* more drives available */ call tape_ansi_mount_cntl_$mount (cP, vX, ecode); /* mount the volume */ if ecode ^= 0 then do; /* maybe trouble */ if ecode = error_table_$device_limit_exceeded then do; cseg.ndrives = cseg.ndrives - 1; /* decrement maximum device count */ go to switch; end; else go to error; /* true trouble */ end; end; else do; /* no drive available */ switch: do i = 1 to vX - 1; /* search up to desired volume */ if vl (i).rcp_id ^= 0 then go to got_one; /* got one active */ end; do i = cseg.vcN to vX + 1 by -1; /* search down to desired volume */ if vl (i).rcp_id ^= 0 then go to got_one; /* got one active */ end; ecode = error_table_$invalid_cseg; /* something very wrong if no volume found */ go to error; got_one: call tape_ansi_mount_cntl_$remount (cP, i, vX, ecode); /* remount the volume */ if ecode ^= 0 then go to error; /* trouble */ end; end; cseg.tseg.drive_name = vl (vX).tape_drive; cseg.tseg.ev_chan = vl (vX).event_chan; fd.vlX = vX; if cseg.open_mode = 5 then do; /* check for VOL1 only if output */ if vl (vX).write_VOL1 = 1 then ; /* tape is blank */ else if vl (vX).write_VOL1 = 3 then ; /* no VOL1 label */ else do; /* has VOL1 label, or can't tell */ if fX ^= 1 then do; /* can't initialize if not first file on volume */ if vl (vX).write_VOL1 = 2 then uninit_msg = "is unreadable"; else uninit_msg = "is not an unlabeled volume"; call ioa_ ("^a: Volume ^a ^a.", cseg.module, vl (vX).volname, uninit_msg); uninit: code = error_table_$uninitialized_volume; go to error; end; go to iq (vl (vX).write_VOL1); iq (6): iq (0): iq (4): iq (5): iq (-1): if initialize_permitA (vX) then go to ok; else go to uninit; iq (2): if ^initialize_permitB (vX) then go to uninit; ok: call tape_ansi_tape_io_$order (cP, "rew", 0, ecode); if ecode ^= 0 then go to error; /* OLD */ call write_TM (2, ecode); /* OLD */ /* NEW * / call write_TM (3, ecode); /* write the init end of vol set TMs * / /* NEW */ if ecode ^= 0 then if ecode ^= error_table_$eov_on_write then go to error; /* OLD */ vl (vX).cflX = 3; /* OLD */ /* NEW * / vl (vX).cflX = vl (vX).fflX + 3; /* set current to three after the first file * / /* NEW */ vl (vX).write_VOL1 = 3; end; end; if vl (vX).cflX = 0 then do; /* volume position unknown */ call tape_ansi_tape_io_$order (cP, "rew", 0, ecode); if ecode ^= 0 then go to error; /* OLD */ vl (vX).cflX = 1; /* OLD */ /* NEW * / vl (vX).cflX = vl (vX).fflX; /* after rewind set file index to first file on volume * / if fX = vl (vX).cflX then go to ok_exit; /* if we are where we want to be at the beginning go on * / /* NEW */ end; if vl (vX).cflX < fX then do; /* volume positioned before desired file */ do i = 1 to fX - vl (vX).cflX; call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode); if ecode ^= 0 then do; if ecode = error_table_$blank_tape then ecode = error_table_$no_file; go to error; end; /* OLD */ end; /* OLD */ /* NEW * / /* when searching forward and the volume indexes are not set then need to read a record looking for eov or eov_set * / if vl (fd.vlX).lflX = 0 then do; /* check for index not set * / call tape_ansi_tape_io_$sync_read (cP, nchar, ecode); /* read a record * / if ecode ^= 0 then do; /* not eof error then error return * / if ecode ^= error_table_$eof_record then go to error; else call tape_ansi_tape_io_$sync_read (cP, nchar, ecode); /* read again hope its a label * / if ecode ^= 0 then do; if ecode = error_table_$eof_record then do; /* if a third eof then we know endofvolset * / ecode = error_table_$no_file; /* set the erorror mseg * / vl (fd.vlX).lflX = vl (fd.vlX).cflX + i - 1; /* set the vol index * / vl (fd.vlX).cflX = vl (fd.vlX).lflX + 3; if append_file () then do; /* check if appending to the last file * / if fX ^= vl (fd.vlX).lflX + 1 then return; /* its okay for last +1 * / else ecode = 0; go to appending; end; else return; end; else go to error; end; if cseg.standard = 1 then cseg.lbl_buf = sync_buf; /* convert ebcdic label * / else call ebcdic_to_ascii_ (sync_buf, cseg.lbl_buf); if substr (lbl_buf, 1, 4) ^= "EOV1" then do; /* is this a label or not * / ecode = error_table_$invalid_file_set_format; /* maybe messed up * / return; end; if debug then call ioa_ ("^80a", lbl_buf); /* mount the next volume * / /* set the volume indexes as you know them * / vl (fd.vlX).lflX = vl (fd.vlX).cflX + i - 1; if ^next_volume () then do; ecode = error_table_$no_next_volume; return; end; fd.vlX = fd.vlX + 1; vl (fd.vlX).cflX = vl (fd.vlX - 1).lflX; vl (fd.vlX).fflX = vl (fd.vlX - 1).lflX; vl (fd.vlX - 1).cflX = 0; appending: call move (fd.vlX, fd.sequence, ecode); /* find the file now * / if ecode ^= 0 then go to error; else go to move_done; end; end; end; move_done: call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode); if ecode ^= 0 then go to error; call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode); if ecode ^= 0 then go to error; /* NEW */ end; else if vl (vX).cflX > fX then do; /* volume positioned after desired file */ do i = 1 to vl (vX).cflX - fX; call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode); if ecode ^= 0 then go to error; end; call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode); if ecode = 0 then do; call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode); if ecode ^= 0 then go to error; end; else if ecode = error_table_$positioned_on_bot then ecode = 0; else go to error; end; else do; /* volume positioned at desired file */ if fX = 1 then do; call tape_ansi_tape_io_$order (cP, "rew", 0, ecode); if ecode ^= 0 then go to error; end; else do; call tape_ansi_tape_io_$order (cP, "bsf", 0, ecode); if ecode ^= 0 then go to error; call tape_ansi_tape_io_$order (cP, "fsf", 0, ecode); if ecode ^= 0 then go to error; end; end; ok_exit: vl (vX).cflX = fX; /* new position info */ return; error: vl (vX).cflX = 0; /* we don't know where we are */ return; end move; next_volume: procedure returns (bit (1)); /* determines if volume switch possible */ dcl canon_std (2) fixed bin initial (Volume_ansi_tape, Volume_ibm_tape); dcl ecode fixed bin (35); if debug then call debug_print ("next_volume"); if fd.vlX < cseg.vcN then return ("1"b); /* if current vlX < vcN then next exists */ if fd.vlX = 63 then do; /* volume chain full */ call ioa_ ("^a: Implementation limit of 63 volumes has been reached.", cseg.module); return ("0"b); end; if another_volume () then vl (cseg.vcN + 1).comment = com_text; /* yes */ else return ("0"b); /* user said terminate */ got_reelid: cseg.vcN = cseg.vcN + 1; /* increment volume link count */ call vl_init (cseg.vcN); vl (cseg.vcN).volname = vn; /* set volume name in volume link */ call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), vn, vl (cseg.vcN).canonical_volname, canon_std (cseg.standard), ecode); if ecode ^= 0 then return (""b); return ("1"b); end next_volume; vl_init: procedure (n); /* initialize a volume link */ dcl n fixed bin; /* link index */ vl (n).fflX = 0; vl (n).cflX = 0; vl (n).pos = 0; vl (n).lflX = 0; vl (n).tracks = 0; vl (n).density = 0; vl (n).label_type = 0; vl (n).usage_count = 0; vl (n).read_errors = 0; vl (n).write_errors = 0; vl (n).rcp_id = 0; vl (n).event_chan = 0; vl (n).tape_drive = ""; vl (n).write_VOL1 = 0; vl (n).ioi_index = 0; return; end vl_init; another_volume: procedure returns (bit (1)); /* queries user for next volume name */ dcl msg char (80) varying; /* message to user */ dcl msg1 char (length (msg)) based (addr (substr (msg, 1))); /* char (*) overlay for command_query_ */ dcl L1 fixed bin; qi.yes_no = "1"b; /* want yes or no */ qi.suppress_name = "0"b; /* don't suppress module name */ qi.scode = error_table_$no_next_volume; msg = "Reached end of volume. Do you wish to terminate processing of this volume-set?"; call command_query_ (addr (qi), answer, cseg.module, msg1); if answer = "yes" then return ("0"b); /* finito */ qi.yes_no = "0"b; /* don't want yes or no */ qi.suppress_name = "1"b; ask: qi.scode = 0; /* no scode when asking for name */ msg = "Enter volume name of next volume (and optional comment).^/"; ask_raw: call command_query_ (addr (qi), answer, cseg.module, msg1); if answer = "" then go to ask; com_text = ""; /* initialize comment message */ L1 = index (answer, " ") - 1; /* scan for a blank */ if L1 < 0 then L1 = length (answer); call canon_for_volume_label_ (VOLUME_TYPE (TAPE_VOL_VTYPEX), substr (answer, 1, L1), vn, 0, code); if code ^= 0 then do; qi.scode = code; msg = substr (answer, 1, L1) || "^/Enter volume name of next volume (and optional comment).^/"; go to ask_raw; end; answer = ltrim (substr (answer, L1 + 1)); if substr (answer, 1, 8) = "-comment" then do; answer = ltrim (substr (answer, 10)); go to comment; end; if substr (answer, 1, 4) = "-com" then do; answer = ltrim (substr (answer, 6)); comment: if length (answer) = 0 then ; /* no comment */ else com_text = answer; end; else do; /* invalid comment */ call ioa_ ("Comment is invalid."); go to ask; end; return ("1"b); /* volume name is ok - exit */ end another_volume; write_TM: procedure (n, ecode); /* writes 1 or 2 TM and adjusts volume link */ dcl n fixed bin, /* number of TM - 1 or 2 */ cnt fixed bin, ecode fixed bin (35); if debug then call ioa_ ("write_TM ^d", n); do cnt = 1 to n; /* 1 or 2 */ call tape_ansi_tape_io_$order (cP, "eof", 0, ecode); /* write a TM */ if ecode ^= 0 then if ecode ^= error_table_$eov_on_write then return; /* error exit */ vl (fd.vlX).cflX = vl (fd.vlX).cflX + 1; end; return; end write_TM; beginning_of_file: entry (iocbP, code); /* positions to beginning of file */ if debug then call debug_print ("bof"); cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */ cc = 0; on cleanup go to bof_fail; call tape_ansi_ibm_lrec_io_$close (cP, code); /* close logical record I/O */ if code ^= 0 then go to bof_fail; /* OLD */ call move (1, fd.sequence, code); /* move the tape */ /* OLD */ /* NEW * / do i = 1 to cseg.vcN; /* determine where the file begins and have that vol mounted * / if fd.sequence >= vl (i).fflX & fd.sequence <= vl (i).lflX then do; fd.vlX = i; go to got_vol; end; end; /* if not found in loop then it is the current volume * / got_vol: /* if no volume found use the current one * / call move (fd.vlX, fd.sequence, code); /* move the tape * / /* NEW */ if code ^= 0 then do; bof_fail: call consistent; go to close_exit; end; call lrec_open; /* re-initialize to open logical record I/O */ /* note - no error can occur in this call */ return; end_of_file: entry (iocbP, code); /* positions to end of file */ if debug then call debug_print ("end_of_file"); cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to cseg */ cc = 0; on cleanup go to eof_fail; if cseg.lrec.code = error_table_$end_of_info then do; /* passed eof */ call tape_ansi_tape_io_$order (cP, "bsf", 0, code); if code ^= 0 then go to eof_fail; else vl (fd.vlX).cflX = vl (fd.vlX).cflX - 1; return; end; cseg.rlN = -1; /* invalidate any record in real_length buffer */ cseg.blkcnt = -1; /* invalidate the block count */ call tape_ansi_ibm_lrec_io_$close (cP, code); /* close logical record io */ if code ^= 0 then do; eof_fail: call consistent; go to close_exit; end; /* OLD */ if fd.vlX ^= cseg.vcN then do; /* not at last volume of file */ call move (cseg.vcN, 1, code); if code ^= 0 then go to eof_fail; end; call tape_ansi_tape_io_$order (cP, "fsf", 0, code); if code ^= 0 then go to eof_fail; /* OLD */ /* NEW * / do i = 1 to cseg.vcN; /* search forward for the next file * / if vl (i).fflX ^= 0 then /* only searching vols that have files * / if (fd.sequence + 1 >= vl (i).fflX & (fd.sequence + 1 <= vl (i).lflX + 1 | vl (i).lflX = 0)) then do; /* then test for a file fit on the volume * / fd.vlX = i; if vl (i).lflX = 0 | fd.sequence + 1 <= vl (i).lflX then go to got_tape; /* it may be after the last file in the file set * / else do j = i to cseg.vcN; /* look until you find the volume. New files can only be 1+ the last written * / if vl (j).fflX ^= 0 then if (fd.sequence + 1 >= vl (j).fflX & (fd.sequence + 1 <= vl (j).lflX + 1 | vl (j).lflX = 0)) then fd.vlX = j; end; go to got_tape; end; end; /* if we fall through search on from where we are * / got_tape: /* move to the next sequential file then back up to be at end of desired file * / call move (fd.vlX, fd.sequence + 1, code); if code ^= 0 then go to eof_fail; /* NEW */ call tape_ansi_tape_io_$order (cP, "bsf", 0, code); if code ^= 0 then go to eof_fail; /* NEW * / else vl (fd.vlX).cflX = vl (fd.vlX).cflX - 1; call lrec_open; /* re-initialize to open record io * / /* NEW */ return; /* */ data_eof: entry (iocbP, code); /* called by ibm_lrec io when read returns an eof_record */ if debug then call debug_print ("data_eof"); cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get control segment pointer */ cc = 0; /* minimal consistency requirement */ on cleanup go to data_eof_fail; vl (fd.vlX).cflX = vl (fd.vlX).cflX + 1; /* have moved over a TM - update position info */ call tape_ansi_ibm_lrec_io_$close (cP, code); if code ^= 0 then do; data_eof_fail: call consistent; go to close_exit; end; /* OLD */ if fd.vlX = cseg.vcN then do; /* last (or only) section */ /* OLD */ /* NEW * / call tape_ansi_tape_io_$sync_read (cP, nchar, code); /* read the next 80 chars looking for eov label * / if code ^= 0 then do; if code = error_table_$eof_record then do; /* if another eof then this maybe end of vol set * / vl (fd.vlX).cflX = vl (fd.vlX).cflX + 1; call tape_ansi_tape_io_$sync_read (cP, nchar, code); /* read again to see if another eof * / if code = error_table_$eof_record then do; /* if another eof then end of vol set emit end_of_info * / vl (fd.vlX).cflX = vl (fd.vlX).cflX + 1; /* update volume positions * / vl (fd.vlX).lflX = vl (fd.vlX).cflX - 3; code = error_table_$end_of_info; return; end; else if code ^= 0 then go to data_eof_fail; if cseg.standard = 1 then cseg.lbl_buf = sync_buf; else call ebcdic_to_ascii_ (sync_buf, cseg.lbl_buf); /* convert the ebcdic label buffer * / if substr (lbl_buf, 1, 4) ^= "EOV1" then do; /* if not a label then just end of file and go on * / code = error_table_$end_of_info; return; end; end; else go to data_eof_fail; /* if error then go to error handle * / end; else do; /* this is simple end of file case go back * / /* NEW */ code = error_table_$end_of_info; return; end; /* OLD */ call move (fd.vlX + 1, 1, code); /* move to next volume */ /* OLD */ /* NEW * / if debug then call ioa_ ("^80a", lbl_buf); /* this is end of volume prepare to mount the next volume in the set * / if ^next_volume () then do; code = error_table_$no_next_volume; return; end; if vl (fd.vlX).lflX = 0 then vl (fd.vlX).lflX = vl (fd.vlX).cflX - 2; /* check last file index * / else if vl (fd.vlX).lflX ^= vl (fd.vlX).cflX - 2 then do; /* if not set set it right if set check it * / code = error_table_$invalid_file_set_format; go to data_eof_fail; end; vl (fd.vlX).cflX = 0; /* invalidate this volume position * / fd.vlX = fd.vlX + 1; /* increment to next volume * / vl (fd.vlX).cflX = vl (fd.vlX - 1).lflX; /* update volume index info * / vl (fd.vlX).fflX = vl (fd.vlX - 1).lflX; call move (fd.vlX, fd.sequence, code); /* NEW */ if code ^= 0 then go to data_eof_fail; return; data_eot: entry (iocbP, code); /* called by lrec IO when a write encounters EOT */ if debug then call debug_print ("data_eot"); cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get pointer to control segment */ if ^next_volume () then do; /* no next volume available */ code = error_table_$no_next_volume; return; end; cc = 2; /* don't leave defective tape file */ on cleanup go to data_eot_fail; /* OLD */ call write_TM (1, code); /* write end-of-data TM */ /* OLD */ /* NEW * / vl (fd.vlX).lflX = vl (fd.vlX).cflX; /* set the last file index counter * / call write_EOV1 (code); /* call write_EOV to write end of vol trail... two tape marks, an eov label, and a tape mark * / /* NEW */ if code ^= 0 then if code ^= error_table_$eov_on_write then do; /* trouble - ignore EOT) */ data_eot_fail: call consistent; go to close_exit; /* force close */ end; cc = 0; /* OLD */ call move (fd.vlX + 1, 1, code); /* move to beginning of next volume */ /* OLD */ /* NEW * / /* set up for mounting the next volume * / vl (fd.vlX).cflX = 0; /* invalidate this volume position * / fd.vlX = fd.vlX + 1; /* increment to next volume * / vl (fd.vlX).cflX = vl (fd.vlX - 1).lflX; /* update volume indexes * / vl (fd.vlX).fflX = vl (fd.vlX - 1).lflX; call move (fd.vlX, fd.sequence, code); /* NEW */ if code ^= 0 then go to data_eot_fail; return; /* NEW * / write_EOV1: procedure (ecode); dcl ecode fixed bin (35); dcl t4 picture "9999", t6 picture "999999"; /* write the end_of_volume trail 2 tape marks an EOV1 label and then another tape mark * / call write_TM (2, ecode); if ecode ^= 0 then if ecode ^= error_table_$eov_on_write then return; fd.dummy_blkcnt = cseg.blkcnt; /* set up the end of volume label * / fd.eox = 2; /* much of the label is not important * / /* the header and the volume id are distinctive * / if debug then call debug_print ("write_EOV"); ibm_hdr1P = addr (lbl_buf); ibm_hdr1.label_id = "EOV1"; ibm_hdr1.dataset_id = fd.file_id; ibm_hdr1.dataset_serial = fd.set_id; t4 = fd.flX; ibm_hdr1.volume_sequence = t4; t4 = fd.sequence; ibm_hdr1.dataset_sequence = t4; ibm_hdr1.generation = ""; ibm_hdr1.version = ""; ibm_hdr1.creation = " " || fd.creation; ibm_hdr1.expiration = " " || fd.expiration; ibm_hdr1.security = fd.access; t6 = cseg.lrec.blkcnt; ibm_hdr1.blkcnt = t6; ibm_hdr1.system = fd.system; ibm_hdr1.reserved = ""; if cseg.standard = 1 then sync_buf = cseg.lbl_buf; /* ascii buffer for label * / else call ascii_to_ebcdic_ (cseg.lbl_buf, sync_buf); /* ebcidic convert and write * / call tape_ansi_tape_io_$sync_write (cP, 80, ecode); /* write it * / if ecode ^= 0 then if ecode ^= error_table_$eov_on_write then return; call write_TM (1, ecode); /* last tape mark written after label * / return; /* with error ecode = 0 eot or error * / end write_EOV1; /* NEW */ close: entry (iocbP, code); /* iox_$close entry */ cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* get control segment pointer */ if cseg.file_lock then do; /* file in use? */ code = error_table_$file_busy; return; end; else do; on cleanup cseg.file_lock = "0"b; cseg.file_lock = "1"b; end; if cseg.invalid then do; code = error_table_$invalid_cseg; on cleanup go to close_exit1; go to close_exit1; end; if cseg.open_mode = 4 then do; /* input mode */ cc = 0; /* minimal consistency requirement */ on cleanup go to close_fail; call tape_ansi_ibm_lrec_io_$close (cP, code); if code ^= 0 then call consistent; go to close_exit; end; else do; /* output mode */ cc = 2; /* don't leave defective tape file */ on cleanup go to close_fail; call tape_ansi_ibm_lrec_io_$close (cP, code); if code ^= 0 then do; /* maybe trouble */ if code ^= error_table_$eov_on_write then do; /* EOT is ok */ close_fail: call consistent; go to close_exit; end; end; /* OLD */ call write_TM (2, code); /* write trailer and end-of-volume TMs */ /* OLD */ /* NEW * / if cseg.blkcnt = 0 then do; /* if no blocks written empty file * / vl (fd.vlX).lflX = vl (fd.vlX).cflX - 1; /* set the last position and issue error * / code = error_table_$empty_file; end; else vl (fd.vlX).lflX = vl (fd.vlX).cflX; /* update the volume indexes after a write * / call write_TM (3, code); /* write trailer and the 2 end-of-volume TMs * / /* NEW */ if code ^= 0 then do; if code = error_table_$eov_on_write then code = 0; else go to close_fail; end; cc = 0; end; close_exit: if cseg.close_rewind then do; /* rewind volume at close time */ vl (fd.vlX).cflX = 0; /* invalidate volume position */ call tape_ansi_tape_io_$order (cP, "rew", 0, 0);/* issue the order */ cseg.close_rewind = "0"b; /* this is a one time switch */ end; close_exit1: mask = "0"b; revert cleanup; on any_other call handler; call hcs_$set_ips_mask ("0"b, mask); iocbP -> iocb.actual_iocb_ptr -> iocb.detach_iocb = tape_ansi_detach_; iocbP -> iocb.actual_iocb_ptr -> iocb.open = tape_ansi_nl_file_cntl_$open; iocbP -> iocb.actual_iocb_ptr -> iocb.control = tape_ansi_control_; iocbP -> iocb.actual_iocb_ptr -> iocb.open_descrip_ptr = null; call iox_$propagate (iocbP -> iocb.actual_iocb_ptr); call hcs_$reset_ips_mask (mask, mask); cseg.file_lock = "0"b; return; debug_on: entry; /* turns debug switch on */ debug = "1"b; return; debug_off: entry; /* truns debug switch off */ debug = "0"b; return; debug_print: procedure (text); /* prints debug text */ dcl text char (*); call ioa_ (text); return; end debug_print; end tape_ansi_nl_file_cntl_;  tape_ansi_parse_options_.pl1 09/24/86 1501.3rew 09/24/86 1453.0 133758 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-18,GWMay), approve(), audit(), install(): old history comments: Modified 9/79 by R.J.C. Kissel to handle 6250 bpi tapes. Modified 2/82 by Chris Jones to add speed specification Modified 4/82 by J. A. Bush to allow blocksizes > 8192 bytes 2) change(86-08-18,GWMay), approve(86-09-09,MCR7536), audit(86-09-15,Dupuis), install(86-09-24,MR12.0-1162): Changed to accommodate error message lengths > 32 chars. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ tape_ansi_parse_options_: procedure (taoP, options, error, code); /* parameters */ dcl options (*) char (*) varying, /* attachment option array */ error char (*) varying, /* invalid option */ code fixed bin (35); /* error code */ %include tape_attach_options; %include rcp_resource_types; /* based storage */ dcl opt char (nc_opt) based (optP); /* adjustable string for (*) varying -> (*) conversion */ /* automatic storage */ dcl (i, j, k, temp) fixed bin, hyphen_ok bit (1), /* volume name can begin with "-" switch */ clock fixed bin (71), nc_opt fixed bin, /* number of characters in opt string */ optP ptr, /* pointer to 1st char of (*) varying char string */ temp21 fixed bin (21), vn char (32), yy picture "99", ddd picture "999"; /* internal static storage */ dcl 1 key internal static, /* option keywords */ 2 n fixed bin init (23), /* number of keywords */ 2 long (23) char (16) varying init /* long forms */ ("-name", "-number", "-ring", "-extend", "-modify", "-generate", "-create", "-format", "-block", "-record", "-mode", "-expires", "-user_labels", "-density", "-track", "-device", "-retain", "-force", "-replace", "-dos", "-no_labels", "-clear", "-speed"), 2 short (23) char (4) varying init ("-nm", "-nb", "-rg", "-ext", "-mod", "-gen", "-cr", "-fmt", "-bk", "-rec", "-md", "-exp", "-ul", "-den", "-trk", "-dv", "-ret", "-fc", "-rpl", "", "-nlb", "-cl", "-ips"); dcl 1 density internal static, /* -density interpretation */ 2 n fixed bin init (5), /* number of possibilities */ 2 type (5) char (4) varying init /* possibilities */ ("200", "556", "800", "1600", "6250"), 2 code (5) fixed bin init /* interpretation */ (0, 1, 2, 3, 4); dcl 1 mode internal static, /* -mode interpretation */ 2 n fixed bin init (3), /* number of possibilities */ 2 type (3) char (8) varying init /* possibilities */ ("ascii", "ebcdic", "binary"), 2 code (3) fixed bin init /* interpretation */ (1, 2, 3); dcl 1 retain internal static, /* -retain interpretation */ 2 n fixed bin init (4), /* number of possibilities */ 2 type (4) char (8) varying init /* possibilities */ ("none", "device", "volume", "all"), 2 code (4) fixed bin init /* interpretation */ (1, 2, 3, 4); /* builtin functions */ dcl (addr, dimension, fixed, index, length, rtrim, substr) builtin; /* external static */ dcl sys_info$max_seg_size fixed bin (35) external static; /* error codes */ dcl ( error_table_$bad_arg, error_table_$bad_tapeid, error_table_$badopt, error_table_$noarg, error_table_$nodescr, error_table_$inconsistent ) fixed bin (35) ext static; /* external procedures */ dcl convert_date_to_binary_ ext entry (char (*), fixed bin (71), fixed bin (35)), resource_info_$canonicalize_name entry (char (*), char (*), char (*), fixed bin (35)), cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)), datebin_ ext entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin), datebin_$dayr_clk ext entry (fixed bin (71), fixed bin); error = ""; /* initialize error message */ code = 0; /* initialize return code */ tao.noptions = dimension (options, 1); /* get number of array entries */ if tao.noptions = 0 then do; /* there must be at least a reel number */ code = error_table_$noarg; return; end; hyphen_ok = "0"b; /* initialize hyphen switch */ i = 1; /* begin with 1st option */ vol_loop: if options (i) = "-volume" then go to vol_op; /* option is -volume */ if options (i) = "-vol" then do; /* option is -vol */ vol_op: hyphen_ok = "1"b; /* next option may begin with "-" */ if no_next () then return; /* no volume name follows */ end; if substr (options (i), 1, 1) = "-" then do; /* option begins with "-" */ if hyphen_ok then hyphen_ok = "0"b; /* allowed - reset ok switch */ else do; /* not allowed */ if i = 1 then do; /* must be at least 1 volume name */ bad_volname: error = options (i); code = error_table_$bad_tapeid; return; end; go to normal_options; /* this and remainder are control options */ end; end; else hyphen_ok = "0"b; /* in case vol name doesn't begin with "-" */ call resource_info_$canonicalize_name (VOLUME_TYPE (TAPE_VOL_VTYPEX), (options (i)), vn, code); if code ^= 0 then goto bad_volname; options (i) = rtrim (vn); if tao.nvolumes = tao_max_volnames then do; /* too many */ error = "Volume limit of 63 exceeded."; code = error_table_$bad_arg; return; end; tao.nvolumes = tao.nvolumes + 1; /* increment volume count */ tao.volname (tao.nvolumes) = vn; /* save the volume name */ i = i + 1; /* increment to next option */ if i > tao.noptions then return; /* exit when done */ if options (i) = "-comment" then go to com_op; /* options is "-comment" */ if options (i) = "-com" then do; /* option is "-com" */ com_op: if no_next () then return; /* no comment string */ if length (options (i)) > 64 then go to bad2; /* too long */ tao.comment (tao.nvolumes) = options (i); /* save the comment */ i = i + 1; /* increment to next option */ if i > tao.noptions then return; /* done */ end; go to vol_loop; /* continue processing */ normal_options: do while (i <= tao.noptions); /* and continue as long as options remain */ test: do j = 1 to key.n; /* test each keyword */ if options (i) = key.long (j) then go to match (j); /* process when matched */ if options (i) = key.short (j) then go to match (j); /* ditto */ end; error = options (i); code = error_table_$badopt; return; match (1): /* -name */ if no_next () then return; /* no fileid */ if length (options (i)) > 17 then go to bad2; /* bad fileid */ tao.file_id = options (i); go to next; match (2): /* -number */ if no_next () then return; /* no sequence number */ optP = addr (substr (options (i), 1)); nc_opt = length (options (i)); temp = fixed (cv_dec_check_ (opt, code), 17);/* convert to binary */ if code ^= 0 then go to bad2; /* bad fileseq */ if temp < 1 then go to bad2; if temp > 9999 then go to bad2; tao.sequence = temp; /* ok */ go to next; match (3): /* -ring */ tao.write_ring = "1"b; go to next; match (4): /* -extend */ if tao.output_mode ^= 0 then do; /* previous mode */ mult_mode: error = long (j) || " and " || long (output_mode + 3); code = error_table_$inconsistent; return; end; tao.output_mode = 1; tao.write_ring = "1"b; go to next; match (5): /* -modify */ if tao.output_mode ^= 0 then go to mult_mode; tao.output_mode = 2; tao.write_ring = "1"b; go to next; match (6): /* -generate */ if tao.output_mode ^= 0 then go to mult_mode; tao.output_mode = 3; tao.write_ring = "1"b; go to next; match (7): /* -create */ if tao.output_mode ^= 0 then go to mult_mode; tao.output_mode = 4; tao.write_ring = "1"b; go to next; match (8): /* -format */ if no_next () then return; /* no format */ tao.format = options (i); /* save it */ go to next; match (9): /* -block */ if no_next () then return; /* no block length */ optP = addr (substr (options (i), 1)); nc_opt = length (options (i)); temp = fixed (cv_dec_check_ (opt, code), 17); if code ^= 0 then go to bad2; if temp < 18 then go to bad2; tao.blklen = temp; /* ok */ go to next; match (10): /* -record */ if no_next () then return; /* no record length */ optP = addr (substr (options (i), 1)); nc_opt = length (options (i)); temp21 = fixed (cv_dec_check_ (opt, code), 21); if code ^= 0 then go to bad2; if temp21 < 1 then go to bad2; if temp21 > sys_info$max_seg_size * 4 then go to bad2; tao.reclen = temp21; /* ok */ go to next; match (11): /* -mode */ if no_next () then return; /* no recording mode */ do k = 1 to mode.n; /* validate */ if options (i) = mode.type (k) then do; /* match? */ tao.mode = mode.code (k); go to next; end; end; go to bad2; /* no match */ match (12): /* -expires */ if no_next () then return; /* no date */ optP = addr (substr (options (i), 1)); nc_opt = length (options (i)); call convert_date_to_binary_ (opt, clock, code); /* convert date */ if code ^= 0 then go to bad2; call datebin_$dayr_clk (clock, j); /* get day of year */ call datebin_ (clock, 0, 0, 0, k, 0, 0, 0, 0, 0); /* get year */ ddd = j; /* convert to characters */ yy = k - 1900; tao.expiration = yy || ddd; /* form Julian date */ go to next; match (13): /* -user_labels */ if tao.no_labels then do; /* -user_labels and -no_labels */ lbl_error: error = """-no_labels"" and ""-user_labels""."; code = error_table_$inconsistent; return; end; tao.user_labels = "1"b; go to next; match (14): /* -density */ if no_next () then return; /* no density */ do k = 1 to density.n; /* validate */ if options (i) = density.type (k) then do; /* match? */ tao.density = density.code (k); go to next; end; end; go to bad2; /* no match */ match (15): /* -track */ if no_next () then return; /* no track specification */ if options (i) = "7" then tao.ntracks = 7; else if options (i) = "9" then tao.ntracks = 9; else go to bad2; /* bad track */ go to next; match (16): /* -device */ if no_next () then return; /* no number of devices */ optP = addr (substr (options (i), 1)); nc_opt = length (options (i)); temp = fixed (cv_dec_check_ (opt, code), 17);/* convert ndevices */ if code ^= 0 then go to bad2; /* bad ndevices */ if temp < 1 then go to bad2; if temp > 63 then go to bad2; tao.ndrives = temp; /* ok */ go to next; match (17): /* -retain */ if no_next () then return; /* no retention option */ do k = 1 to retain.n; /* test each valid retain */ if options (i) = retain.type (k) then do; /* match */ tao.retain = retain.code (k); go to next; end; end; go to bad2; /* no match */ match (18): /* -force */ tao.force = "1"b; /* set force overwrite bit */ go to next; match (19): /* -replace */ if no_next () then return; /* no file identifier */ if length (options (i)) > 17 then go to bad2; tao.replace_id = options (i); go to next; match (20): /* -dos */ tao.DOS = "1"b; go to next; match (21): /* -no_labels */ if tao.user_labels then go to lbl_error; /* conflict */ tao.no_labels = "1"b; go to next; match (22): tao.clear_cseg = "1"b; /* flag to delete present cseg */ goto next; match (23): begin; dcl COMMA char (1) init (",") static options (constant); dcl current_value char (32) varying; dcl current_idx fixed bin; /* how far we've gotten into value */ if no_next () then return; current_idx = 1; /* start from the beginning of the string */ current_value = get_next_value (); if current_value = "" then goto bad2; /* insist on at least one */ do while (current_value ^= ""); if current_value = "75" then tao.speed = tao.speed | "100"b; else if current_value = "125" then tao.speed = tao.speed | "010"b; else if current_value = "200" then tao.speed = tao.speed | "001"b; else goto bad2; current_value = get_next_value (); end; /* do while ... */ get_next_value: proc returns (char (32) varying); dcl next_value char (32) varying; if current_idx = -1 then return (""); if index (substr (options (i), current_idx), COMMA) = 0 then do; next_value = substr (options (i), current_idx); current_idx = -1; /* so next call will stop */ return (next_value); end; else do; next_value = substr (options (i), current_idx, index (substr (options (i), current_idx), COMMA) - 1); current_idx = current_idx + length (next_value) + 1; return (next_value); end; end get_next_value; end; /* the begin */ goto next; next: i = i + 1; /* get next keyword */ end; return; /* done */ bad2: error = options (i - 1) || " " || options (i); /* form string */ code = error_table_$bad_arg; return; no_next: procedure returns (bit (1)); /* sees if 2nd part of two-part option exists */ if i + 1 > tao.noptions then do; /* does 2nd part exist? */ error = options (i); /* no - get keyword */ code = error_table_$nodescr; return ("1"b); end; else do; /* 2nd part does exist */ i = i + 1; /* increment the option index */ return ("0"b); end; end no_next; end tape_ansi_parse_options_;  tape_ansi_position_.pl1 11/04/82 1931.3rew 11/04/82 1606.1 44136 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ tape_ansi_position_: procedure (iocbP, type, n, code); /* iox_$position entry for tape_ansi_ IO Module */ %include iocb; %include tape_ansi_cseg; /* arguments */ dcl iocbP ptr, /* pointer to iocb */ type fixed bin, /* -1 : position to beginning of file */ /* 0 : position +_ n records (only +n supported) */ /* +1 : position to end of file */ n fixed bin (21), /* number of records : type = 0 */ code fixed bin (35); /* returned error code */ /* automatic */ dcl (i, j) fixed bin (21), /* temporary storage */ tape_error bit (1) aligned; /* parity error switch */ /* external procedures */ dcl tape_ansi_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), tape_ansi_file_cntl_$beginning_of_file ext entry (ptr, fixed bin (35)), tape_ansi_file_cntl_$end_of_file ext entry (ptr, fixed bin (35)), tape_ansi_ibm_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), tape_ansi_nl_file_cntl_$beginning_of_file ext entry (ptr, fixed bin (35)), tape_ansi_nl_file_cntl_$end_of_file ext entry (ptr, fixed bin (35)); /* external static */ dcl (error_table_$bad_arg, error_table_$fatal_error, error_table_$file_busy, error_table_$long_record, error_table_$tape_error, error_table_$invalid_cseg) fixed bin (35) ext static; /* builtin functions */ dcl null builtin; /* conditions */ dcl cleanup condition; cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* set pointer to control segment */ if cseg.invalid then do; code = error_table_$invalid_cseg; return; end; if cseg.file_lock then do; /* is file in use? */ code = error_table_$file_busy; return; end; else do; on cleanup begin; cseg.code = error_table_$fatal_error; cseg.file_lock = "0"b; end; cseg.file_lock = "1"b; end; if type < -1 | type > 1 then do; /* invalid type */ code = error_table_$bad_arg; go to exit; end; else go to action (type); /* perform appropriate positioning operation */ action (-1): /* position to beginning of file */ if cseg.no_labels then call tape_ansi_nl_file_cntl_$beginning_of_file (iocbP, code); else call tape_ansi_file_cntl_$beginning_of_file (iocbP, code); /* move to 1st data record */ if code ^= 0 then cseg.code = code; /* disallow subsequent read ops */ go to exit; action (+1): /* position to end of file */ if cseg.no_labels then call tape_ansi_nl_file_cntl_$end_of_file (iocbP, code); else call tape_ansi_file_cntl_$end_of_file (iocbP, code); /* move to data EOF */ if code ^= 0 then cseg.code = code; /* disallow subsequent read ops */ go to exit; action (0): /* position forward (n > 0) */ code = 0; /* initialize return code */ tape_error = "0"b; /* initialize parity error switch */ if n = 0 then go to exit; /* nothing to do */ if n < 0 then do; /* positioning backwards isn't supported */ code = error_table_$bad_arg; go to exit; end; i = n; /* copy n */ if cseg.rlN ^= -1 then do; /* next record is in read length segment */ cseg.rlN = -1; /* that record has just been position over */ i = i - 1; /* decrement count */ end; do j = 1 to i; /* skip records until done or error or end of file */ cseg.file_lock = "0"b; /* unlock so lrec_io_ call will work */ if cseg.standard = 1 then call tape_ansi_lrec_io_$read_record (iocbP, null, 0, 0, code); else call tape_ansi_ibm_lrec_io_$read_record (iocbP, null, 0, 0, code); if code = error_table_$long_record then code = 0; /* ignore this */ else if code = 0 then; /* rare, only skipping a zero-length record */ else if code = error_table_$tape_error then do; /* ignore for now, but remember */ tape_error = "1"b; /* this does the remembering */ cseg.code = 0; /* this allows further lrec_io_ calls */ end; else go to exit; /* fatal error or EOF - give up */ cseg.file_lock = "1"b; /* relock to avoid unlikely but disasterous situation */ end; if tape_error then do; /* a parity error occurred */ cseg.code = error_table_$tape_error; /* inhibit further I/O */ code = error_table_$tape_error; /* set return code */ end; exit: cseg.file_lock = "0"b; return; end tape_ansi_position_;  tape_ansi_read_length_.pl1 11/04/82 1931.3rew 11/04/82 1606.1 34974 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ tape_ansi_read_length_: procedure (iocbP, reclen, code); /* iox_$read_length entry for tape_ansi_ IO Module */ %include iocb; %include tape_ansi_cseg; /* arguments */ dcl iocbP ptr, /* pointer to iocb */ reclen fixed bin (21), /* returned record length */ code fixed bin (35); /* returned error code */ /* external procedures */ dcl tape_ansi_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), tape_ansi_ibm_lrec_io_$read_record ext entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); /* external static */ dcl sys_info$max_seg_size fixed bin (35) external static; /* error codes */ dcl (error_table_$fatal_error, error_table_$file_busy, error_table_$tape_error, error_table_$invalid_cseg) fixed bin (35) external static; /* internal static */ dcl nc_wanted fixed bin (21) internal static; /* maximum record length */ /* builtin functions */ dcl (null, prec, substr) builtin; /* conditions */ dcl cleanup condition; cP = iocbP -> iocb.actual_iocb_ptr -> iocb.attach_data_ptr; /* set pointer to control segment */ if cseg.invalid then do; /* is control segment invalid? */ code = error_table_$invalid_cseg; return; end; if cseg.file_lock then do; /* is file in use? */ code = error_table_$file_busy; return; end; else do; on cleanup begin; cseg.file_lock = "0"b; cseg.code = error_table_$fatal_error; end; cseg.file_lock = "1"b; end; if cseg.rlP = null then do; /* read length segment not known */ call hcs_$make_seg ("", cseg.module || vl (1).volname || "_.rl", "", 01011b, cseg.rlP, code); if cseg.rlP = null then do; /* shouldn't be - serious trouble */ cseg.code = error_table_$fatal_error; go to exit; end; else do; /* all is well */ nc_wanted = prec (sys_info$max_seg_size * 4, 21); /* compute maximum record length */ go to none; /* nothing in segment - fill it */ end; end; if cseg.rlN = -1 then do; /* get a record if none in read length segment */ none: cseg.file_lock = "0"b; /* unlock so lrec_io_ call will work */ if cseg.standard = 1 then call tape_ansi_lrec_io_$read_record (iocbP, cseg.rlP, nc_wanted, cseg.rlN, code); else call tape_ansi_ibm_lrec_io_$read_record (iocbP, cseg.rlP, nc_wanted, cseg.rlN, code); cseg.file_lock = "1"b; /* avoid conflicts */ if code = 0 | code = error_table_$tape_error then /* record hasn't been read */ cseg.lrec.reccnt = cseg.lrec.reccnt - 1; /* yet by the user */ else do; /* error or event */ reclen = 0; /* return 0 record length */ cseg.rlN = -1; /* insure cseg.rlN -> empty */ go to exit; /* cseg.lrec.reccnt wasn't incremented */ end; end; else code = 0; /* no lrec_io_ call, so 0 error code */ reclen = cseg.rlN; /* return record length; from actual lrec_io_ call... */ /* or, from previous read length operation */ /* note that read_length does _n_o_t change position */ /* so that multiple read_length calls without inter- */ /* vening read_record or position calls all refer to */ /* the same record. */ exit: cseg.file_lock = "0"b; return; end tape_ansi_read_length_;  tape_ansi_tape_io_.pl1 09/24/86 1501.3rew 09/24/86 1453.1 305190 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-18,GWMay), approve(), audit(), install(): old history comments: Modified 9/79 by R.J.C. Kissel to handle 6250 bpi tapes Modified 4/82 by J. A. Bush for block sizes > 8192 Bytes 2) change(86-08-18,GWMay), approve(86-09-09,MCR7536), audit(86-09-17,Dupuis), install(86-09-24,MR12.0-1162): Changed to look up the wait switch for a given drive using the cseg.vl entry. END HISTORY COMMENTS */ /* format: style3,ind3,dclind6,idind32 */ tape_ansi_tape_io_: proc; %include tape_ansi_cseg; dcl (bP, CP) ptr, /* parameters */ ccount fixed bin, /* character count argument */ code fixed bin (35), /* returned error code */ operation char (3); /* order code */ dcl ( error_table_$tape_error, /* error codes returned */ error_table_$nine_mode_parity, error_table_$blank_tape, error_table_$eov_on_write, error_table_$positioned_on_bot, error_table_$eof_record, error_table_$fatal_error, tape_status_$ready_at_bot, /* error codes referenced */ tape_status_$subsystem_ready, tape_status_$device_data_alert, tape_status_$end_of_tape, tape_status_$end_of_file, tape_status_$command_reject, tape_status_$mpc_device_data_alert, tape_status_$blank_tape_on_read, tape_status_$reject_at_bot ) fixed bin (35) ext; dcl (addr, bin, divide, fixed, index, lbound, null, rel) builtin; dcl ecode fixed bin (35) init (0), /* automatic storage */ (synchro, loop_bit, reset_wait) bit (1), /* internal logic switches */ (i, indx, errc) fixed bin; /* temporary storage */ dcl drive_number fixed bin; /* Set by setup. */ dcl ( tmodes (0:1) fixed bin (2) initial (0, 2), /* internal static variables */ oplist (17) bit (6) aligned initial ("47"b3, "46"b3, "54"b3, "45"b3, "44"b3, "00"b3, "40"b3, "70"b3, "72"b3, "55"b3, "62"b3, "63"b3, "64"b3, "61"b3, "60"b3, "65"b3, "41"b3), /* decimal orders */ codechart char (52) initial ("bsf bsr ers fsf fsr rqs rss rew run eof pro per sdn") ) internal static; dcl 1 internal_codes based (addr (oplist)), 2 (bsf, bsr, ers, fsf, fsr, rqs, rss, rew, run, eof, pro, per, s200, s556, s800, s1600, s6250) bit (6) aligned; dcl tdcm_$tdcm_iocall ext entry (ptr, fixed bin (35)), tdcm_$tdcm_set_signal ext entry (ptr, fixed bin (35)), tdcm_$tdcm_reset_signal ext entry (ptr, fixed bin (35)), tape_ansi_interpret_status_ ext entry (ptr), ipc_$block ext entry (ptr, ptr, fixed bin (35)); attach: entry (CP); /* attach entry - initializes tseg */ cP = CP; /* copy pointer to cseg */ cseg.syncP = addr (tseg.buffer (4)); tseg.mode (4) = 2; /* always 9 mode for synchronous (label) buffer */ do i = 1 to 4; /* set tseg buffer pointers */ tseg.bufferptr (i) = fixed (rel (addr (tseg.buffer (i)))); end; cseg.wait_switch (*) = "0"b; /* not waiting for any wakeups */ return; open: entry (CP); /* open entry - initialize buffer management */ cP = CP; free_list = 1; /* initialize buffer indices */ busy_list = 0; chain (1) = 2; /* initialize free chain */ chain (2) = 3; chain (3) = 0; soft_status.nbuf = 0; /* initialize software status */ do i = 1 to 3; /* initialize IO buffer modes */ tseg.mode (i) = tmodes (cseg.mode); end; return; /* This entry can return one of two codes: */ /* */ /* 1) 0 - normal */ /* 2) error_table_$fatal_error - processing cannot continue */ /* Note that EOT on a write synchronize is suppressed. */ synchronize: close: entry (CP, code); /* synchronize entry - synchronize read/write */ call setup; if code ^= 0 then return; tseg.sync = 1; if tseg.write_sw ^= 1 then do; /* check for read synchronization */ if busy_list ^= 0 then do; /* if any buffers */ tseg.command_count = 1; /* must backspace one record */ tseg.buffer_count = 0; /* no buffers involved */ tseg.command_queue (1) = bin (bsr); /* set backspace record code */ retry: call tdcm_$tdcm_iocall (addr (tseg), ecode); /* do backspace */ if ecode ^= 0 then do; /* error calling tdcm */ code = error_table_$fatal_error; return; end; if tseg.completion_status ^= 1 then do; /* something unusual happened */ if tseg.command_count = 1 then go to retry; /* previous read erroneous - retry bsr */ hdw_status.bits = tseg.hardware_status || (36)"0"b; /* pad to 72 bits */ call tape_ansi_interpret_status_ (addr (hdw_status)); /* see what happened */ if hdw_status.major ^= tape_status_$end_of_file then do; /* error if ^ EOF */ code = error_table_$fatal_error; /* set error code */ return; /* exit */ end; end; if free_list ^= 0 then chain (busy_list) = free_list; free_list = busy_list; busy_list = 0; end; return; end; if busy_list = 0 then return; /* write case */ synchro = "1"b; tseg.command_count, tseg.buffer_count = 0; /* set tseg */ indx = busy_list; errc = 10; loop_bit = "0"b; go to synch_write; /* join write code at iocall */ /* This entry returns one of two error codes: */ /* 1) 0 - normal */ /* 2) error_table_$fatal_error */ get_buffer: entry (CP, bP, code); /* get_buffer entry - sets pointer to io_buffer */ cP = CP; /* copy pointer */ bP = null; /* null buffer pointer */ code = 0; /* and zero rc */ findfree: if free_list ^= 0 then do; /* if there is a free bufer hand it to him */ indx = free_list; /* set index to free buffer */ free_list = chain (indx); /* and take it off free chain */ chain (indx) = 0; /* no successor */ bP = addr (tseg.buffer (indx)); /* return address to buffer */ return; end; if busy_list = 0 then do; /* check for all buffers allocated */ code = error_table_$fatal_error; return; end; call synchronize (cP, code); /* synchrionize the tape */ if code ^= 0 then return; /* give up if error */ go to findfree; /* check for buffer again */ /* This entry returns either 0 or error_table_$fatal_error */ release_buffer: entry (CP, bP, code); /* release_buffer entry - returns buffer to free pool */ cP = CP; /* copy pointer */ code = 0; do indx = 1 to 3; /* search for buffer pointer match */ if bP = addr (cseg.buffer (indx)) then go to gotbuf; /* look for match */ end; code = error_table_$fatal_error; /* no match found, return error code */ return; gotbuf: chain (indx) = free_list; /* put onto beginning of free list chain */ free_list = indx; bP = null; /* null out pointer */ return; /* This entry returns one of five error codes: */ /* 1) 0 - normal */ /* 2) error_table_$eof_record - read end of file mark */ /* 3) error_table_$blank_tape - read blank tape, bad volume format */ /* 4) error_table_$tape_error - parity-type tape error */ /* 5) error_table_$fatal_error - cannot continue processing */ /* Note that with tape_error, ccount and bP are valid */ read: entry (CP, bP, ccount, code); /* returns one block */ bP = null; /* initialize in case of error */ ccount = 0; /* ditto */ call setup; /* initialize */ if code ^= 0 then return; /* trouble with rewind wait */ read_ahead: if free_list = 0 then do; /* check for free buffer */ if busy_list ^= 0 then do; /* check for busy buffer */ errc = 25; /* can't read ahead. initialize error retry count */ tseg.command_count, tseg.buffer_count = 0;/* clear (tdcm will just wait) */ go to await_tape; /* call tdcm to wait or tape */ end; /* end of code for locked buffer */ code = error_table_$fatal_error; /* there are just no buffers left */ return; /* so return to the buffer hog with an error */ end; /* end of code for no free buffer */ indx = free_list; /* set index into first free buffer */ free_list = chain (indx); /* reset free list start */ chain (indx) = 0; if busy_list = 0 then busy_list = indx; else chain (busy_list) = indx; tseg.sync = 0; /* read asynchronously */ errc = 25; /* initialize in case of error */ restart_read: tseg.buffer_offset = indx - 1; /* set tseg buffer pointer */ tseg.buffer_count = 1; /* one buffer @ a time */ tseg.command_count = 0; /* indicate reading */ tseg.write_sw = 0; /* "" */ tseg.buffer_size (indx) = divide (cseg.buf_size, 4, 18, 0); await_tape: call tdcm_$tdcm_iocall (addr (tseg), ecode); /* call tdcm to do io */ if ecode ^= 0 then go to r_fatal; /* error in call is fatal */ if tseg.completion_status = 0 then go to read_ahead; /* not complete - read another record while waiting */ else bufct (busy_list) = tseg.buffer_size (busy_list);/* complete - set buffer size */ hdw_status.bits = tseg.hardware_status || (36)"0"b; /* set hardware_status string */ if tseg.completion_status = 1 then do; /* read complete and valid */ hdw_status.major = tape_status_$subsystem_ready;/* return minimal status information */ hdw_status.no_minor = 0; /* to avoid expense of interpretation call */ return_data: bP = addr (cseg.buffer (busy_list)); /* return buffer pointer */ ccount = bufct (busy_list) * 4; /* and buffer count */ busy_list = chain (busy_list); /* unbusy buffer */ return; end; call tape_ansi_interpret_status_ (addr (hdw_status)); /* ERROR or EVENT - see what happened */ if hdw_status.major = tape_status_$end_of_file then do; /* EOF ? */ code = error_table_$eof_record; go to r_exit; end; i = chain (busy_list); /* error - free the last busied buffer */ if i ^= 0 then do; chain (busy_list) = 0; chain (i) = free_list; free_list = i; end; indx = busy_list; if hdw_status.minor (1) = tape_status_$blank_tape_on_read then do; /* give up */ code = error_table_$blank_tape; go to r_exit; end; if hdw_status.major = tape_status_$device_data_alert then go to check_retry; /* may be recoverable */ if hdw_status.major = tape_status_$mpc_device_data_alert then do; /* ditto */ check_retry: if errc = 0 then do; /* retries exhausted? */ if bufct (busy_list) = 0 then go to r_fatal; /* no data at all - not a parity-type error */ code = error_table_$tape_error; /* data returned, albeit erroneously */ go to return_data; end; else do; /* retries not exhausted */ errc = errc - 1; /* decrement retry count */ tseg.command_queue (1) = bin (bsr); /* set backspace record order code */ tseg.command_count = 1; /* one order code to execute */ tseg.buffer_count = 0; /* no buffers to read */ tseg.sync = 1; /* retries are synchronous */ call tdcm_$tdcm_iocall (addr (tseg), ecode); /* call tdcm to backspace tape */ if ecode ^= 0 then go to bsr_error; if tseg.completion_status ^= 1 then do; bsr_error: code = error_table_$fatal_error; go to r_exit; end; go to restart_read; /* restart the read operation */ end; end; r_fatal: code = error_table_$fatal_error; r_exit: if chain (busy_list) = 0 then i = busy_list; /* free the last busied buffer */ else i = chain (busy_list); chain (i) = free_list; free_list = busy_list; busy_list = 0; return; /* This entry can return one of five error codes: */ /* 1) 0 - normal */ /* 2) error_table_$eof_record - read end of file mark */ /* 3) error_table_$blank_tape - read blank tape, bad vol format */ /* 4) error_table_$tape_error - unrecoverable tape error */ /* 5) error_table_$fatal_error - cannot continue processing */ sync_read: entry (CP, ccount, code); /* entry to read 1 block using syncP buffer */ ccount = 0; /* initialize in case of error */ call setup; /* initialize */ if code ^= 0 then return; /* trouble with rewind */ call synchronize (cP, code); /* synchronize IO */ if code ^= 0 then return; tseg.write_sw = 0; /* set write off, we're reading */ i = 1; /* one order code for recovery */ errc = 25; /* set read retry count */ go to sync_com; /* join common erb code */ /* This entry can return one of four error codes: */ /* 1) 0 - normal */ /* 2) error_table_$eov_on_write - EOT detected */ /* 3) error_table_$tape_error - unrecoverable tape error */ /* 4) error_table_$fatal_error - cannot continue processing */ sync_write: entry (CP, ccount, code); /* entry to write a block using syncP buffer */ call setup; /* initialize */ if code ^= 0 then return; /* trouble with rewind */ call synchronize (cP, code); /* synchronize IO */ if code ^= 0 then return; tseg.write_sw = 1; /* set tseg write switch */ i = 2; /* 2 order codes for recovery */ errc = 10; /* set write retry count */ tseg.command_queue (2) = bin (ers); /* set bin (ers) code */ sync_com: tseg.sync = 1; /* synchronous operation */ tseg.command_queue (1) = bin (bsr); /* set backspace record recovery op */ tseg.buffer_offset = 3; /* buffer 4 is the recovery buffer */ sync_restart: if i = 2 then tseg.buffer_size (4) = ccount / 4; /* set count for write */ else tseg.buffer_size (4) = divide (cseg.buf_size, 4, 18, 0); /* read: try to get maximum */ tseg.command_count = 0; /* we are reading or writing */ tseg.buffer_count = 1; /* .... */ call tdcm_$tdcm_iocall (addr (tseg), ecode); /* do io */ if ecode ^= 0 then do; /* error from tdcm */ sync_fatal: code = error_table_$fatal_error; /* set return code */ return; /* exit */ end; hdw_status.bits = tseg.hardware_status || (36)"0"b; /* get and pad hardware status */ call tape_ansi_interpret_status_ (addr (hdw_status)); /* interpret it */ if tseg.completion_status ^= 1 then do; /* something untoward happened */ if hdw_status.major = tape_status_$end_of_file then do; /* EOF detected */ if i = 1 then do; /* on a read */ code = error_table_$eof_record; /* set return code */ go to sync_return; end; else go to sync_error; /* just shouldn't happen when writing */ end; if hdw_status.major = tape_status_$subsystem_ready then do; /* but no major status */ code = error_table_$nine_mode_parity; /* must be invalid 9 mode data */ hdw_status.major = code; hdw_status.no_minor = 0; return; end; if hdw_status.no_minor = 1 then do; /* simple cases */ if hdw_status.minor (1) = tape_status_$end_of_tape then do; /* EOT detected */ if i = 1 then go to sync_error; /* shouldn't happen on read */ code = error_table_$eov_on_write; return; end; if hdw_status.minor (1) = tape_status_$blank_tape_on_read then do; /* trouble */ if i = 2 then go to sync_error; /* shouldn't happen on write */ code = error_table_$blank_tape; return; end; end; if hdw_status.major = tape_status_$device_data_alert then go to sync_repos; /* reposition */ if hdw_status.major = tape_status_$mpc_device_data_alert then do; /* reposition */ sync_repos: tseg.command_count = i; /* set count */ tseg.buffer_count = 0; /* and clear buffer count */ errc = errc - 1; /* decrement retry count */ call tdcm_$tdcm_iocall (addr (tseg), ecode); /* have tdcm reposition */ if ecode ^= 0 then go to sync_fatal; /* call to tdcm failed */ if tseg.completion_status = 2 then do; /* io failed */ hdw_status.bits = tseg.hardware_status || (36)"0"b; /* trouble - get status */ call tape_ansi_interpret_status_ (addr (hdw_status)); /* interpret it */ if hdw_status.no_minor = 1 then do; /* simple case ? */ if hdw_status.minor (1) = tape_status_$end_of_tape then go to sync_test; /* EOT ok */ end; go to sync_error; /* give up */ end; sync_test: if errc >= 0 then go to sync_restart; /* retry if count not exhausted */ end; /* end of recovery loop */ sync_error: code = error_table_$tape_error; /* indicate trouble with tape */ return; /* exit */ end; sync_return: if i = 1 then ccount = 4 * tseg.buffer_size (4); /* return count if read */ return; /* and return to caller */ /* This entry returns one of four error codes: */ /* 1) 0 - normal */ /* 2) error_table_$eov_on_write - EOT detected */ /* 3) error_table_$tape_error - unrecoverable tape error */ /* 4) error_table_$fatal_error - cannot continue processing */ write: entry (CP, bP, ccount, code); /* write entry - stacks one write */ call setup; /* initizlize */ if code ^= 0 then return; /* trouble with rewind */ synchro = "0"b; /* set flag - this is not a synchronize operation */ do indx = 1 to 3; /* find buffer index */ if bP = addr (cseg.buffer (indx)) then go to gotbuf1; end; go to w_fatal; /* invalid buffer */ gotbuf1: bufct (indx) = ccount / 4; /* set count */ if busy_list = 0 then busy_list = indx; else chain (busy_list) = indx; chain (indx) = 0; tseg.buffer_size (indx) = bufct (indx); /* set tseg buffer size */ rstrtw: if ^synchro then tseg.sync = 0; /* write asynchronously if ^synchronize call */ loop_bit = "0"b; /* restart (or start) afresh */ errc = 10; /* initialize in case of error */ rtryw: tseg.write_sw = 1; tseg.buffer_offset = indx - 1; /* set tseg buffer index */ tseg.buffer_count = 1; /* one buffer to deal with */ tseg.command_count = 0; /* no order codes */ synch_write: call tdcm_$tdcm_iocall (addr (tseg), ecode); /* call tseg to write buffer */ if ecode ^= 0 then do; /* call to tdcm failed */ w_fatal: code = error_table_$fatal_error; /* set error code */ return; /* give up */ end; if tseg.completion_status = 1 then do; /* check for write completed */ indx = chain (busy_list); chain (busy_list) = free_list; free_list = busy_list; busy_list = indx; end; else if tseg.completion_status = 0 then ; /* operation not complete */ else do; /* error or event occurred */ hdw_status.bits = tseg.hardware_status || (36)"0"b; /* get hardware status and pad */ call tape_ansi_interpret_status_ (addr (hdw_status)); /* interpret it */ if hdw_status.no_minor = 1 then do; /* simple case? */ if hdw_status.minor (1) = tape_status_$end_of_tape then do; /* report it */ code = error_table_$eov_on_write; /* set error code */ indx = chain (busy_list); /* buffer _w_a_s written: get next in queue */ chain (busy_list) = free_list; /* fill the queue slot */ free_list = busy_list; /* the buffer written is now free */ busy_list = indx; /* buffer pulled from queue is now busy */ if busy_list = 0 then go to synch_check; /* queue was empty - exit */ tseg.sync = 1; /* do this buffer synchronously */ go to synch_write; /* write it */ end; end; if hdw_status.major = tape_status_$subsystem_ready then do; /* but no major status */ code = error_table_$nine_mode_parity; /* must be invalid 9 mode data */ hdw_status.major = code; hdw_status.no_minor = 0; go to w_error1; end; if hdw_status.major = tape_status_$device_data_alert then go to reposit; /* reposition */ if hdw_status.major = tape_status_$mpc_device_data_alert then do; /* reposition */ reposit: tseg.sync = 1; /* retries synchronous */ loop_bit = "1"b; /* indicate retrying */ errc = errc - 1; /* decrement error retry count */ tseg.command_queue (1) = bin (bsr); /* set backspace code */ tseg.command_queue (2) = bin (ers); /* and erase code */ tseg.command_count = 2; /* 2 commands to execute */ indx = busy_list; /* retry first write */ tseg.buffer_count = 0; /* reset buffer count */ call tdcm_$tdcm_iocall (addr (tseg), ecode); /* call tdcm to backspace and erase */ if ecode ^= 0 then go to w_fatal; /* tdcm call failed - give up */ if tseg.completion_status = 2 then do; /* error occurred */ hdw_status.bits = tseg.hardware_status || (36)"0"b; /* trouble - get status */ call tape_ansi_interpret_status_ (addr (hdw_status)); /* interpret it */ if hdw_status.no_minor = 1 then do; /* simple case? */ if hdw_status.minor (1) = tape_status_$end_of_tape then go to w_test; /* EOT is reasonable */ end; go to w_error; /* anything else is error */ end; w_test: if errc >= 0 then go to rtryw; /* retry write if error count not exhausted */ end; w_error: code = error_table_$tape_error; w_error1: indx = busy_list; /* report _a_l_l queued buffers */ w_report: soft_status.nbuf = 0; /* set suspended count */ do while (indx ^= 0); /* set up suspended buffer list */ soft_status.nbuf = soft_status.nbuf + 1; soft_status.bufP (nbuf) = addr (tseg.buffer (indx)); soft_status.count (nbuf) = bufct (indx) * 4; /* set buffer count */ indx = chain (indx); /* and go to next buffer */ end; /* end of code for setting up list of suspended buffers */ busy_list = 0; go to synch_check; /* return to caller */ end; if loop_bit then if busy_list ^= 0 then do; /* see if more buffers (first in error) */ indx = busy_list; /* index to suspended buffer */ go to rstrtw; /* restart write */ end; /* end of buffer error loop code */ synch_check: if ^synchro then bP = null; /* write entry: null buffer pointer */ else do; /* synchronize/close entry */ if code = error_table_$eov_on_write then code = 0; /* ignore EOT */ else if code = error_table_$tape_error then code = error_table_$fatal_error; /* treat as fatal */ end; return; /* return to caller */ /* The following codes may be returned: */ /* 1) 0 - all orders */ /* 2) error_table_$fatal_error - all orders */ /* 3) error_table_$positioned_on_bot - bsf, bsr */ /* 4) error_table_$eov_on_write - ers, eof */ /* 5) error_table_$eof_record - fsr, bsr */ /* 6) error_table_$tape_error - all orders */ order: entry (CP, operation, ccount, code); /* order entry - performs synchronous order calls */ call setup; /* initialize */ if code ^= 0 then return; /* trouble with rewind */ call synchronize (cP, code); /* synchronize */ if code ^= 0 then return; /* trouble with synch */ errc = 10; /* set error retry count */ tseg.sync = 1; /* synchronous for order codes */ tseg.buffer_count = 0; /* indicate order code to tdcm */ i = index (codechart, operation); /* pick up index for order code */ if i = 0 then do; /* illegal operation */ code = error_table_$fatal_error; return; end; else if i = 49 then i = 13 + ccount; /* set density index */ else i = i / 4 + 1; if i = 8 then do; /* rewind */ call tdcm_$tdcm_set_signal (addr (tseg), code); /* set signal */ if code ^= 0 then go to er_fatal; /* troubles */ cseg.wait_switch (drive_number) = "1"b; /* set switch for rewind wait */ end; rtryo: tseg.command_queue (1) = bin (oplist (i)); /* set operation code */ tseg.command_count = 1; /* only one order code */ reset_wait = "0"b; /* tdcm signal not to be reset */ call tdcm_$tdcm_iocall (addr (tseg), code); /* have tdcm do my thing */ if code ^= 0 then do; /* did tdcm call fail? */ er_fatal: reset_wait = "1"b; /* reset tdcm signal if set */ code = error_table_$fatal_error; /* tdcm failure is fatal */ go to wait_test; /* check tdcm signal */ end; hdw_status.bits = tseg.hardware_status || (36)"0"b; /* pad hardware status to 72 bits */ call tape_ansi_interpret_status_ (addr (hdw_status)); /* generate error code structure from hdw status */ if i = 6 then return; /* request status - exit because any result is ok */ if i = 7 then return; /* reset status - ditto */ if tseg.completion_status = 1 then do; /* implies Subsystem Ready major status */ if i = 4 then go to er_notry; /* forward file didn't get EOF: error */ if i < 3 then do; /* bsf, bsr - are they at BOT? */ if check (tape_status_$ready_at_bot) then do; /* minor status shows tape at BOT */ code = error_table_$positioned_on_bot; /* not an error */ return; end; else do; /* not at BOT */ if i = 1 then code = error_table_$fatal_error; /* bad if bsf */ return; end; end; go to wait_test; /* ok: check tdcm signal */ end; if hdw_status.major = tape_status_$end_of_file then do; /* End of File major status */ go to eof (i); /* perform appropriate action */ eof (1): eof (4): return; /* bsf/fsf - normal */ eof (2): eof (5): code = error_table_$eof_record; /* bsr/fsr - an event, not an error */ return; /* exit */ eof (3): eof (10): /* ers/eof - error, no retry */ eof (8): eof (9): eof (11): go to er_notry; /* rew/run/sdn - error, give up */ end; if hdw_status.major = tape_status_$device_data_alert then do; /* Device Data Alert major status */ if hdw_status.no_minor = 1 then do; /* simple case ? */ if hdw_status.minor (1) = tape_status_$end_of_tape then do; /* EOT? */ code = error_table_$eov_on_write; return; end; end; if i = 3 then do; /* multiple errors - erase case */ tseg.command_queue (2) = bin (fsr); /* recovery will forward space after backspace */ go to er_retry; /* retry with positioning */ end; if i = 10 then do; /* write eof case */ tseg.command_queue (2) = bin (ers); /* set recovery code to erase bad tape mark */ go to er_retry; /* retry with positioning */ end; go to er_notry; /* give up */ end; if hdw_status.major = tape_status_$mpc_device_data_alert then do; /* MPC Device Data Alert major status */ if i = 10 then do; /* write eof case */ tseg.command_queue (2) = bin (ers); /* erase the bad tape mark */ go to er_retry; /* retry it */ end; go to er_notry; /* give up on any other order */ end; if hdw_status.major = tape_status_$command_reject then do; /* Command Reject major status */ if i < 3 then do; /* bsf or bsr cases */ if check (tape_status_$reject_at_bot) then do; /* was tape at BOT? */ code = error_table_$positioned_on_bot; /* set return code */ return; /* exit */ end; end; /* other bsf/bsr cases fall through */ end; /* other orders fall through */ /* Device Busy major status */ /* MPC Device Attention major status */ /* MPC Command Reject major status */ /* Device Attention major status */ er_notry: reset_wait = "1"b; /* reset tdcm signal if set */ code = error_table_$tape_error; wait_test: if cseg.wait_switch (drive_number) then if reset_wait then do; /* rewind at bot or error */ call tdcm_$tdcm_reset_signal (addr (tseg), 0); cseg.wait_switch (drive_number) = "0"b; end; return; /* return to caller */ er_retry: if errc > 0 then do; /* has retry count been exhausted? */ tseg.command_queue (1) = bin (bsr); /* set tdcm to backspace 1 record */ tseg.command_count = 2; /* error code has set tseg.command_queue (2) */ call tdcm_$tdcm_iocall (addr (tseg), code); /* do io */ if code ^= 0 then go to er_fatal; /* tdcm failed - give up */ if tseg.completion_status = 1 then go to rtryo; /* io was uneventful - retry order */ hdw_status.bits = tseg.hardware_status || (36)"0"b; /* trouble - get status */ call tape_ansi_interpret_status_ (addr (hdw_status)); /* interpret it */ if hdw_status.major = tape_status_$end_of_file then go to rtryo; /* well, EOF is reasonable */ if hdw_status.no_minor = 1 then do; /* simple case? */ if hdw_status.minor (1) = tape_status_$end_of_tape then go to rtryo; /* so is EOT */ end; end; go to er_notry; /* exhausted or non-reasonable */ setup: proc; /* internal proc for call initialization */ dcl 1 wait_list, /* parameter lists for block */ 2 n fixed bin, 2 chn fixed bin (71); dcl 1 message, 2 channel fixed bin (71), 2 mess fixed bin (71), 2 sender bit (36), 2 origin, 3 dev_sig bit (18) unal, 3 ring bit (18) unal, 2 channel_index fixed bin; cP = CP; /* copy pointer */ code = 0; /* zero out rc */ do drive_number = lbound(cseg.vl, 1) to cseg.vcN while (cseg.vl(drive_number).tape_drive ^= tseg.drive_name); end; if drive_number > cseg.vcN then do; code = error_table_$fatal_error; return; end; if cseg.wait_switch (drive_number) then do; /* see if tape rewinding */ cseg.wait_switch (drive_number) = "0"b; /* clear switch */ wait: wait_list.n = 1; /* initialize arg for block */ wait_list.chn = tseg.ev_chan; call ipc_$block (addr (wait_list), addr (message), code); /* go blocked waiting for tape rewind */ if code ^= 0 then code = error_table_$fatal_error; call tdcm_$tdcm_reset_signal (addr (tseg), 0); /* reset */ end; /* end of code for rewind wait */ return; /* return to main line */ end; /* end of procedure setup */ check: procedure (min_code) returns (bit (1)); /* internal proc for status checking */ dcl min_code fixed bin (35), /* minor status code to be checked */ ix fixed bin; /* index into minor status code array */ do ix = 1 to hdw_status.no_minor; /* check each element */ if min_code = hdw_status.minor (ix) then return ("1"b); /* got it */ end; return ("0"b); /* not there */ end check; end tape_ansi_tape_io_;  tape_status_.alm 11/05/86 1318.2r w 11/04/86 1038.1 52623 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** """""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" " " N__a_m_e: tape_status_ " " An error table segment defining a unique status code for " each possible major and sub-status generated by the MTS500 " Magnetic Tape Subsystem. " " 0) Created: Oct. 21, 1974 by Ross E. Klinger " " 1) Modified: March 5, 1976 by R. E. Klinger to add a new " Command Reject substatus, Invalid Density. " " 2) Converted to ALM January 1980 by C. Hornig. " " """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""" include et_macros et tape_status_ ec command_reject,MTS010,(Command Reject.) ec invalid_density,MTS015,(Command Reject - Invalid Density.) ec invalid_opcode,MTS020,(Command Reject - Invalid Op Code.) ec invalid_device_code,MTS030,(Command Reject - Invalid Device Code.) ec invalid_idcw_parity,MTS040,(Command Reject - Invalid IDCW Parity.) ec reject_at_bot,MTS050,(Command Reject - Positioned at BOT.) ec read_after_write,MTS060,Command Reject - Forward Read After Write.; ec nine_track_error,MTS070,(Command Reject - 9-Track Error.) ec mpc_command_reject,MTS080,(MPC Command Reject.) ec illegal_procedure,MTS090,(MPC Command Reject - Illegal Procedure.) ec illegal_lc_number,MTS100,(MPC Command Reject - Illegal LC Number.) ec illegal_susp_lc_number,MTS110,(MPC Command Reject - Illegal Suspended LC Number.) ec continue_not_set,MTS120,(MPC Command Reject - Continue Bit Not Set.) ec end_of_file,MTS130,(End of File.) ec seven_track_eof,MTS140,(End of File - End of File Mark (7-Track).) ec nine_track_eof,MTS150,(End of File - End of File Mark (9-track).) ec data_alert,MTS160,(End of File - Data Alert Condition.) ec single_char_record,MTS170,(End of File - Single Character Record.) ec device_data_alert,MTS180,(Device Data Alert.) ec transfer_timing,MTS190,(Device Data Alert - Transfer Timing Alert.) ec blank_tape_on_read,MTS200,(Device Data Alert - Blank Tape on Read.) ec bit_during_erase,MTS210,(Device Data Alert - Bit Detected During Erase Operation.) ec transmission_parity,MTS220,(Device Data Alert - Transmission Parity Alert.) ec lateral_parity,MTS230,(Device Data Alert - Lateral Tape Parity Alert.) ec longitudinal_parity,MTS240,(Device Data Alert - Longitudinal Tape Parity Alert.) ec end_of_tape,MTS250,(Device Data Alert - End of Tape Mark.) ec mpc_device_data_alert,MTS260,(MPC Device Data Alert.) ec transmission_alert,MTS270,(MPC Device Data Alert - Transmission Alert.) ec inconsistent_command,MTS280,(MPC Device Data Alert - Inconsistent Command.) ec sum_check_error,MTS290,(MPC Device Data Alert - Sum Check Error.) ec byte_locked_out,MTS300,(MPC Device Data Alert - Byte Locked Out.) ec pe_burst_error,MTS310,(MPC Device Data Alert - PE-Burst Write Error.) ec preamble_error,MTS320,(MPC Device Data Alert - Preamble Error.) ec marginal_condition,MTS330,(MPC Device Data Alert - Marginal Condition.) ec multitrack_error,MTS340,(MPC Device Data Alert - Multitrack Error.) ec skew_error,MTS350,(MPC Device Data Alert - Skew Error.) ec postamble_error,MTS360,(MPC Device Data Alert - Postamble Error.) ec nrzi_ccc_error,MTS370,(MPC Device Data Alert - NRZI CCC Error.) ec code_alert,MTS380,(MPC Device Data Alert - Code Alert.) ec device_attention,MTS390,(Device Attention.) ec write_protect_attention,MTS400,(Device Attention - Write Protected.) ec no_such_device,MTS410,(Device Attention - No Such Device.) ec device_in_standby,MTS420,(Device Attention - Device in Standby.) ec device_check,MTS430,(Device Attention - Device Check.) ec blank_tape_on_write,MTS440,(Device Attention - Blank Tape on Write.) ec mpc_device_attention,MTS450,(MPC Device Attention.) ec configuration_error,MTS460,(MPC Device Attention - Configuration Switch Error.) ec multiple_devices,MTS470,(MPC Device Attention - Multiple Devices.) ec illegal_device_id,MTS480,(MPC Device Attention - Illegal Device ID Number.) ec incompatible_mode,MTS490,(MPC Device Attention - Incompatible Mode.) ec tca_malfunction_port0,MTS500,(MPC Device Attention - TCA Malfunction Port 0.) ec tca_malfunction_port1,MTS510,(MPC Device Attention - TCA Malfunction Port 1.) ec tca_malfunction_port2,MTS520,(MPC Device Attention - TCA Malfunction Port 2.) ec tca_malfunction_port3,MTS530,(MPC Device Attention - TCA Malfunction Port 3.) ec mth_malfunction,MTS540,(MPC Device Attention - MTH Malfunction.) ec multiple_bot,MTS550,(MPC Device Attention - Multiple BOT.) ec device_busy,MTS560,(Device Busy.) ec in_rewind,MTS570,(Device Busy - In Rewind.) ec device_reserved,MTS580,(Device Busy - Device Reserved.) ec alternate_channel,MTS590,(Device Busy - Alternate Channel in Control.) ec device_loading,MTS600,(Device Busy - Device Loading.) ec subsystem_ready,MTS610,(Peripheral Subsystem Ready.) ec device_ready,MTS620,(Peripheral Subsystem Ready - Device Ready.) ec write_protected,MTS630,(Peripheral Subsystem Ready - Write Protected) ec ready_at_bot,MTS640,(Peripheral Subsystem Ready - Positioned at BOT) ec nine_track_handler,MTS650,(Peripheral Subsystem Ready - 9-Track Handler.) ec two_bit_fill,MTS660,(Peripheral Subsystem Ready - 2-Bit Fill.) ec four_bit_fill,MTS670,(Peripheral Subsystem Ready - 4-Bit Fill.) ec six_bit_fill,MTS680,(Peripheral Subsystem Ready - 6-Bit Fill.) ec ascii_alert,MTS690,(Peripheral Subsystem Ready - ASCII Alert.) end  tdcm_.pl1 11/30/82 1535.6rew 11/30/82 1207.1 385290 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ tdcm_: procedure; /* This is the non-ring 0 version of the tape DCM. * Recoded from ring 0 version by Bill Silver on 09/30/74. * Modified for preloaded volumes by Michael R. Jordan on 04/28/78. * Modified 7/79 by R.J.C. Kissel to user version 1 tseg. * Modified 03/82 by Chris Jones for version 2 tseg. * Modified 3/82 by J. A. Bush for Marker interrupt processing * Modified 7/13/82 by J. A. Bush to fix some interrupt processing bugs * * This version of this program is part of the initial "dummy" * installation of RCP. * * tdcm_ interfaces with RCP in order to perform device management * functions. It interfaces with IOI in order to perform the * actual tape I/O. Notes about this procedure: * 1. In general all entry points function in the same way. * 2. The caller of tdcm_ must be aware that the first tseg buffer * and tseg.drive_number are not valid between the call to * tdcm_$tdcm_attach and the first call to tdcm_$tdcm_message. * 3. tdcm_$tdcm_message must be called after the call to tdcm_attach or * after a call to tdcm_$tdcm_detach in which the drive assignment has * been retained. Subsequent calls to tdcm_$tdcm_message will temporarily * still type a mount message on the operator's console. * 4. I/O modules no longer need to check that the tape drive is ready or * that the volume is at BOT or that the write ring is set correctly. * RCP does all of this checking. * 5. tdcm_$tdcm_priv_attach is no longer supported. RCP checks to see * if a process is privileged. * 6. tdcm_$tdcm_mount_bit_set and tdcm_$tdcm_mount_bit_get are no * longer supported. * 7. A new entry point, tdcm_set_disposition, is available. * It allows the user to specify a disposition value to be given * to RCP when the tape drive is detached. * 8. Two new entry points are now available: tdcm_set_buf_size and * tdcm_get_buf_size; They allow the caller to adjust the size of * the tdcm_ I/O buffer. */ /* ARGUMENT DATA */ dcl arg_buf_size fixed bin; /* (I/O) Size of tdcm_ I/O buffer. */ dcl arg_call_data_ptr ptr; /* (I) Pointer to event call data structure. */ dcl arg_disposition bit (*); /* (I) Disposition value given to RCP. */ dcl arg_ecode fixed bin (35); /* (O) Standard error_table_ code. */ dcl arg_reel_name char (*); /* (I) Tape reel ID name plus qualifiers. */ dcl arg_tsegp ptr; /* (I) Pointer to user's tseg. */ dcl arg_val_level fixed bin; /* (I) Validation level to be set. */ dcl arg_write_sw fixed bin (1); /* (I) 1 => write, 0 => read. */ /* AUTOMATIC DATA */ dcl 1 event_data like call_data; /* Not really used. */ dcl call_data_ptr ptr; /* Pointer to event call data structure. */ dcl wbuf_ptr ptr; /* Pointer to buffer in IOIworkspace. */ dcl buf_size fixed bin; /* Used to copy buffer size argument. */ dcl data_size fixed bin; /* Number of words to be moved by based_data. */ dcl dcw_tally fixed bin (18); /* Number of words to be move by single DCW. */ dcl ecode fixed bin (35); /* Temporary error code. */ dcl fix fixed bin; /* Used to correct read count. */ dcl tmr bit (1) aligned; dcl ck_level fixed bin (3); /* interrupt level returned by CK_STATQ */ dcl (i, sqx) fixed bin; dcl listx fixed bin; /* Index to last IDCW that was executed. */ dcl new_val_level fixed bin; /* Used to copy validation level argument. */ dcl op_count fixed bin; /* Number of commands or buffers in I/O. */ dcl (tbuf_num, wbuf_num) fixed bin; /* Number of tseg buffer. */ dcl tot_data_size fixed bin; /* Tot num of words written with 1 connect. */ dcl special_flag bit (1) aligned; /* ON => we have special status. */ dcl special_status_word bit (36) aligned; /* Status word for special interrupts. */ dcl data_idcw bit (36) aligned; /* to copy current data xfer idcw into */ dcl (io_time, delta) fixed bin (71); dcl (pfs, pf_code) fixed bin (35); /* BASED DATA */ dcl based_data (data_size) fixed bin (35) aligned based; /* Used to move data. */ dcl based_idcw bit (36) aligned based (idcwp); dcl 1 call_data based (call_data_ptr) aligned, /* Data structure for event calls. */ 2 channel_id fixed bin (71), 2 message fixed bin (71), 2 sender bit (36), 2 orgin, ( 3 dev_signal bit (18), 3 ring bit (18) ) unaligned, 2 data_ptr ptr; /* Points to IOIworkspace. */ /* EXTERNAL ENTRIES CALLED */ dcl (addr, addrel, baseptr, bin, bit, clock, divide, hbound, min, ptr, rel, string, substr) builtin; dcl ( error_table_$bad_arg, error_table_$buffer_big, error_table_$invalid_state, error_table_$out_of_main_memory, error_table_$unimplemented_version, error_table_$net_timeout, error_table_$too_many_buffers ) fixed bin (35) external; dcl display_meters bit (1) aligned static options (constant) init ("0"b); /* if meters are to be displayed at detach time, set to ("1"b) */ dcl convert_ipc_code_ entry (fixed bin (35)); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)); dcl ioi_$connect entry (fixed bin, fixed bin, fixed bin (35)); dcl ioi_$set_event entry (fixed bin, fixed bin (71), fixed bin (35)); dcl ioi_$get_special_status entry (fixed bin, bit (1) aligned, bit (36) aligned, fixed bin (35)); dcl ipc_$drain_chn entry (fixed bin (71), fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl rcp_$promote entry (bit (36) aligned, fixed bin, fixed bin (35)); dcl tdcm_$tdcm_reset_signal entry (ptr, fixed bin (35)); dcl tdcm_attach_ entry (ptr, fixed bin (35)); dcl tdcm_detach_ entry (ptr, fixed bin (35)); dcl tdcm_message_ entry (ptr, ptr, char (*), fixed bin (1), fixed bin (35)); dcl mhcs_$get_seg_usage_ptr entry (ptr, fixed bin (35), fixed bin (35)); dcl ioa_ entry options (variable); %page; %include tseg; %page; %include tdcm_info; %page; %include ioi_stat; %page; %include iom_stat; %page; %include iom_pcw; %include iom_dcw; %page; tdcm_attach: entry (arg_tsegp, arg_ecode); /* The following entry points will be implemented as external procedures. * This is done in order to reduce the size of tdcm_.pl1. */ call tdcm_attach_ (arg_tsegp, arg_ecode); return; tdcm_message: entry (arg_tsegp, arg_reel_name, arg_write_sw, arg_ecode); call SETUP; /* Initialize and validate. */ ws.info.subset_size = divide (hbound (ws.rw_list, 1), 2, 17, 0); /* set up max subset size */ call tdcm_message_ (tsegp, ws_ptr, arg_reel_name, arg_write_sw, arg_ecode); return; tdcm_detach: entry (arg_tsegp, arg_ecode); call SETUP; /* Initialize and validate. */ if ws.info.flags.good_ws then do; call REWIND_TAPE; /* TERMPORARY for DUMMY RCP. */ call tdcm_$tdcm_reset_signal (tsegp, ecode); /* set up to ignore special interrupt */ if display_meters then do; /* this will normally be shut off */ call mhcs_$get_seg_usage_ptr (tsegp, pfs, pf_code); call ioa_ ("^/Total number of data xfer I/O calls:^2-^d", ws.number_ios + 1); call ioa_ ("Highest number of blocks/data xfer I/O call:^-^d", ws.info.block_count); call ioa_ ("Average Time between data xfer I/O calls:^-^.3f MS", float (ws.io_delta / ws.number_ios) / 1000); call ioa_ ("Longest time between data xfer I/O calls:^-^.3f MS", float (ws.high_delta) / 1000); call ioa_ ("Shortest time between data xfer I/O calls:^-^.3f MS", float (ws.low_delta) / 1000); call ioa_ ("Number of calls to ipc_$block:^2-^d", ws.info.block); call ioa_ ("Times status queue processed w/o going blocked:^-^d", ws.info.no_block); call ioa_ ("Total number of terminate interrupts:^2-^d", ws.info.term_st); call ioa_ ("Number of terminate interrupts without errors:^-^d", ws.info.term_ne); call ioa_ ("Total number of marker interrupts:^2-^d", ws.info.mark_st); call ioa_ ("Most consecutive number of marker interrupts:^-^d", ws.most_consec_mark); call ioa_ ("Number of page faults taken on tseg:^2-^d", pfs); call mhcs_$get_seg_usage_ptr (ws_ptr, pfs, pf_code); call ioa_ ("Number of page faults taken on workspace:^-^d^/", pfs); end; end; call tdcm_detach_ (ws_ptr, arg_ecode); return; %page; tdcm_set_signal: entry (arg_tsegp, arg_ecode); /* This entry point is called whenever the caller wants to be waked * up when a special interrupt is received from the tape drive. * Until this entry is called all special interrupts will be ignored. * In order to implement this feature we must change the event * channel that IOIis using to communicate with us. We will * use an event call channel instead of the fast event channel. * This means that when IOI sends a wakeup we will enter the call * handler tdcm_$special_handler rather than being waked up in * WAIT_FOR_STATUS. If the tape drive is not yet attached we will save * the ID of the event channel we want to use. It will be set up with * IOIafter the attachment is made. */ call SETUP; /* Initialize and validate. */ if ws.info.flags.attached /* If attached switch, else save. */ then call ioi_$set_event (ws.info.ioix, ws.info.special_echan, ecode); else ws.info.init_echan = ws.info.special_echan; arg_ecode = ecode; return; tdcm_reset_signal: entry (arg_tsegp, arg_ecode); /* This entry point is called when the caller is no longer * interrested in special interrupts. We will swap back the * the event channels that we changed in tdcm_set_signal. * We will use the fast event channel again. */ call SETUP; /* Initialize and validate. */ if ws.info.flags.attached /* If attached switch back, else save. */ then call ioi_$set_event (ws.info.ioix, ws.info.fast_echan, ecode); else ws.info.init_echan = ws.info.fast_echan; arg_ecode = ecode; return; %page; tdcm_promote: entry (arg_tsegp, arg_val_level, arg_ecode); /* This entry point is called to promote the validation level of the * specified tape drive. The validation level will already be set * to the caller's validation level. If this entry point is called * before this drive is attached we will get an error from IOI. */ call SETUP; /* Initialize and validate. */ new_val_level = arg_val_level; /* Copy validation level caller wants to set. */ call rcp_$promote (ws.info.rcp_id, new_val_level, ecode); arg_ecode = ecode; return; tdcm_set_disposition: entry (arg_tsegp, arg_disposition, arg_ecode); /* This entry is called to specify a disposition to be passed to RCP * when this drive is detached. If this entry point is called * before this drive is attached we will return an error. */ call SETUP; if ^ws.info.flags.attached /* Make sure tape drive is attached. */ then do; /* Not attached, return error. */ arg_ecode = error_table_$invalid_state; return; end; ws.info.disposition = arg_disposition; /* Save caller's disposition. */ arg_ecode = ecode; return; %page; tdcm_set_buf_size: entry (arg_tsegp, arg_buf_size, arg_ecode); /* This entry point is called to set the size of the tdcm_ I/O buffer. * The default tdcm_ I/O buffer size is 2080 words. The actual buffer size * used is also a function of the maximum workspace size available from IOI. * This entry point must be called before the first call to tdcm_$tdcm_message. */ call SETUP; buf_size = arg_buf_size; /* Copy argument. */ if ws.info.flags.attached then do; /* Is tape drive already attached? */ arg_ecode = error_table_$invalid_state; /* Yes, buffer size already established. */ return; end; if buf_size < 1 then do; /* Is buffer size too small? */ arg_ecode = error_table_$bad_arg; /* Yes, don't change the buffer size. */ return; end; if buf_size = 1040 * 6 then do; /* tape_mult_ with "-sys" option? */ ws.info.flags.allow_marker = "1"b; /* yes, do marker interrupt processing */ buf_size = hbound (ws.rw_list, 1) * 1040; /* set wks to mak size allowed */ end; ws.info.buf_size = buf_size; /* Set buffer size. */ arg_ecode = 0; return; tdcm_get_buf_size: entry (tsegp, arg_buf_size, arg_ecode); call SETUP; if ^ws.info.flags.attached then do; /* Is tape drive attached? */ arg_buf_size = 0; /* No, buffer size value not valid yet. */ arg_ecode = error_table_$invalid_state; return; end; if ws.info.flags.allow_marker then /* if we phonied up buffer size.. */ arg_buf_size = ws.info.subset_size * 1040; /* don't tell user */ else arg_buf_size = ws.info.buf_size; /* Return actual buffer size. */ arg_ecode = 0; return; %page; tdcm_iocall: entry (arg_tsegp, arg_ecode); /* This entry point is called to perform actual I/O operations on the * specified tape drive. There are two main types of I/O operations * performed: non-data transfer commands, and reads or writes. * If this entry point is called before the tape drive is attached * we will get an error from IOI. */ call SETUP; /* Initialize and verify. */ tseg.completion_status = 0; /* Initialize to imply no status. */ IOCALL_LOOP: /* Check status and perform I/O. */ if ws.info.flags.connected then /* Are _w_e currently performing I/O? */ if ^ws.info.flags.allow_marker then /* and not doing marker processing? */ call CHECK_STATUS; /* Yes, wait for it to complete. */ else if tseg.command_count > 0 | /* allowing markers, but non-data xfer or */ tseg.command_count + tseg.buffer_count <= 0 then /* if no I/O to perform */ call CHECK_STATUS; /* then wait for terminate status */ if tseg.command_count + tseg.buffer_count <= 0 then goto IOCALL_RETURN; /* No I/O to perform. */ /* Write switch in tseg => error type. */ if tseg.command_count > 0 then /* Are there any non-data transfer commands? */ call NON_DATA_TRANSFER; /* Yes, do them first. */ else if ws.info.flags.allow_marker then /* if doing marker interrupt processing... */ call MARKER_READ_WRITE; /* go to that routine */ else call READ_WRITE; /* No, caller must want to read or write. */ if tseg.sync ^= 0 then /* Does caller want us to wait? */ goto IOCALL_LOOP; /* Yes, wait until operation complete. */ IOCALL_RETURN: arg_ecode = ecode; return; %page; special_handler: entry (arg_call_data_ptr); /* This entry point is called to handle wakeups on the event call * channel, special_echan. This event channel is given to IOI when * the user calls tdcm_set_signal. We will call IOI to get the * status for the current interrupt. */ call_data_ptr = arg_call_data_ptr; /* Get pointer to event call data. */ ws_ptr = call_data.data_ptr; /* The event data ptr is the workspace ptr. */ isp = addr (ws.statq (ws.info.statqx)); /* Get pointer to current IOI status queue entry. */ if ^istat.completion.st then /* If no status then ignore status queue. */ goto GET_SPECIAL_STATUS; /* Go see if there is special status. */ goto SLEVEL (istat.level); /* Go process according to level. */ SLEVEL (7): /* Should not get special status in queue. */ if ws.info.statqx = hbound (ws.statq, 1) then /* Get index of next status queue entry. */ ws.info.statqx = 1; /* If at end wraparound. */ else ws.info.statqx = ws.info.statqx + 1; istat.completion.st = "0"b; /* Free this status queue entry. */ goto GET_SPECIAL_STATUS; /* This is a terminate of system fault interrupt. Either of these * interrupts signals the completion of a connect. tdcm_iocall will * always wait on the wait list event channel for the completion * of a connect. Therefore we must send a wakeup over that channel. * We will not actually process the status from this interrupt. * It will be processed by WAIT_FOR_STATUS when it wakes up. */ SLEVEL (1): /* System fault or terminate interrupt. */ SLEVEL (3): /* Send a wakeup to WAIT_FOR_STATUS. */ SLEVEL (5): /* Marker, treat like terminate */ call hcs_$wakeup (ws.info.process_id, ws.info.wait_list.wait_echan, 0, ecode); /* One way or another we have processed any status in the queue. * Now we must look for a special interrupt. Since this entry * was called we know that the caller wants to be signalled * when there is a special interrupt. We will send a wakeup to him * over the user event channel. The caller should be blocked himself * waiting for this wakeup. */ GET_SPECIAL_STATUS: call ioi_$get_special_status (ws.info.ioix, special_flag, special_status_word, ecode); if ecode ^= 0 then return; if special_flag then /* If we got a special signal user. */ call hcs_$wakeup (ws.info.process_id, ws.info.user_echan, 0, ecode); return; %page; /* This label defines the location where all internal procedures will * return if they encounter a fatal error. This non-structured bit * of programming is done for the sake of efficiency. It means that * there does not have to be a check for errors after each call to * an internal procedure. */ INTERNAL_PROC_RETURN: arg_ecode = ecode; /* Return error code. */ return; SETUP: procedure; /* This procedure is called by all entry points except tdcm_attach. * It gets a pointer to the IOI workspace that we are using. * If we don't have a real IOI workspace yet we will temporarily * use part of the tseg. */ tsegp = arg_tsegp; /* Copy argument. */ if tseg.version_num ^= tseg_version_2 then do; ecode = error_table_$unimplemented_version; goto INTERNAL_PROC_RETURN; end; ecode = 0; if tseg.ws_segno = "0"b /* Do we have a real IOI workspace yet? */ then ws_ptr = addr (tseg.buffer (1)); /* No, use temporary workspace area. */ else ws_ptr = baseptr (tseg.ws_segno); end SETUP; %page; WAIT_FOR_STATUS: procedure; /* This procedure is called when we must wait for a connect to terminate. * We will always block on the status_echan event channel. This is the * event channel that we try to initiate as a fast channel. If the * interrupt which caused IOI to send this wakeup is not a terminate * or system fault we will ignore the wakeup and go blocked again. * When we return all the necessary processing of the interrupt will have * been performed. Then the connect will be considered complete. */ WAIT_LOOP: /* Come here if we have to block again. */ ws.info.meters.block = ws.info.meters.block + 1; /* increment meter */ call ipc_$block (addr (ws.info.wait_list), addr (event_data), ecode); if ecode ^= 0 then do; call convert_ipc_code_ (ecode); goto INTERNAL_PROC_RETURN; end; go to PROC_QUEUE; PROCESS_QUEUE: entry; /* entry called when we know a status queue entry is full */ ws.info.meters.no_block = ws.info.meters.no_block + 1; /* increment meter */ PROC_QUEUE: isp = addr (ws.statq (ws.info.statqx)); /* Get pointer to current IOI status queue entry. */ if ^istat.completion.st then /* If no status then we got an extra wakeup. */ goto WAIT_LOOP; /* Wait again. */ if ws.info.statqx = hbound (ws.statq, 1) then /* Get index of next status queue entry. */ ws.info.statqx = 1; /* If at end wraparound. */ else ws.info.statqx = ws.info.statqx + 1; istat.completion.st = "0"b; /* Free this status queue entry. */ statp = addr (istat.iom_stat); /* Get pointer to IOM status. */ listx = istat.offset; /* Get absolute listx from IOI. */ if ws.info.flags.ndtrans then /* Convert listx depending upon type of DCW list. */ op_count = listx - ws.info.ndt_offsetx + 1; else if ws.info.flags.large_rec then /* One record longer than 4096 words? */ op_count = 1; else op_count = divide ((listx - ws.info.rw_offsetx + 2), 2, 17, 0); goto WLEVEL (istat.level); /* Go process according to level. */ WLEVEL (7): /* Should not get special status in queue. */ goto WAIT_LOOP; /* Ignore, wait for real status. */ WLEVEL (1): /* System fault. */ istat.iom_stat = "0"b; /* Clear IOM status. */ status.major = "1111"b; /* This denotes a system fault. */ WLEVEL (3): /* Terminate interrupt. Process together. */ ws.info.term_st = ws.info.term_st + 1; /* increment meter */ ws.info.consec_mark = 0; /* reset this meter */ if op_count > ws.info.subset_size then do; /* if doing marker processing, must be on second half */ op_count = op_count - ws.info.subset_size; /* set for only number of buffers since last marker */ ws.info.mark_offset = ws.info.subset_size; /* set base buffer */ end; else ws.info.mark_offset = 0; /* first buffer subset */ ws.info.flags.connected = "0"b; /* Connect has now completed. */ if ws.info.flags.reading then /* Was this connect for a read? */ call PROCESS_INPUT; /* Yes, extra processing needed for input. */ tseg.hardware_status = istat.iom_stat; /* Return iom status to user. */ if ^istat.completion.er then do; /* Was there an error? */ tseg.completion_status = 1; /* No, tell user everything is OK. */ ws.info.term_ne = ws.info.term_ne + 1; /* increment meter */ end; else do; /* Yes, there was an error. */ tseg.completion_status = 2; /* Tell user that he got bad status. */ tseg.error_buffer = op_count; /* Tell him how far he got. */ if (status.major = "0011"b) | (status.major = "1011"b) then /* Count data alert errors. */ /* And MPC data alert errors. */ ws.info.error_count = ws.info.error_count + 1; if istat.completion.time_out then /* IF time-out set error code. */ ecode = error_table_$net_timeout; goto INTERNAL_PROC_RETURN; /* Return directly to user. */ end; return; WLEVEL (5): /* Marker interrupt */ ws.info.mark_st = ws.info.mark_st + 1; /* increment meter */ ws.consec_mark = ws.consec_mark + 1; /* increment meter */ if ws.consec_mark > ws.most_consec_mark then /* if this is bigger than previous high */ ws.most_consec_mark = ws.consec_mark; /* change the value */ if ws.info.flags.reading then do; /* if reading extra processing required */ tmr = "0"b; /* reset terminate condition */ do i = op_count by -1 while (^tmr); /* find the real marker index */ if i = 0 then /* if we got to the beginning of the list.. */ i = hbound (ws.rw_list, 1); /* reset back to the end */ idcwp = addr (ws.rw_list (i).idcw); if idcw.control = "11"b then do; /* if true, we found the marker */ tmr = "1"b; /* set terminate conditon */ op_count = i; /* adjust op_count to corrected value */ end; end; if op_count > ws.info.subset_size then do; /* if doing marker processing, must be on second half */ op_count = op_count - ws.info.subset_size; /* set for only number of buffers since last marker */ ws.info.mark_offset = ws.info.subset_size; /* set base buffer */ end; else ws.info.mark_offset = 0; /* first buffer subset */ call PROCESS_INPUT; /* Yes, extra processing needed for input. */ end; tseg.hardware_status = istat.iom_stat; /* copy marker status to return to user */ tseg.completion_status = 1; /* indicate no error */ end WAIT_FOR_STATUS; %page; PROCESS_INPUT: procedure; /* This procedure is called to process input data found in the IOI workspace. * We will copy the input data from the workspace into the tseg buffers. * We must copy the input buffers one at a time since the size of each tseg * buffer may be much larger than the number of words that are actually used * in each buffer. */ if ws.info.flags.allow_marker then /* if doing marker processing */ tbuf_num = ws.info.mark_offset + 1; /* 1 to 1 relation between tseg buf and ws buf */ else tbuf_num = ws.info.read_start; /* otherwise start where he told us */ if ws.info.flags.get_size then do; /* Does caller want actual read count? */ /* Yes, special case. */ fix = 0; /* We may have to fix the read count. */ if (status.char_pos = "1"b3) & (^istat.completion.er) then /* NZ char count & no error? */ if (status.sub & "04"b3) = "04"b3 then if addr (ws.rw_list (1).idcw) -> idcw.command ^= addr (ws.read_idcws (2)) -> idcw.command then fix = 1; /* Fix, 9 track _a_n_d _n_o_t read tape 9. */ else ; else if (^status.eo) & ((status.sub & "60"b3) = "40"b3) then fix = 1; /* Fix, 7 track _a_n_d even _a_n_d 4 bit fill. */ dcw_tally = bin (status.tally, 12) + fix; /* Compute correct tally residue. */ /* Now return read count of first buffer. */ if (listx - ws.info.rw_offsetx) >= (divide (ws.info.buffer_size (1) + 4095, 4096, 17)) then data_size = ws.info.buffer_size (1) - dcw_tally; else data_size = (listx - ws.info.rw_offsetx) * 4096 - dcw_tally; tseg.buffer_size (ws.info.read_start) = data_size; end; do i = ws.info.mark_offset + 1 to ws.info.mark_offset + op_count; /* Copy buffers from workspace to tseg. */ data_size = ws.info.buffer_size (i); /* Get size of this input buffer. */ dcwp = addr (ws.rw_list (i).dcw); /* get correct dcw */ wbuf_ptr = ptr (addr (ws.buffer), dcw.address); /* and get ptr to data */ /* Copy one input buffer into tseg. */ ptr (tsegp, tseg.bufferptr (tbuf_num)) -> based_data = wbuf_ptr -> based_data; tbuf_num = tbuf_num + 1; /* Move to next tseg buffer. */ end; end PROCESS_INPUT; %page; NON_DATA_TRANSFER: procedure; /* This procedure is called to set up non-data transfer IDCWs. * Most fields in these non-data transfer IDCWs were set up when the * the tape drive was attached. We just have to fill in the actual * device command codes and turn OFF the continue bits in the last * IDCW. We get the device commands from the tseg command queue. */ op_count = tseg.command_count; /* Get number of non-data transfer operations. */ if op_count > hbound (ws.ndt_list, 1) /* Make sure there are not too many. */ then do; ecode = error_table_$too_many_buffers; goto INTERNAL_PROC_RETURN; end; do i = 1 to op_count; /* Set up specified number of IDCWs. */ idcwp = addr (ws.ndt_list (i).idcw); /* Get pointer to non-data transfer IDCW. */ idcw.command = bit (tseg.command_queue (i), 6); /* Copy device command. */ idcw.control = "10"b; /* Turn ON continue in each IDCW. */ end; idcw.control = "00"b; /* Terminate list with last IDCW. */ tseg.command_count = 0; /* Tell caller we have picked up all commands. */ ws.info.flags.reading = "0"b; /* Not reading or writing. */ ws.info.flags.ndtrans = "1"b; /* Non-data transfer commands. */ call TRY_TO_CONNECT (ws.info.ndt_offsetx); if ecode ^= 0 then goto INTERNAL_PROC_RETURN; ws.info.flags.connected = "1"b; /* Connect has been made. */ end NON_DATA_TRANSFER; /* CK_STATQ - subroutine to check if any status queue entry is full */ CK_STATQ: proc returns (bit (1) aligned); if ws.statq (ws.info.statqx).completion.st then /* if status stored in this queue entry */ return ("1"b); /* return true */ else return ("0"b); /* no status stored */ end CK_STATQ; %page; MARKER_READ_WRITE: procedure; /* This procedure is called to set up the IDCWs and DCWs used to read * or write data. The write switch in the tseg tells us which type * of operation is to be performed. */ op_count = tseg.buffer_count; /* Get number of buffers to read or write. */ if op_count > ws.info.subset_size then do; /* Did caller specify too many buffers? */ ecode = error_table_$too_many_buffers; goto INTERNAL_PROC_RETURN; end; wbuf_ptr = addr (ws.buffer); /* Get pointer to buffer area in IOI workspace. */ tbuf_num = tseg.buffer_offset + 1; /* Get number of first tseg buffer. */ if tbuf_num > ws.info.subset_size then do; /* if setting up second subset of buffers */ wbuf_num = ws.info.subset_size + 1; wbuf_ptr = addrel (wbuf_ptr, ws.info.subset_size * 1040); /* start at end of first subset */ end; else wbuf_num = 1; /* no set up for first subset */ if tseg.write_sw ^= 0 then do; /* Are we reading or writing? */ ws.info.flags.reading = "0"b; /* Writing not reading. */ data_idcw = ws.info.write_idcws (tseg.mode (tbuf_num)); /* Writing. */ end; else do; /* Reading. */ ws.info.flags.reading = "1"b; ws.info.read_start = tbuf_num; /* Save number of first tseg buffer read into. */ data_idcw = ws.info.read_idcws (tseg.mode (tbuf_num)); /* Reading. */ end; if substr (ws.rw_list (1).idcw, 1, 12) ^= substr (data_idcw, 1, 12) then do; /* set up DCW list, 1st time */ ws.info.flags.large_rec = "0"b; data_size = tseg.buffer_size (tbuf_num); /* set physical record size */ do i = 1 to hbound (ws.rw_list, 1); idcwp = addr (ws.rw_list (i).idcw); /* set up IDCW */ based_idcw = data_idcw; dcwp = addr (ws.rw_list (i).dcw); /* set up DCW */ string (dcw) = "0"b; /* make sure its zero first */ dcw.address = rel (wbuf_ptr); /* set relative workspace address */ dcw.tally = bit (bin (data_size, 12)); /* set tally */ wbuf_ptr = addrel (wbuf_ptr, data_size);/* increment workspace ptr */ ws.info.buffer_size (i) = data_size; /* set up buffer size for reads */ end; wbuf_ptr = addr (ws.buffer); /* reset workspace buffer ptr */ tdcwp = addr (ws.mark_tdcw); /* set up tdcw to chain list */ tdcw.address = rel (addr (ws.rw_list (1).idcw)); tdcw.type = "10"b; /* make it a tdcw */ tdcw.rel = "1"b; /* and set relative mode */ end; call METER_IO; /* go meter the IO time */ do i = wbuf_num to wbuf_num + op_count - 1; /* Set up IDCW and and copy data if writing */ if tseg.write_sw ^= 0 then do; /* if writing... */ data_size = tseg.buffer_size (tbuf_num);/* get buffer size */ wbuf_ptr -> based_data = ptr (tsegp, tseg.bufferptr (tbuf_num)) -> based_data; wbuf_ptr = addrel (wbuf_ptr, data_size);/* go to next buffer */ tbuf_num = tbuf_num + 1; /* increment tseg buffer number */ end; idcwp = addr (ws.rw_list (i).idcw); /* set idcw ptr */ idcw.control = "10"b; /* set all idcws to continue */ end; idcw.control = "00"b; /* Terminate list with last IDCW. */ tseg.buffer_count = 0; /* Tell caller that we picked up all buffers. */ ws.info.flags.ndtrans = "0"b; /* These are not non-data transfer commands. */ if ^ws.info.flags.connected then do; /* if no I/O in progress, get it going now */ call TRY_TO_CONNECT (ws.info.rw_offsetx + ((wbuf_num - 1) * 2)); ws.info.flags.connected = "1"b; /* Connect has been made. */ end; else do; /* I/O in progress, must be processing markers */ if op_count = ws.info.subset_size then do; /* if we can, set up marker to keep I/O going */ if tseg.buffer_offset = 0 then /* if this I/O was for first subset */ idcwp = addr (ws.rw_list (hbound (ws.rw_list, 1)).idcw); /* set idcw ptr for last idcw */ else idcwp = addr (ws.rw_list (tseg.buffer_offset).idcw); /* otherwise set for middle idcw */ idcw.control = "11"b; /* set marker control bits in appropriate idcw */ end; call CHECK_STATUS; /* wait for status to come in */ if ^ws.info.flags.connected & /* if no I/O in progress */ tseg.completion_status = 1 then do; /* and no error, get I/O going */ call TRY_TO_CONNECT (ws.info.rw_offsetx + ((wbuf_num - 1) * 2)); ws.info.flags.connected = "1"b; /* Connect has been made. */ end; end; end MARKER_READ_WRITE; %page; READ_WRITE: procedure; /* This procedure is called to set up the IDCWs and DCWs used to read * or write data. The write switch in the tseg tells us which type * of operation is to be performed. */ op_count = tseg.buffer_count; /* Get number of buffers to read or write. */ if op_count > ws.info.subset_size then do; /* Did caller specify too many buffers? */ ecode = error_table_$too_many_buffers; goto INTERNAL_PROC_RETURN; end; wbuf_ptr = addr (ws.buffer); /* Get pointer to buffer area in IOI workspace. */ tbuf_num = tseg.buffer_offset + 1; /* Get number of first tseg buffer. */ /* tseg buffer offset starts with 0. */ if tseg.write_sw ^= 0 then /* Are we reading or writing? */ ws.info.flags.reading = "0"b; /* Writing not reading. */ else do; /* Reading. */ ws.info.flags.reading = "1"b; ws.info.read_start = tbuf_num; /* Save number of first tseg buffer read into. */ if tseg.get_size ^= 1 then /* Does caller want actual data size read? */ ws.info.flags.get_size = "0"b; /* No. */ else do; /* Yes. */ ws.info.flags.get_size = "1"b; if op_count > 1 then do; /* Only works if reading one buffer. */ ecode = error_table_$too_many_buffers; goto INTERNAL_PROC_RETURN; end; end; end; call METER_IO; /* go meter this I/O */ tot_data_size = 0; /* Keep count of combined buffer sizes. */ do i = 1 to op_count; /* Set up IDCW and DCW for each buffer. */ data_size = tseg.buffer_size (tbuf_num); /* Num of words to process in this buf. */ tot_data_size = tot_data_size + data_size; /* Get total num of words to process. */ if (tot_data_size > ws.info.buf_size) | (data_size <= 0) then do; /* Is total more than we can handle? */ /* Or is number for this buffer invalid? */ ecode = error_table_$buffer_big; goto INTERNAL_PROC_RETURN; end; if data_size > 4096 then /* If more than one DCW needed ... */ if op_count > 1 then do; /* Can only allow one operation. */ ecode = error_table_$too_many_buffers; go to INTERNAL_PROC_RETURN; end; else ws.info.flags.large_rec = "1"b; else ws.info.flags.large_rec = "0"b; idcwp = addr (ws.rw_list (i).idcw); /* Now set up IDCW. */ if tseg.write_sw ^= 0 then do; /* Are we writing or reading? */ based_idcw = ws.info.write_idcws (tseg.mode (tbuf_num)); /* Writing, copy data from tseg to workspace. */ wbuf_ptr -> based_data = ptr (tsegp, tseg.bufferptr (tbuf_num)) -> based_data; end; else do; /* Reading. */ based_idcw = ws.info.read_idcws (tseg.mode (tbuf_num)); ws.info.buffer_size (i) = data_size; /* Remember how many words we are to read. */ end; dcwp = addr (ws.rw_list (i).dcw); /* Set up DCW first. */ do while (data_size > 0); /* Make as many DCWs as needed. */ string (dcw) = "0"b; dcw.address = rel (wbuf_ptr); dcw_tally = min (data_size, 4096); dcw.tally = bit (bin (dcw_tally, 12)); if data_size > 4096 then dcw.type = "01"b; dcwp = addrel (dcwp, 1); wbuf_ptr = addrel (wbuf_ptr, dcw_tally); data_size = data_size - dcw_tally; end; tbuf_num = tbuf_num + 1; /* Move to next tseg buffer. */ end; idcw.control = "00"b; /* Terminate list with last IDCW. */ tseg.buffer_count = 0; /* Tell caller that we picked up all buffers. */ ws.info.flags.ndtrans = "0"b; /* These are not non-data transfer commands. */ call TRY_TO_CONNECT (ws.info.rw_offsetx); ws.info.flags.connected = "1"b; /* Connect has been made. */ end READ_WRITE; %page; /* METER_IO - subroutine to meter time of each I/O */ METER_IO: proc; if ^display_meters then return; /* if not doing metering, forget it */ if ws.last_io_time = 0 then /* if first I/O... */ ws.last_io_time, ws.low_delta = clock (); /* initialize meters */ else do; /* do some metering */ io_time = clock (); /* get the current clock reading */ delta = io_time - ws.last_io_time; /* get time between ios */ ws.last_io_time = io_time; /* save current time */ ws.io_delta = ws.io_delta + delta; /* add in current increment */ if delta > ws.high_delta then /* if this increment is larger than previous.. */ ws.high_delta = delta; /* save this one */ if delta < ws.low_delta then /* if this icrement is smaller than previous */ ws.low_delta = delta; /* save this one */ if tseg.buffer_count > ws.info.block_count then /* if block count > whats saved */ ws.info.block_count = tseg.buffer_count;/* change it */ ws.number_ios = ws.number_ios + 1; /* increment number of data xfer ios */ end; end METER_IO; /* CHECK_STATUS - subroutine to check status queue. If status queue entry full, we will process it without going blocked. */ CHECK_STATUS: proc; if CK_STATQ () then /* if there is status to process.. */ call PROCESS_QUEUE; /* go do it, don't wait for it */ else do; /* currently no status, drain the channel... */ call ipc_$drain_chn (ws.info.wait_list.wait_echan, ecode); /* get ride of any pending wakeups */ if ecode ^= 0 then do; call convert_ipc_code_ (ecode); goto INTERNAL_PROC_RETURN; end; if CK_STATQ () then /* if there is status to process.. */ call PROCESS_QUEUE; /* go do it, don't wait for it */ else call WAIT_FOR_STATUS; /* go wait for marker or terminate status */ end; end CHECK_STATUS; %page; TRY_TO_CONNECT: proc (P_idx); /* * This procedure is used to perform connects; if there is insufficient * main memory for a buffer when it is called, it waits for one half second, * and tries again. If it fails after 25 tries, or encounters some other * error, it aborts and goes to INTERNAL_PROC_RETURN. This is done in * tdcm_ because it is necessary to go blocked while waiting; the error * of not having sufficient memory used to crash the system. */ dcl P_idx fixed bin parameter; dcl connect_retries fixed bin; dcl MAX_CONNECT_RETRIES fixed bin internal static options (constant) init (25); connect_retries = 0; /* haven't tried at all yet */ TRY_AGAIN_TO_CONNECT: call ioi_$connect (ws.info.ioix, P_idx, ecode); if ecode = 0 then return; /* successfully accomplished */ else if ecode ^= error_table_$out_of_main_memory then /* lossage, some unexpected error */ goto INTERNAL_PROC_RETURN; else do; /* not enough room now, wait a while */ if connect_retries > MAX_CONNECT_RETRIES then/* we've tried too often, let's just give up */ goto INTERNAL_PROC_RETURN; connect_retries = connect_retries + 1; call WAIT_FOR_A_MOMENT (); goto TRY_AGAIN_TO_CONNECT; end; /* end of loop trying to connect */ end TRY_TO_CONNECT; %page; WAIT_FOR_A_MOMENT: proc (); /* * This procedure is used to sleep for a short period of time, while * waiting for more buffer space to become available. It is stolen * more or less bodily from set_lock_. */ dcl ALRM_STRING (1) char (32) internal static options (constant) init ("alrm"); dcl A_BRIEF_MOMENT fixed bin (71) internal static options (constant) init (500000); /* half a second, really */ dcl RELATIVE_MICROSECONDS bit (2) aligned internal static options (constant) init ("10"b); dcl initialized_for_waiting bit (1) aligned internal static init ("0"b); dcl this_is_initial_ring bit (1) aligned internal static; dcl alrm_mask bit (36) aligned internal static; dcl 1 wait_list aligned internal static, 2 count fixed bin, 2 channel fixed bin (71); dcl saved_alarm_channel fixed bin (71); dcl saved_alarm_time fixed bin (71); dcl ignore_message fixed bin (71); dcl saved_mask bit (36) aligned; dcl create_ips_mask_ entry (ptr, fixed bin, bit (36) aligned); dcl get_lock_id_ ext entry (bit (36) aligned); dcl get_ring_ ext entry returns (fixed bin (3)); dcl get_initial_ring_ ext entry returns (fixed bin (3)); dcl hcs_$get_alarm_timer ext entry (fixed bin (71), fixed bin (71)); dcl hcs_$get_ips_mask entry (bit (36) aligned); dcl hcs_$set_alarm_timer ext entry (fixed bin (71), fixed bin, fixed bin (71)); dcl ipc_$create_ev_chn ext entry (fixed bin (71), fixed bin (35)); dcl ipc_$block ext entry (ptr, ptr, fixed bin (35)); dcl timer_manager_$sleep ext entry (fixed bin (71), bit (2) aligned); if ^initialized_for_waiting then do; /* prepare to wait for a moment */ call create_ips_mask_ (addr (ALRM_STRING), 1, alrm_mask); alrm_mask = substr (^alrm_mask, 1, 35); /* complement it for later tests */ this_is_initial_ring = (get_ring_ () = get_initial_ring_ ()); call ipc_$create_ev_chn (wait_list.channel, (0)); wait_list.count = 1; initialized_for_waiting = "1"b; end; call hcs_$get_ips_mask (saved_mask); /* See if IPS are masked. */ if this_is_initial_ring & ((substr (saved_mask, 1, 35) & alrm_mask) = alrm_mask) then do; /* we can call timer_manager_ */ call timer_manager_$sleep (A_BRIEF_MOMENT, RELATIVE_MICROSECONDS); end; /* sleep for a moment */ else do; /* we cannot call timer_manager_ */ call hcs_$get_alarm_timer (saved_alarm_time, saved_alarm_channel); /* remember current alarm settings */ call hcs_$set_alarm_timer (A_BRIEF_MOMENT, 1, wait_list.channel); /* get awakened later */ call ipc_$block (addr (wait_list), addr (ignore_message), ecode); /* wait for wakeup */ call hcs_$set_alarm_timer (saved_alarm_time, 2, saved_alarm_channel); /* reset original timer settings */ if ecode ^= 0 then /* if trouble then give up */ goto INTERNAL_PROC_RETURN; end; return; /* we have waited */ end; /* internal procedure WAIT_FOR_A_MOMENT */ %page; REWIND_TAPE: procedure; /* Temporary procedure used with the dummy version of RCP. */ dcl tdcm_$tdcm_iocall entry (ptr, fixed bin (35)); tseg.sync = 1; tseg.get_size = 0; tseg.buffer_count = 0; tseg.command_count = 1; tseg.command_queue (1) = 111000b; /* REWIND */ call tdcm_$tdcm_iocall (tsegp, ecode); end REWIND_TAPE; end tdcm_;  tdcm_attach_.pl1 11/30/82 1535.7rew 11/30/82 1207.7 40302 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ tdcm_attach_: procedure (arg_tsegp, arg_ecode); /* This program implements the entry point tdcm_$tdcm_attach. * Created on 02/20/75 by Bill Silver. * Modified 7/79 by R.J.C. Kissel to use version 1 tseg. * * This program is called by tdcm_ to attach a tape drive. No concept of * privilege is recognized. RCP will determine the privilege of the caller. * Since at this time we do not know the name of the tape reel the caller * wants mounted we will not be able to call RCP to make the attachment. * The actual attachment will be made by tdcm_$tdcm_message_. We will use the * first tseg buffer for a temporary IOI workspace. We will return a 0 in the * tseg drive_number field. Thus the tseg will be in an inconsistent state * until the first call to tdcm_$tdcm_message. */ dcl arg_ecode fixed bin (35); /* (O) Standard error_table_ code. */ dcl arg_tsegp ptr; /* (I) Pointer to user's tseg. */ dcl ecode fixed bin (35); /* Temporary error code. */ dcl init_flag bit (1) internal static init ("0"b); dcl based_ws_info (size (ws_info)) bit (36) based (ws_ptr); dcl (addr, size, string) builtin; dcl default_buf_size fixed bin /* tdcm_ I/O buffer size. Room for 2 MST records. */ internal static init (2080); dcl convert_ipc_code_ entry (fixed bin (35)); dcl hcs_$assign_channel entry (fixed bin (71), fixed bin (35)); dcl ipc_$create_ev_chn entry (fixed bin (71), fixed bin (35)); dcl tdcm_detach_ entry (ptr, fixed bin (35)); dcl error_table_$unimplemented_version fixed bin (35) external; /* */ %include tseg; /* */ %include tdcm_info; /* */ %include ioi_stat; /* */ tsegp = arg_tsegp; /* Pick up argument. */ if tseg.version_num ^= tseg_version_2 then do; arg_ecode = error_table_$unimplemented_version; return; end; tseg.ws_segno = "0"b; /* We don't have a real IOI workspace yet. */ ws_ptr = addr (tseg.buffer (1)); /* Use first buffer for temp workspace. */ string (based_ws_info) = "0"b; /* Initialize all info fields to zero. */ /* We must set up three event channels. * 1. A user event channel - found in the tseg. * 2. A fast event channel - used to wait for status. * 3. A call event channel - used to handle special interrupts. */ ws.info.wait_list.num_ev_chans = 1; /* Set up the wait list count. */ ws.info.user_echan = tseg.ev_chan; /* Get event channel ID from tseg. */ /* Created our main (fast) event channel. */ call hcs_$assign_channel (ws.info.fast_echan, ecode); if ecode ^= 0 /* Did we get a fast channel? */ then do; /* No, get regular channel. */ call ipc_$create_ev_chn (ws.info.fast_echan, ecode); if ecode ^= 0 then do; call convert_ipc_code_ (ecode); goto RETURN; end; end; ws.info.detachx = 1; /* Note that fast channel was created OK. */ ws.info.init_echan = ws.info.fast_echan; /* Start out using the fast channel. */ /* Create a regular event channel for special interrupts. */ call ipc_$create_ev_chn (ws.info.special_echan, ecode); if ecode ^= 0 /* When drive attached it becomes a call channel. */ then do; call convert_ipc_code_ (ecode); goto RETURN; end; ws.info.detachx = 2; /* Note that this channel was created OK. */ /* Now initialize some fields in the temporary workspace. They will * be copied into the real workspace when we get one. */ ws.info.buf_size = default_buf_size; /* Set up size of tdcm_ I/O buffer. */ if tseg.tracks = 1 /* Save requested track type. */ then ws.info.tracks = 7; /* 1 => seven track. */ else ws.info.tracks = 9; /* Otherwise it is nine track. */ tseg.drive_name = ""; /* Don't let caller think it has a real drive. */ RETURN: arg_ecode = ecode; if ecode ^= 0 /* Was there any error? */ then call tdcm_detach_ (ws_ptr, ecode); end tdcm_attach_;  tdcm_detach_.pl1 11/30/82 1535.7rew 11/30/82 1207.8 24363 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ tdcm_detach_: procedure (arg_ws_ptr, arg_ecode); /* This program implements the tdcm_$tdcm_detach entry point. * Created on 02/20/75 by Bill Silver. * * This program is called to detach the specified tape drive. * Unless the current disposition specifies that we should retain * this tape drive assignmnet we will unassign as well as detach * this tape drive. */ /* ARGUMENT DATA */ dcl arg_ecode fixed bin(35); /* (O) Standard error_table_ code. */ dcl arg_ws_ptr ptr; /* (I) Pointer to IOI workspace segment. */ /* AUTOMATIC DATA */ dcl drive_num fixed bin; /* Number of the current drive. */ dcl ecode fixed bin(35); /* Temporary error code. */ dcl save_ecode fixed bin; /* Used to save ecode. */ dcl special_echan fixed bin(71); /* Copied from workspace. */ dcl fast_echan fixed bin(71); /* EXTERNAL ENTRIES CALLED */ dcl ( addr, size, string ) builtin; dcl convert_ipc_code_ entry (fixed bin(35)); dcl ipc_$delete_ev_chn entry (fixed bin(71), fixed bin(35)); dcl rcp_$detach entry (bit(36) aligned, bit(*) aligned, fixed bin, char(*), fixed bin(35)); /* */ %include tdcm_info; /* */ %include ioi_stat; /* */ /* Begin tdcm_detach_.pl1 */ ws_ptr = arg_ws_ptr; /* Copy arguments. */ special_echan = ws.info.special_echan; /* Copy before workspace deleted. */ fast_echan = ws.info.fast_echan; save_ecode = 0; goto DETACH(ws.info.detachx); /* Go undo whatever has been done. */ DETACH(3): /* Tape drive has been attached. */ call rcp_$detach (ws.info.rcp_id, ws.info.disposition, ws.info.error_count, "", ecode); if ecode ^= 0 then if save_ecode = 0 then save_ecode = ecode; DETACH(2): /* Special event channel was created. */ call ipc_$delete_ev_chn (special_echan, ecode); if ecode ^= 0 then do; call convert_ipc_code_ (ecode); if save_ecode = 0 then save_ecode = ecode; end; DETACH(1): /* Fast event channel was created. */ call ipc_$delete_ev_chn (fast_echan, ecode); if ecode ^= 0 then do; call convert_ipc_code_ (ecode); if save_ecode = 0 then save_ecode = ecode; end; DETACH(0): arg_ecode = save_ecode; /* Return first error code. */ end tdcm_detach_;  tdcm_message_.pl1 11/30/82 1535.7rew 11/30/82 1207.8 140499 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,indattr,ifthen,dclind9 */ tdcm_message_: procedure (arg_tsegp, arg_ws_ptr, arg_reel_name, arg_write_sw, arg_ecode); /* This program implements the tdcm_$tdcm_message entry point. * Created on 02/20/75 by Bill Silver. * Cleanup handler during block added 12/28/76 by Bernard Greenberg. * Modified on 09/19/77 by R.J.C. Kissel to fix bug in call to ipc_$decl_ev_call_chn. * Modified on 12/09/78 by Michael R. Jordan to use version 2 tape_info. * Modified 3/79 by Michael R. Jordan for MR7.0R to stop using rcp_$tape_message and always detach (with retain) * and re-attach for multiple volumes. * Modified 7/79 by R.J.C. Kissel to use tseg version 1, to correct wrong drive name bug, * and to ask RCP for the right density. * * Modified 8/80 by R.L. Coppola to pass tseg.drive_name to tape_info.device_name. * * This program is called to write a mount message on the operator's console. * However, the first time it is called no message is written. Instead this * first call will actually perform the tape drive attachment. For at least * a while, subsequent calls will result in a mount message being typed. */ /* ARGUMENTS DATA */ dcl arg_ecode fixed bin (35); /* (O) Standard error_table_ code. */ dcl arg_reel_name char (*); /* (I) Tape reel ID name plus qualifiers. */ dcl arg_tsegp ptr; /* (I) Pointer to user's tseg. */ dcl arg_write_sw fixed bin (1); /* (I) 1 => write, 0 => read. */ dcl arg_ws_ptr ptr; /* (I) Pointer to temporary workspace. */ /* AUTOMATIC DATA */ dcl 1 tape_info_buffer like tape_info; /* Tape info structure needed by RCP. */ dcl temp_idcw bit (36) aligned; /* Used to build read/write IDCW's. */ dcl system_flag bit (1); /* ON => user wants to be a system process. */ dcl write_flag bit (1); /* Used to copy arg_write_sw. */ dcl comment char (64); /* Comment sent to RCP. */ dcl reel_name char (32); /* Tape reel ID name. */ dcl temp_reel_name char (64); /* Used to copy reel name argument. */ dcl real_ws_ptr ptr; /* Pointer to actual IOI workspace segment. */ dcl delimx fixed bin; /* Used to parse the reel name string. */ dcl drive_num fixed bin; /* Number of the current drive. */ dcl ecode fixed bin (35); /* Temporary error code. */ dcl i fixed bin; dcl statex fixed bin; /* RCP state index. */ dcl timeout_max fixed bin (71); /* Maximum time-out interval. */ dcl workspace_max fixed bin (19); /* Maximum size of IOI workspace. */ dcl workspace_size fixed bin (19); /* Actual size of IOI workspace. */ /* BASED DATA */ dcl based_idcw bit (36) based (idcwp) aligned; dcl event_data (8) bit (36); /* Not really used. */ /* INTERNAL STATIC DATA */ dcl read_idcw_commands (0:5) bit (6) internal static init ("000101"b, /* Binary */ "000100"b, /* BCD */ "000011"b, /* 9 Track */ "010100"b, /* EBCDIC */ "010111"b, /* ASCII */ "010101"b); /* ASCII/EBCDIC */ dcl write_idcw_commands (0:5) bit (6) internal static init ("001101"b, /* Binary */ "001100"b, /* BCD */ "001011"b, /* 9 Track */ "011100"b, /* EBCDIC */ "011111"b, /* ASCII */ "011101"b); /* ASCII/EBCDIC */ /* EXTERNAL ENTRIES CALLED */ dcl (addr, after, baseno, bit, decat, fixed, hbound, index, rel, rtrim, size, string, substr, unspec) builtin; dcl error_table_$ionmat fixed bin (35) external; dcl error_table_$big_ws_req fixed bin (35) external; dcl error_table_$unimplemented_version fixed bin (35) external; dcl com_err_ entry options (variable); dcl convert_ipc_code_ entry (fixed bin (35)); dcl cv_dec_ entry (char (*), fixed bin); dcl get_process_id_ entry returns (bit (36) aligned); dcl hcs_$wakeup entry (bit (36) aligned, fixed bin (71), fixed bin (71), fixed bin (35)); dcl ioi_$set_event entry (fixed bin, fixed bin (71), fixed bin (35)); dcl ioi_$set_status entry (fixed bin, fixed bin (18), fixed bin, fixed bin (35)); dcl ioi_$timeout entry (fixed bin, fixed bin (71), fixed bin (35)); dcl ioi_$workspace entry (fixed bin, ptr, fixed bin (19), fixed bin (35)); dcl ipc_$block entry (ptr, ptr, fixed bin (35)); dcl ipc_$decl_ev_call_chn entry (fixed bin (71), entry, ptr, fixed bin, fixed bin (35)); dcl ipc_$decl_ev_wait_chn entry (fixed bin (71), fixed bin (35)); dcl rcp_$attach entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35)); dcl rcp_$check_attach entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (19), fixed bin (71), fixed bin, fixed bin (35)); dcl rcp_$detach entry (bit (36) aligned, bit (*), fixed bin, char (*), fixed bin (35)); dcl tdcm_$special_handler entry (ptr); /* CONDITIONS */ dcl cleanup condition; %include tseg; %include tdcm_info; %include ioi_stat; %include rcp_tape_info; %include rcp_resource_types; %include iom_pcw; tsegp = arg_tsegp; /* Copy arguments. */ if tseg.version_num ^= tseg_version_2 then do; arg_ecode = error_table_$unimplemented_version; return; end; ws_ptr = arg_ws_ptr; temp_reel_name = arg_reel_name; write_flag = bit (arg_write_sw); system_flag = "0"b; /* Assume not a system process. */ begin; /* Necessary for multi-volume switching. */ dcl garbage (size (ws)) bit (36); if ws.flags.attached /* Is tape drive already attached. */ then do; /* Yes, actually process the message. */ unspec (garbage) = unspec (ws); /* Make temp copy of workspace. */ tseg.ws_segno = "0"b; /* No workspace for a while. */ ws_ptr = addr (garbage); /* And start to use it. */ call rcp_$detach (ws.info.rcp_id, "1"b, ws.info.error_count, "", ecode); ws.info.error_count = 0; call ipc_$decl_ev_wait_chn (ws.info.special_echan, ecode); if ecode ^= 0 /* Did we make it a call channel? */ then do; /* No. */ call convert_ipc_code_ (ecode); goto RETURN; end; end; /* Now we will parse the reel name string. */ delimx = index (temp_reel_name, ","); /* Look for first comma in reel name. */ if delimx = 0 /* Are there other fields in the reel name? */ then do; /* No. */ reel_name = temp_reel_name; /* Use the whole reel name. */ comment = ""; /* No comment. */ end; else do; /* Yes there are other fields in the reel name. */ reel_name = substr (temp_reel_name, 1, (delimx - 1)); comment = temp_reel_name; /* Use whole reel name string as a comment. */ delimx = index (temp_reel_name, ",sys"); if delimx ^= 0 /* ",sys" => user wants to be a system process */ then system_flag = "1"b; end; /* Now that we know the reel name we will try to attach the tape drive. * RCP will assign a tape drive depending upon the data in tape_info. * RCP will mount the specified reel on the assigned drive as part of * the attachment. RCP will make sure that the drive is ready and the * reel is at BOT. It will make sure that the write ring is correct. * First we must fill in the tape_info structure needed by RCP. */ tape_info_ptr = addr (tape_info_buffer); /* Pointer to tape_info structure. */ tape_info.version_num = tape_info_version_2; /* We must always set this. */ tape_info.usage_time, /* These fields not used yet. */ tape_info.wait_time = 0; tape_info.system_flag = system_flag; tape_info.device_name = tseg.drive_name; /* Assign the right device. */ tape_info.model = 0; /* We will accept any model. */ tape_info.tracks = ws.info.tracks; /* We want specific track type. */ tape_info.density = tseg.density; /* Ask for what the user requested. */ tape_info.speed = tseg.speed; tape_info.unused_qualifier = "0"b; tape_info.volume_name = reel_name; /* Fill in tape info colume data. */ tape_info.write_flag = write_flag; tape_info.position_index = 0; /* Initialize. Not really used yet. */ /* Use regular channel with RCP. Not a call chan yet. */ ws.info.wait_list.wait_echan = ws.info.special_echan; call rcp_$attach (DEVICE_TYPE (TAPE_DRIVE_DTYPEX), tape_info_ptr, ws.info.special_echan, comment, ws.info.rcp_id, ecode); if ecode ^= 0 then goto RETURN; reel_name = tape_info.volume_name; /* remember, these things might have been changed by ring 1 */ if index (temp_reel_name, ",") > 0 then temp_reel_name = rtrim (reel_name) || "," || after (temp_reel_name, ","); else temp_reel_name = reel_name; arg_reel_name = temp_reel_name; ws.info.detachx = 3; /* Now we have an RCP ID and must detach. */ /* We must check to see if the attachment has completed. If RCP tells us * that there is a short wait we will block. We must call RCP again after * each short wait. */ ATTACH_LOOP: comment = " "; call rcp_$check_attach (ws.info.rcp_id, tape_info_ptr, comment, ws.info.ioix, workspace_max, timeout_max, statex, ecode); if comment ^= " " /* Is there a comment from RCP? */ then call com_err_ (0, "tdcm_", "RCP comment: ^a", comment); goto ATTACH_STATE (statex); ATTACH_STATE (1): /* Short wait. */ on cleanup call clean_up; call ipc_$block (addr (ws.info.wait_list), addr (event_data), ecode); revert cleanup; if ecode ^= 0 then do; call convert_ipc_code_ (ecode); goto RETURN; end; goto ATTACH_LOOP; /* Call RCP again. */ ATTACH_STATE (2): /* Long wait. */ ecode = error_table_$ionmat; ATTACH_STATE (3): /* Fatal error. */ goto RETURN; /* The attachment has completed. We must call IOI to establish the * real IOI workspace buffer. */ ATTACH_STATE (0): /* Attachment complete. */ call cv_dec_ (substr (tape_info.device_name, 6, 2), drive_num); tseg.drive_name = tape_info.device_name; /* Return correct drive name. */ /* Now we must get a real IOI workspace. We will ask for a workspace that is * just large enough to contain all of tdcm_info. If the buffer size is too * large we will have to adjust it so it will fit into the maximum size * workspace that we may allocate. */ workspace_size = fixed (rel (addr (ws.buf_end)), 18) - fixed (rel (addr (ws.info)), 18) + 1; if workspace_size > workspace_max /* If buffer size too large adjust it. */ then do; ws.info.flags.good_ws = "0"b; ecode = error_table_$big_ws_req; goto RETURN; end; call ioi_$workspace (ws.info.ioix, real_ws_ptr, workspace_size, ecode); if ecode ^= 0 then do; ws.info.flags.good_ws = "0"b; goto RETURN; end; ws.info.flags.good_ws = "1"b; /* We now have a real IOI workspace. We will copy all workspace ws_info * from the temporary workspace into the real workspace. From then on * we will deal only with the real workspace. */ real_ws_ptr -> ws.info = ws_ptr -> ws.info; /* Move ws_info to real workspace. */ ws_ptr = real_ws_ptr; /* Use real workspace pointer. */ tseg.ws_segno = baseno (ws_ptr); /* Save workspace segment number. */ end; /* End of the begin block. */ /* Now we will complete the initialization of the IOI workspace. * We will call IOI to set the time-out limit to the maximum. * We will convert the special event channel into an event call * channel. The data pointer for this call channel is the pointer * to the real workspace for this drive. We must call IOI to set up * the event channel that we want to use when we start I/O processing. * We will initialize all the other data in the workspace including * the DCW lists. */ call ioi_$timeout (ws.info.ioix, timeout_max, ecode); if ecode ^= 0 then goto RETURN; /* Set up our IOI status queue. */ call ioi_$set_status (ws.info.ioix, fixed (rel (addr (ws.statq)), 18), hbound (ws.statq, 1), ecode); if ecode ^= 0 then return; do i = 1 to hbound (ws.statq, 1); /* Set up all status queue entries. */ ws.statq (i).completion.st = "0"b; /* Make this entry free. */ end; ws.info.statqx = 1; /* Start with first status queue entry. */ call ioi_$set_event (ws.info.ioix, ws.info.init_echan, ecode); if ecode ^= 0 /* Did we set up IOI's event channel? */ then goto RETURN; /* No. */ /* From now on always wait on fast channel. */ ws.info.wait_list.wait_echan = ws.info.fast_echan; /* Make special channel an event call channel. */ call ipc_$decl_ev_call_chn (ws.info.special_echan, tdcm_$special_handler, ws_ptr, 0, ecode); if ecode ^= 0 /* Did we make it a call channel? */ then do; /* No. */ call convert_ipc_code_ (ecode); goto RETURN; end; ws.info.disposition = "0"b; /* Until told otherwise let RCP decide. */ ws.info.process_id = get_process_id_ (); /* Need process ID to wakeup user. */ ws.info.flags.attached = "1"b; /* Device is now attached. */ /* Save offset of each DCW list. */ ws.info.ndt_offsetx = fixed (rel (addr (ws.ndt_list)), 18); ws.info.rw_offsetx = fixed (rel (addr (ws.rw_list)), 18); do i = 1 to hbound (ws.ndt_list, 1); /* Initialize non-data transfer IDCWs. */ idcwp = addr (ws.ndt_list (i).idcw); /* Get pointer to IDCW. */ string (idcw) = "0"b; /* Clear it to all zeros. */ idcw.device = bit (fixed (drive_num, 6)); /* Set up device number. */ idcw.code = "111"b; /* This => it is an IDCW. */ idcw.chan_cmd = "000010"b; /* This => it is a non-data transfer IDCW. */ idcw.count = "000001"b; /* Record count = 1. */ end; do i = 1 to hbound (ws.rw_list, 1); /* Set up read/write DCW list. */ ws.rw_list (i).dcw = "0"b; /* Clear all DCW's. */ end; idcwp = addr (temp_idcw); /* Initialize our work IDCW. */ string (idcw) = "0"b; /* Clear it to all zeros. */ idcw.device = bit (fixed (drive_num, 6)); /* Fill in this drive number. */ idcw.code = "111"b; /* This is an IDCW. */ idcw.control = "10"b; /* Initialize to continue. */ do i = 0 to hbound (ws.info.read_idcws, 1); idcwp = addr (ws.info.read_idcws (i)); /* Set up each read IDCW. */ based_idcw = temp_idcw; /* Copy template with drive number. */ idcw.command = read_idcw_commands (i); /* Fill in corresponding command. */ end; do i = 0 to hbound (ws.info.write_idcws, 1); idcwp = addr (ws.info.write_idcws (i)); /* Set up each write IDCW. */ based_idcw = temp_idcw; idcw.command = write_idcw_commands (i); end; /* Now send a wakeup to the user. He should be waiting for it. * It tells him that the tape drive is now in READY. */ call hcs_$wakeup (ws.info.process_id, ws.info.user_echan, 0, ecode); RETURN: arg_ecode = ecode; /* Return error code. */ return; /* Clean-up procedure during blocking. */ clean_up: proc; call rcp_$detach (ws.info.rcp_id, "0"b, (0), "", (0)); end; end tdcm_message_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- 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