cancel_cobol_program.pl1 05/24/89 1048.6rew 05/24/89 0837.3 38952 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cancel_cobol_program.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/25/76 by ORN to comply with error message standards */ /* Modified 03/26/76 by ORN to call cobol_control_$cancel and cobol_stop_run_. Change made in conjunction with cobol_control_ modification. */ /* format: style3 */ cancel_cobol_program: ccp: proc; dcl (i, arglen, nargs) fixed bin; dcl code fixed bin (35); dcl (rdsw, rfsw) fixed bin; dcl asw bit (1); dcl found bit (1); dcl argptr ptr; dcl arg char (arglen) based (argptr); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cobol_control_$cancel entry (char (*), fixed bin, fixed bin, fixed bin (35)); dcl cobol_stop_run_ entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$bigarg fixed bin (35) ext static; /*************************************/ start: asw = "0"b; rdsw, rfsw = 0; call cu_$arg_count (nargs); if nargs < 1 then go to no_arg_error; do i = 1 to nargs; call cu_$arg_ptr (i, argptr, arglen, code); if code ^= 0 then go to multics_error; if substr (arg, 1, 1) = "-" then do; if arg = "-a" | arg = "-all" then asw = "1"b; else if arg = "-retd" | arg = "-retain_data" then rdsw = 1; else if arg = "-rf" | arg = "-retain_files" then rfsw = 1; else go to control_arg_error; end; end; found = "0"b; do i = 1 to nargs; call cu_$arg_ptr (i, argptr, arglen, code); if code ^= 0 then go to multics_error; if substr (arg, 1, 1) ^= "-" then do; if asw then do; call com_err_ (0, "cancel_cobol_program", "Redundant names specified with the -all option are ignored."); i = nargs; end; else do; if arglen > 65 then go to arg_too_long_error; call cobol_control_$cancel (arg, rdsw, rfsw, code); if code ^= 0 then do; if code = -2 then go to no_run_error; else if code = -1 then go to no_prog_error; else go to multics_arg_error; end; found = "1"b; end; end; end; if asw then do; call cobol_stop_run_ (null (), rdsw, rfsw, code); if code ^= 0 then go to no_run_error; end; else if ^found then go to no_arg_error; return; /*************************************/ no_prog_error: call com_err_ (0, "cancel_cobol_program", "The program ^a is not active in the current run-unit.", substr (arg, 1, arglen)); if code > 0 then go to multics_error; return; arg_too_long_error: call com_err_ (error_table_$bigarg, "cancel_cobol_program", substr (arg, 1, arglen)); return; no_run_error: call com_err_ (0, "cancel_cobol_program", "There are no active programs in the current run-unit."); if code > 0 then go to multics_error; return; no_arg_error: call com_err_ (error_table_$noarg, "cancel_cobol_program"); return; control_arg_error: call com_err_ (error_table_$badopt, "cancel_cobol_program", substr (arg, 1, arglen)); return; multics_error: call com_err_ (code, "cancel_cobol_program"); return; multics_arg_error: call com_err_ (code, "cancel_cobol_program", substr (arg, 1, arglen)); return; end cancel_cobol_program;  cobol_FILE_.pl1 05/24/89 1048.6rew 05/24/89 0837.3 71073 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_FILE_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_FILE_: proc; call com_err_ (0, "cobol_FILE_", "For documentation execute:^/ec >udd>LIS>Wardd>pr_doc cobol_FILE_ MPM"); return; IN: entry (cn, n1, n2, opn, p, l, k) returns (bit (1)); p = null (); l = 0; /* Initiate. */ if length (opn) > 0 then if ^gn (n1, n2, opn) then call hcs_$initiate (dn, en, "", 0b, 00b, p, e); if p = null () then do; if gn (n1, n2, "") then return ("1"b); call hcs_$initiate (dn, en, "", 0b, 00b, p, e); end; if p = null () then do; /* Attempt to use names as an initiated segment. */ call hcs_$make_ptr (null (), n1 || n2 || opn, "", p, e); if length (opn) > 0 then if p = null () then call hcs_$make_ptr (null (), n1 || n2, "", p, e); if p ^= null () then call hcs_$fs_get_path_name (p, dn, l1, wen, e); end; if p = null () then do; call com_err_ (e, cn, NAMES ()); return ("1"b); end; call hcs_$status_mins (p, tp, bc, e); if e > 0 then do; call com_err_ (e, cn, (NAMES ())); return ("1"b); end; if k = 0 then do; call com_err_ (0, cn, "Warning,zero divide factor " || NAMES ()); l = -bc; return ("1"b); end; if k < 0 then call com_err_ (0, cn, "Warning, divide factor (^d) negative " || NAMES (), k); if bc < 1 then call com_err_ (0, cn, "Warning, bit-count zero " || NAMES ()); l = divide ((bc + (k - 1)), k, 35, 0); return ("0"b); LEN: entry (cn, n1, n2, l) returns (bit (1)); if gn (n1, n2, "") then return ("1"b); if l < 0 then call hcs_$delentry_file (dn, en, e); else do; call hcs_$set_bc (dn, en, fixed (l, 24), e); if e = 0 then call hcs_$truncate_file (dn, en, divide ((l + 35), 36, 24, 0), e); end; if e > 0 then do; call com_err_ (e, cn, "Attempted bit-count ^d " || NAMES (), l); return ("1"b); end; return ("0"b); SBC: entry (cn, segp, l) returns (bit (1)); if l < 0 then call hcs_$delentry_seg (segp, e); else call hcs_$set_bc_seg (segp, fixed (l, 24), e); if e > 0 then do; /* Obtain the segment's pathname. */ call hcs_$fs_get_path_name (segp, dn, l1, en, e); call com_err_ (e, cn, "Attempted to set bi ^d " || NAMES (), l); return ("1"b); end; return ("0"b); OUT: entry (cn, n1, n2, opn, p) returns (bit (1)); p = null (); if gn (n1, n2, "") then return ("1"b); do l1 = 1 to length (opn); /* Verify that access is acceptable characters. */ l2 = index ("rewa", substr (opn, l1, 1)); if l2 < 1 then do; call com_err_ (0, cn, "Parameter 4, access must be letters from ""rewa"", (""^a"").", opn); return ("1"b); end; substr (mode, (l2 + 1), 1) = "1"b; end; call hcs_$make_seg (dn, en, "", fixed (mode, 5), p, e); if p ^= null () then do; call hcs_$truncate_file (dn, en, 0, e); call hcs_$set_bc (dn, en, 0, e); end; if p = null () then do; call com_err_ (e, cn, (NAMES ())); return ("1"b); end; call hcs_$acl_add1 (dn, en, "*.*.*", 01100b, rbc, e); return ("0"b); PROC: entry (cn, n1, n2, p) returns (bit (1)); p = null (); SN = n1 || n2; EN = ""; DN = ""; i = index (SN, "$"); if i > 0 then do; /* Specific entry name. */ EN = substr (SN, (i + 1), (length (SN) - i)); SN = substr (SN, 1, (i - 1)); end; /* Isolate segment name from directory. */ do i = length (SN) to 1 by -1 while ((substr (SN, i, 1) ^= ">") & (substr (SN, i, 1) ^= "<")); end; if i > 0 then do; /* More than a segment name input. */ DN = substr (SN, 1, i); SN = substr (SN, (i + 1), (length (SN) - i)); end; if length (EN) < 1 then EN = SN; /* Entry name, if not specific. */ /* Establish calling directory. */ dp = null (); if length (DN) > 0 then if ^gn ((DN), (SN), "") then call hcs_$initiate (dn, en, "", 0b, 00b, dp, e); call hcs_$make_ptr (dp, (SN), (EN), p, e); if e > 0 then do; call com_err_ (e, cn, "Could not obtain pointer to an entry from name ""^a^a""", n1, n2); return ("1"b); end; return ("0"b); /* Internal procedures. */ gn: proc (n1, n2, opn) returns (bit (1)); /* Obtain directory name in dn and entry name in en. */ if length (n1) > 0 then N = n1 || n2 || opn; else do; call cobol_set_pdir (N); N = N || ">" || n2 || opn; end; call expand_path_ (addrel (addr (N), 1), length (N), addr (dn), addr (en), e); if e > 0 then do; if length (opn) > 0 then call com_err_ (e, cn, "for (""^a"",""^a"",[""^a""]).", n1, n2, opn); else call com_err_ (e, cn, "for (""^a"",""^a"").", n1, n2); return ("1"b); end; return ("0"b); dcl (n1, n2, opn) char (*) parm; dcl N char (256) var; end gn; NAMES: proc returns (char (256) var); l1 = index (en, " "); if l1 < 1 then l1 = 33; else l1 = l1 - 1; l2 = index (dn, " "); if l2 < 1 then l2 = 169; else l2 = l2 - 1; r = "Segment """ || substr (en, 1, l1) || """ in directory """ || substr (dn, 1, l2) || """."; return (r); dcl r char (256) var; end NAMES; /* Declarations for variables. */ dcl ( cn, /* Caller's name. */ n1, /* Name left part. */ n2, /* Name right part. */ opn /* Name right optional part (| access mode. */ ) char (*) parm, segp ptr parm, /* Input pointer. */ p ptr parm, /* Output pointer. */ l fixed bin (35) parm, /* Output length. */ k fixed bin (35) parm, /* Bit-count divide constant. */ (l1, l2) fixed bin (35), bc fixed bin (24), tp bin (2), e fixed bin (35), /* Error code. */ com_err_ entry options (variable) ext, mode bit (5) aligned init ("00000"b), dn char (169), (en, wen) char (33); dcl (addr, addrel, null, substr, index, length) builtin; dcl expand_path_ entry (ptr, fixed bin (35), ptr, ptr, fixed bin (35)) ext, hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)) ext, hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)) ext, hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)) ext, hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)) ext, hcs_$delentry_file entry (char (*), char (*), fixed bin (35)) ext, hcs_$delentry_seg entry (ptr, fixed bin (35)) ext, hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)) ext, hcs_$truncate_seg entry (ptr, fixed bin (35), fixed bin (35)) ext, hcs_$truncate_file entry (char (*), char (*), fixed bin (35), fixed bin (35)) ext, hcs_$fs_get_path_name entry (ptr, char (*), fixed bin (35), char (*), fixed bin (35)) ext, hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)) ext; dcl hcs_$acl_add1 entry (char (*), char (*), char (*), fixed bin (5), (3) fixed bin (6), fixed bin (35)) ext; dcl rbc (3) fixed bin (6) init (4, 4, 4) static internal; dcl cobol_set_pdir entry (char (*) var) ext; dcl SN char (256) var; dcl EN char (32) var; dcl DN char (168) var; dcl i fixed bin (35); dcl dp ptr; end cobol_FILE_;  cobol_FP_.pl1 05/24/89 1048.6rew 05/24/89 0837.3 19134 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_FP_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_FP_: proc (p) returns (char (16) var); /* Format the contents of pointer "p". */ S = O (fixed (s, 36)) || "|" || O (fixed (w, 36)); if fixed (b, 36) > 0 then S = S || "(" || O (fixed (b, 36)) || ")"; return ((S)); dcl p ptr parameter, 1 ovlp aligned based (addr (p)), 2 s bit (18) unaligned, /* Segment number. */ 2 nu1 bit (12) unaligned, /* Not used. */ 2 its bit (6) unaligned, /* ITS. */ 2 w bit (18) unaligned, /* Word offset. */ 2 nu2 bit (2) unaligned, /* Not used. */ 2 b bit (7) unaligned, /* Bit offset. */ 2 nu3 bit (3) unaligned, /* Not used. */ 2 nu4 bit (6) unaligned, /* Not used. */ S char (16) var, addr builtin; O: proc (v) returns (char (16) var); /* Return v a octal numeric. */ if v = 0 then R = "0"; else do; bz = 0; lv = v; R = ""; do while (lv > 0); unspec (c) = substr (bit ((mod (lv, 8) + bz), 9), 1, 9); R = c || R; lv = lv / 8; end; end; return (R); dcl v fixed bin parameter, (lv, bz) fixed bin, c char (1), R char (16) var, (mod, bit) builtin; end O; end cobol_FP_;  cobol_MSORT_.pl1 05/24/89 1048.6rew 05/24/89 0837.3 59103 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_MSORT_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_MSORT_: proc; /* Version 2. */ /* cobol_MSORT_ (a special version of SORT) inputs three data structures and a comparison procedure. The "records" specified by the data structures are sorted according to the comparison procedure and moved into the "next" merge storage areas (three similar data structures). The array I (based on SIp) contains SIi entries. Each value in I is the index to a row in R (based on SRp). Each row of R contains two values, a first bit and the number of bits in a "record" located in the S string (based on SSp). The records are sorted according to the procedure pointed to by "cmp". The result is stored in an R table and S string, in a sorted order, based on the pointers "rp" and "sp". A row in the I array (based on MIp) contains the number of records for the "next" merge string. */ i = cobol_SM_$MIi + 1; /* Count the merge strings. */ if i > cobol_SM_$max4 then do; cobol_SM_$ec = 4; signal condition (SORTM_STOP); end; /* Create the next merge string R and S segments. */ if cobol_FILE_$OUT ("cobol_MSORT_", (cobol_SM_$sort_dir), "SRTM.MR." || cobol_NUMS_ (i), "rwa", rp) | cobol_FILE_$OUT ("cobol_MSORT_", (cobol_SM_$sort_dir), "SRTM.MS." || cobol_NUMS_ (i), "rwa", sp) then do; cobol_SM_$ec = 5; signal condition (SORTM_STOP); end; if i = 1 then cmpe = cobol_SM_$cmp; /* Assign the comparison procedure at the first call. */ cobol_SM_$MIi = i; cobol_SM_$MIp -> I (i) = cobol_SM_$SIi; /* The number of "records" in the "next" merge store. */ cobol_SM_$MRp (i) = rp; /* Pointer to "next" merge R table. */ cobol_SM_$MSp (i) = sp; /* Pointer to "next" merge S string. */ /* calculate the lengths of lists and their start pointers in a linear set. */ t = 0; l = cobol_SM_$SIi; do n = 1 by 1 while (l > 1); cobol_SM_$s (n) = t; /* start of the next list. */ if substr (unspec (l), 36, 1) then l = l + 1; /* make the length even. */ t = t + l; /* accumulate the lengths. */ l = l / 2; /* next list is 1/2 the length of the present list. */ end; n = n - 1; /* fill in all lists. */ do i = 2 to n; lft = cobol_SM_$s (i - 1); rit = cobol_SM_$s (i); do j = 1 by 2 to (rit - lft); x = lft + j; v1 = cobol_SM_$SIp -> I (x); v2 = cobol_SM_$SIp -> I (x + 1); if v2 > 0 then do; cobol_SM_$fb1 = cobol_SM_$SRp -> R.pt (v1); cobol_SM_$bl1 = cobol_SM_$SRp -> R.ln (v1); cobol_SM_$fb2 = cobol_SM_$SRp -> R.pt (v2); cobol_SM_$bl2 = cobol_SM_$SRp -> R.ln (v2); call cmpe; if cobol_SM_$result > 0 then v1 = v2; end; rit = rit + 1; cobol_SM_$SIp -> I (rit) = v1; end; end; /* calculate the list of pointers in o */ y = cobol_SM_$s (n) + 1; do i = 1 to cobol_SM_$SIi; v1 = cobol_SM_$SIp -> I (y); v2 = cobol_SM_$SIp -> I (y + 1); if (v1 = 0) & (v2 = 0) then i = cobol_SM_$SIi + 1; /* End "i" loop. */ else do; if v1 = 0 then v1 = v2; else if v2 > 0 then do; cobol_SM_$fb1 = cobol_SM_$SRp -> R.pt (v1); cobol_SM_$bl1 = cobol_SM_$SRp -> R.ln (v1); cobol_SM_$fb2 = cobol_SM_$SRp -> R.pt (v2); cobol_SM_$bl2 = cobol_SM_$SRp -> R.ln (v2); call cmpe; if cobol_SM_$result > 0 then v1 = v2; end; /* Move the next sorted record to the merge string. */ l = cobol_SM_$SRp -> R.ln (v1); substr (sp -> S, ns, l) = substr (cobol_SM_$SSp -> S, cobol_SM_$SRp -> R.pt (v1), l); np = np + 1; rp -> R.pt (np) = ns; /* Location of merge record. */ rp -> R.ln (np) = l; /* The length of the merge record. */ ns = ns + l; cobol_SM_$SIp -> I (v1) = 0; /* delete the last winner. */ do j = 2 to n; /* get the next winner. */ lft = cobol_SM_$s (j - 1); if substr (unspec (v1), 36, 1) then v2 = v1 + 1; else v2 = v1 - 1; x = (v1 + 1) / 2; v1 = cobol_SM_$SIp -> I (v1 + lft); v2 = cobol_SM_$SIp -> I (v2 + lft); if v1 = 0 then v1 = v2; else if v2 > 0 then do; cobol_SM_$fb1 = cobol_SM_$SRp -> R.pt (v1); cobol_SM_$bl1 = cobol_SM_$SRp -> R.ln (v1); cobol_SM_$fb2 = cobol_SM_$SRp -> R.pt (v2); cobol_SM_$bl2 = cobol_SM_$SRp -> R.ln (v2); call cmpe; if cobol_SM_$result > 0 then v1 = v2; end; cobol_SM_$SIp -> I (x + cobol_SM_$s (j)) = v1; v1 = x; end; end; end; dcl ( cobol_SM_$SIp, cobol_SM_$SSp, cobol_SM_$MIp, cobol_SM_$MRp (1000), cobol_SM_$MSp (1000), cobol_SM_$SRp ) ptr ext, ( cobol_SM_$SIi, cobol_SM_$s (36), cobol_SM_$ec, cobol_SM_$fb1, cobol_SM_$fb2, cobol_SM_$bl1, cobol_SM_$bl2, cobol_SM_$result, cobol_SM_$max4, cobol_SM_$MIi ) fixed bin (35) ext, cobol_SM_$sort_dir char (168) var ext, cobol_SM_$cmp entry variable ext, (sp, rp) ptr, S bit (2359296) aligned based, I (65536) fixed bin (35) aligned based, 1 R (32768) aligned based, 2 pt fixed bin (35), 2 ln fixed bin (35), cobol_NUMS_ entry (fixed bin (35)) ext returns (char (13) var), cobol_FILE_$OUT entry (char (*), char (*), char (*), char (*), ptr) ext returns (bit (1)), cmpe entry variable static internal, SORTM_STOP condition ext, ( ns init (1), np init (0) ) fixed bin (35), (t, n, v1, v2, l, x, j, y, lft, rit, i) fixed bin (35) static internal; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ end cobol_MSORT_;  cobol_NUMS_.pl1 05/24/89 1048.6rew 05/24/89 0837.3 13563 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_NUMS_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_NUMS_: proc (v) returns (char (13) var); /* Return "v" as an un-padded numeric string. */ if v = 0 then return ("0"); if v < 0 then t = -v; else t = v; do while (t > 0); r = d (mod (t, 10)) || r; t = divide (t, 10, 35, 0); end; if v < 0 then r = "-" || r; return (r); dcl (t, v) fixed bin (35), r char (13) var aligned init (""), d (0:9) char (1) static internal init ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9"), (mod, divide) builtin; end cobol_NUMS_;  cobol_RELEASE_.pl1 05/24/89 1048.6rew 05/24/89 0837.3 43983 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_RELEASE_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_RELEASE_: proc; /* Version 2. */ /* Input records while "l">0, then sort. */ cobol_SM_$disaster1 = cobol_SM_$disaster1 + 1; if cobol_SM_$disaster1 > 1 then do; /* cobol_RELEASE_ called twice after cobol_SM_$disaster1. */ cobol_SM_$ec = 1; signal condition (SORTM_STOP); end; if cobol_SM_$RELbl > 0 then do; /* Input call. */ if cobol_SM_$RELbl > cobol_SM_$max1 then do; cobol_SM_$ec = 2; signal condition (SORTM_STOP); end; if cobol_SM_$SSi = 0 then do; /* This is the initial call to cobol_RELEASE_. */ if cobol_FILE_$OUT ("SORTM_", (cobol_SM_$sort_dir), "SRTM.SI", "rwa", cobol_SM_$SIp) | cobol_FILE_$OUT ("SORTM_", (cobol_SM_$sort_dir), "SRTM.SR", "rwa", cobol_SM_$SRp) | cobol_FILE_$OUT ("SORTM_", (cobol_SM_$sort_dir), "SRTM.SS", "rwa", cobol_SM_$SSp) | cobol_FILE_$OUT ("SORTM_", (cobol_SM_$sort_dir), "SRTM.MI", "rwa", cobol_SM_$MIp) then do; cobol_SM_$ec = 3; signal condition (SORTM_STOP); end; cobol_SM_$MIi = 0; cobol_SM_$SSi = 1; cobol_SM_$SIi = 0; cobol_SM_$rp1 = cobol_SM_$SSp; cobol_SM_$rp2 = cobol_SM_$SSp; cobol_SM_$sn1 = 1; /* Durning sort the merge string number is 1. */ cobol_SM_$sn2 = 1; end; if ((cobol_SM_$RELbl + cobol_SM_$SSi) > cobol_SM_$max2) | (cobol_SM_$SIi > cobol_SM_$max3) then do; /* Sort the accumulated records. */ call cobol_MSORT_; /* cobol_SM_$LTSIi=cobol_SM_$TSIi; */ /* One less than the first record to be sorted _n_e_x_t. */ /* Initialize the sort tables for next input. */ cobol_SM_$SIi = 0; cobol_SM_$SSi = 1; if cobol_FILE_$LEN ("cobol_RELEASE_", (cobol_SM_$sort_dir), "SRTM.SI", 0) then ; /* Assure file truncated. */ end; /* Move the input record into the sort storage area. */ substr (cobol_SM_$SSp -> S, cobol_SM_$SSi, cobol_SM_$RELbl) = substr (input_rec, cobol_SM_$RELfb, cobol_SM_$RELbl); cobol_SM_$SIi = cobol_SM_$SIi + 1; /* Count of the records for the next sort. */ /* cobol_SM_$TSIi=cobol_SM_$TSIi+1; */ /* Total record count. */ cobol_SM_$SRp -> R.pt (cobol_SM_$SIi) = cobol_SM_$SSi; /* Location in sort storage segment of the record. */ cobol_SM_$SRp -> R.ln (cobol_SM_$SIi) = cobol_SM_$RELbl; /* The length of the record. */ cobol_SM_$SSi = cobol_SM_$SSi + cobol_SM_$RELbl; /* Update the next location available in the sort storage segment. */ cobol_SM_$SIp -> I (cobol_SM_$SIi) = cobol_SM_$SIi; /* Record index for sort. */ cobol_SM_$disaster1 = 0; return; end; /* All records have been input. Sort those in storage. Ready for merge output. */ call cobol_MSORT_; return; /* Global declarations. */ dcl input_rec bit (2359296) based (cobol_SM_$RELp), cobol_FILE_$LEN entry (char (*), char (*), char (*), fixed bin (35)) ext returns (bit (1)), cobol_FILE_$OUT entry (char (*), char (*), char (*), char (*), ptr) ext returns (bit (1)), SORTM_STOP condition ext, cobol_MSORT_ entry ext, ( cobol_SM_$SIi, cobol_SM_$SSi, cobol_SM_$MIi, cobol_SM_$disaster1, cobol_SM_$TSIi, cobol_SM_$LTSIi, cobol_SM_$sn1, cobol_SM_$sn2, cobol_SM_$RELbl, cobol_SM_$RELfb, cobol_SM_$ec, cobol_SM_$max1, cobol_SM_$max2, cobol_SM_$max3, cobol_SM_$max4 ) fixed bin (35) static external, ( cobol_SM_$SIp, cobol_SM_$SRp, cobol_SM_$SSp, cobol_SM_$rp1, cobol_SM_$rp2, cobol_SM_$RELp, cobol_SM_$MIp, cobol_SM_$MRp (1000), cobol_SM_$MSp (1000) ) ptr static external, cobol_SM_$sort_dir char (168) var static external, /* Based structures for sort and merge storage segments. */ I (65536) fixed bin (35) aligned based, S bit (2359296) aligned based, 1 R (32768) aligned based, 2 pt fixed bin (35), /* Location in S or a record. */ 2 ln fixed bin (35), /* Length of a record. */ (substr) builtin; end cobol_RELEASE_;  cobol_RETURN_.pl1 05/24/89 1048.6rew 05/24/89 0837.2 79992 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_RETURN_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_RETURN_: proc; /* Version 2. */ /* Entry to return records from the SORTM_. */ if cobol_SM_$disaster2 = 0 then do; /* Initial call to cobol_RETURN_. */ cobol_SM_$disaster2 = 1; cmpe = cobol_SM_$mcp; /* Point to the merge comparison procedure. */ call A0; return; end; if cobol_SM_$RETbl < 1 then do; /* Delete all work files. */ cobol_SM_$disaster2 = cobol_SM_$disaster2 + 1; if cobol_SM_$disaster2 > 2 then do; cobol_SM_$ec = 6; signal condition (SORTM_STOP); end; j = cobol_SM_$RETbl; if cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SI", j) | cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SR", j) | cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SS", j) | cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.MI", j) then do; cobol_SM_$ec = 7; signal condition (SORTM_STOP); end; do i = 1 to cobol_SM_$MIi; N = cobol_NUMS_ (i); if cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.MR." || N, j) | cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.MS." || N, j) then do; cobol_SM_$ec = 7; signal condition (SORTM_STOP); end; end; return; end; if cobol_SM_$MIi < 2 then do; /* Single merge string. */ if ns > n then do; cobol_SM_$disaster2 = 2; cobol_SM_$ec = 8; signal condition (SORTM_STOP); end; else do; cobol_SM_$RETp = cobol_SM_$MSp (1); p1 = cobol_SM_$MRp (1); cobol_SM_$RETfb = p1 -> R.pt (ns); cobol_SM_$RETbl = p1 -> R.ln (ns); ns = ns + 1; end; return; end; /* Multiple merge strings. */ call A2; call A1; return; A0: proc; /* SORTM_ return "record" procedure (entry point cobol_RETURN_). */ if cobol_SM_$MIi < 2 then do; /* Single sorted string. */ n = cobol_SM_$MIp -> I (1); /* Number of output records. */ if n < 1 then do; cobol_SM_$ec = 9; signal condition (SORTM_STOP); end; else do; cobol_SM_$RETp = cobol_SM_$MSp (1); p1 = cobol_SM_$MRp (1); cobol_SM_$RETfb = p1 -> R.pt (1); cobol_SM_$RETbl = p1 -> R.ln (1); ns = 2; end; return; end; /* Initialize for multiple merge strings. */ /* Truncate merge work files. */ if (cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SI", 0)) | (cobol_FILE_$LEN ("cobol_RETURN_", (cobol_SM_$sort_dir), "SRTM.SR", 0)) then do; cobol_SM_$ec = 10; signal condition (SORTM_STOP); end; do i = 1 to cobol_SM_$MIi; /* Set indices for merge. */ cobol_SM_$SIp -> I (i) = i; cobol_SM_$SRp -> I (i) = 1; end; /* calculate the lengths of lists and their start pointers in a linear set. */ t = 0; l = cobol_SM_$MIi; do n = 1 by 1 while (l > 1); cobol_SM_$s (n) = t; /* start of the next list. */ if substr (unspec (l), 36, 1) then l = l + 1; /* make the length even. */ t = t + l; /* accumulate the lengths. */ l = l / 2; /* next list is 1/2 the length of the present list. */ end; n = n - 1; /* Set cobol_SM_$s(n) to (one more than) the index to the list for the final 2 records to be compared. */ do i = 2 to n; lft = cobol_SM_$s (i - 1); rit = cobol_SM_$s (i); do j = 1 by 2 to (rit - lft); x = lft + j; v1 = cobol_SM_$SIp -> I (x); v2 = cobol_SM_$SIp -> I (x + 1); if v2 > 0 then do; p1 = cobol_SM_$MRp (v1); p2 = cobol_SM_$MRp (v2); cobol_SM_$sn1 = v1; cobol_SM_$sn2 = v2; cobol_SM_$rp1 = cobol_SM_$MSp (v1); cobol_SM_$rp2 = cobol_SM_$MSp (v2); cobol_SM_$fb1 = p1 -> R.pt (1); cobol_SM_$fb2 = p2 -> R.pt (1); cobol_SM_$bl1 = p1 -> R.ln (1); cobol_SM_$bl2 = p2 -> R.ln (1); call cmpe; if (cobol_SM_$result = 1) | ((cobol_SM_$result = 2) & (v2 < v1)) then v1 = v2; end; rit = rit + 1; cobol_SM_$SIp -> I (rit) = v1; end; end; i = cobol_SM_$s (n) + 2; do i = 1 to i; N = cobol_NUMS_ (cobol_SM_$SIp -> I (i)); end; y = cobol_SM_$s (n) + 1; call A1; return; end A0; A1: proc; /* Obtain the next record to output. */ v1 = cobol_SM_$SIp -> I (y); v2 = cobol_SM_$SIp -> I (y + 1); if (v1 = 0) & (v2 = 0) then do; cobol_SM_$ec = 11; signal condition (SORTM_STOP); cobol_SM_$RETbl = 0; return; end; if v1 = 0 then do; v1 = v2; p1 = cobol_SM_$MRp (v2); i1 = cobol_SM_$SRp -> I (v2); end; else if v2 = 0 then do; p1 = cobol_SM_$MRp (v1); i1 = cobol_SM_$SRp -> I (v1); end; else if v2 > 0 then do; p1 = cobol_SM_$MRp (v1); p2 = cobol_SM_$MRp (v2); i1 = cobol_SM_$SRp -> I (v1); i2 = cobol_SM_$SRp -> I (v2); cobol_SM_$sn1 = v1; cobol_SM_$sn2 = v2; cobol_SM_$rp1 = cobol_SM_$MSp (v1); cobol_SM_$rp2 = cobol_SM_$MSp (v2); cobol_SM_$fb1 = p1 -> R.pt (i1); cobol_SM_$fb2 = p2 -> R.pt (i2); cobol_SM_$bl1 = p1 -> R.ln (i1); cobol_SM_$bl2 = p2 -> R.ln (i2); call cmpe; if (cobol_SM_$result = 1) | ((cobol_SM_$result = 2) & (v2 < v1)) then do; /* Second record first | Key fields equal but 2-nd merge string earlier. */ v1 = v2; i1 = i2; p1 = p2; end; end; cobol_SM_$RETp = cobol_SM_$MSp (v1); cobol_SM_$RETfb = p1 -> R.pt (i1); cobol_SM_$RETbl = p1 -> R.ln (i1); return; end A1; A2: proc; /* Delete last record output. */ i = cobol_SM_$SRp -> I (v1) + 1; if i > cobol_SM_$MIp -> I (v1) then cobol_SM_$SIp -> I (v1) = 0; /* v1-th string depleted. */ cobol_SM_$SRp -> I (v1) = i; /* Update the index to which record is next in the v1-th string. */ do j = 2 to n; lft = cobol_SM_$s (j - 1); if substr (unspec (v1), 36, 1) then v2 = v1 + 1; else v2 = v1 - 1; x = (v1 + 1) / 2; v1 = cobol_SM_$SIp -> I (v1 + lft); v2 = cobol_SM_$SIp -> I (v2 + lft); if v1 = 0 then v1 = v2; else if v2 > 0 then do; p1 = cobol_SM_$MRp (v1); p2 = cobol_SM_$MRp (v2); i1 = cobol_SM_$SRp -> I (v1); i2 = cobol_SM_$SRp -> I (v2); cobol_SM_$sn1 = v1; cobol_SM_$sn2 = v2; cobol_SM_$rp1 = cobol_SM_$MSp (v1); cobol_SM_$rp2 = cobol_SM_$MSp (v2); cobol_SM_$fb1 = p1 -> R.pt (i1); cobol_SM_$fb2 = p2 -> R.pt (i2); cobol_SM_$bl1 = p1 -> R.ln (i1); cobol_SM_$bl2 = p2 -> R.ln (i2); call cmpe; if (cobol_SM_$result = 1) | ((cobol_SM_$result = 2) & (v2 < v1)) then v1 = v2; end; cobol_SM_$SIp -> I (x + cobol_SM_$s (j)) = v1; v1 = x; end; end A2; dcl ( cobol_SM_$SIp, cobol_SM_$MIp, cobol_SM_$rp1, cobol_SM_$rp2, cobol_SM_$RETp, cobol_SM_$MRp (1000), cobol_SM_$MSp (1000), cobol_SM_$SRp ) ptr ext, ( cobol_SM_$disaster2, cobol_SM_$s (36), cobol_SM_$sn1, cobol_SM_$sn2, cobol_SM_$fb1, cobol_SM_$fb2, cobol_SM_$bl1, cobol_SM_$bl2, cobol_SM_$result, cobol_SM_$RETfb, cobol_SM_$RETbl, cobol_SM_$ec, cobol_SM_$MIi ) fixed bin (35) ext, cobol_SM_$sort_dir char (168) var ext, cobol_SM_$mcp entry variable ext, S bit (2359296) aligned based, I (65536) fixed bin (35) aligned based, 1 R (32768) aligned based, 2 pt fixed bin (35), 2 ln fixed bin (35), N char (13) var, cobol_NUMS_ entry (fixed bin (35)) ext returns (char (13) var), cobol_FILE_$LEN entry (char (*), char (*), char (*), fixed bin (35)) ext returns (bit (1)), cobol_FILE_$OUT entry (char (*), char (*), char (*), char (*), ptr) ext returns (bit (1)), cmpe entry variable internal static, SORTM_STOP condition ext, (p1, p2) ptr, (t, n, v1, v2, i1, i2, l, x, j, y, ns, np, lft, rit, i) fixed bin (35) static internal; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ end cobol_RETURN_;  cobol_SET_.pl1 05/24/89 1048.6rew 05/24/89 0837.1 62550 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_SET_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_SET_: proc; /* Versiin 2. */ /* Set or print control variables for SORTM_. */ Lp = addrel (addr (L), 1); call cu_$arg_count (i); if i < 1 then do; L = "cobol_SET_ S S ... Each S is a string: name=value (no spaces). Name from {sort_dir,disaster1,disaster2,SIi,SSi,MIi,max1,max2,max3,max4}. Value is an integer except for sort_dir it is a string."; L = L || " If S is ""default"" (only) the values are set to their default values. If S is ""print"" (only) the current values are printed. "; /* call ios_$write_ptr(Lp,0,length(L)); */ return; end; do j = 1 to i; call cu_$arg_ptr (j, p, l, e); if e > 0 then do; call com_err_ (e, "cobol_SET_", " Could not obtain parameter ^d.", j); return; end; if arg = "print" then do; L = " SORTM_ values " || substr (L, 2, 24) || " sort_dir=""" || cobol_SM_$sort_dir || """ "; L = L || "disaster1=" || cobol_NUMS_ (cobol_SM_$disaster1) || " disaster2=" || cobol_NUMS_ (cobol_SM_$disaster2) || " SIi=" || cobol_NUMS_ (cobol_SM_$SIi) || " SSi=" || cobol_NUMS_ (cobol_SM_$SSi) || " MIi=" || cobol_NUMS_ (cobol_SM_$MIi) || " TSIi=" || cobol_NUMS_ (cobol_SM_$TSIi) || " LTSIi=" || cobol_NUMS_ (cobol_SM_$LTSIi) || " max1=" || cobol_NUMS_ (cobol_SM_$max1) || " max2=" || cobol_NUMS_ (cobol_SM_$max2) || " max3=" || cobol_NUMS_ (cobol_SM_$max3) || " max4=" || cobol_NUMS_ (cobol_SM_$max4) || " "; call FME (cobol_SM_$cmp, "cmp"); call FME (cobol_SM_$mcp, "mcp"); L = L || "SIp=" || cobol_FP_ (cobol_SM_$SIp) || " SRp=" || cobol_FP_ (cobol_SM_$SRp) || " SSp=" || cobol_FP_ (cobol_SM_$SSp) || " MIp=" || cobol_FP_ (cobol_SM_$MIp) || " "; /* call ios_$write_ptr(Lp,0,length(L)); */ end; else if arg = "default" then do; cobol_SM_$sort_dir = ""; cobol_SM_$disaster1 = 0; cobol_SM_$disaster2 = 0; cobol_SM_$SSi = 0; cobol_SM_$SIi = 0; cobol_SM_$MIi = 0; cobol_SM_$max1 = 64 * 1024 * 36; cobol_SM_$max2 = cobol_SM_$max1; cobol_SM_$max3 = 30000; cobol_SM_$max4 = 1000; end; else do; k = index (arg, "="); if k < 1 then call err ("contains no ""=""."); else do; m = index (/* . 1 2 3 4 5 6 7 8 9 .1 9 18 27 30 33 36 40 44 48 */ "sort_dirdisaster1disaster2SIiSSiMIimax1max2max3max4", substr (arg, 1, (k - 1))); if m < 1 then call err ("not a known name."); else do; if m = 1 then cobol_SM_$sort_dir = substr (arg, (k + 1), (l - k)); else call set_val; end; end; end; end; return; CPP: entry (PT, PT2); /* Save the pointer, "p", to the comparison procedure. */ call cu_$arg_count (i); if (i < 1) | (i > 2) then do; call com_err_ (0, "CPP", " Pointer to comparison procedure required."); return; end; cobol_SM_$cmp = PT; if i = 2 then cobol_SM_$mcp = PT2; cobol_SM_$sort_dir = ""; cobol_SM_$disaster1 = 0; cobol_SM_$disaster2 = 0; cobol_SM_$SSi = 0; cobol_SM_$SIi = 0; cobol_SM_$MIi = 0; cobol_SM_$max1 = 64 * 1024 * 36; cobol_SM_$max2 = cobol_SM_$max1; cobol_SM_$max3 = 30000; cobol_SM_$max4 = 1000; return; FME: proc (e, n); /* Format entry "e" named "n". */ if p2 = null () then do; L = L || n || "=(ext proc)" || cobol_FP_ (p1) || " "; end; else do; L = L || n || "=(int proc)" || cobol_FP_ (p1) || "(in)" || cobol_FP_ (p2) || " "; end; return; dcl e entry parm, n char (*) parm, 1 E aligned based (addr (e)), 2 p1 ptr, 2 p2 ptr, null builtin; end FME; set_val: proc; /* Convert the "value" part of the argument and load the specified variable. */ /* Convert the numeric string (unsigned). */ v = 0; do k = (k + 1) to l; c = substr (arg, k, 1); if (c < "0") | (c > "9") then do; call err ("contains non-numeric character """ || c || """ in the numeric value field."); return; end; v = (v * 10) + fixed (c, 9) - 0; end; /* Load the value. */ goto set (red (m)); set (0): call err ("unknown name."); return; set (1): cobol_SM_$disaster1 = v; return; set (2): cobol_SM_$disaster2 = v; return; set (3): cobol_SM_$SIi = v; return; set (4): cobol_SM_$SSi = v; return; set (5): cobol_SM_$MIi = v; return; set (6): cobol_SM_$max1 = v; return; set (7): cobol_SM_$max2 = v; return; set (8): cobol_SM_$max3 = v; return; set (9): cobol_SM_$max4 = v; return; end set_val; err: proc (message); L = "cobol_SET_: Parameter " || cobol_NUMS_ (j) || ", """ || arg || """, " || message || " "; /* call ios_$write_ptr(Lp,0,length(L)); */ return; dcl message char (*); end err; dcl (PT, PT2) entry parm, (Lp, p) ptr, L char (1000) var, cu_$arg_count entry (fixed bin (35)) ext, cu_$arg_ptr entry (fixed bin (35), ptr, fixed bin (35), fixed bin (35)) ext, /* ios_$write_ptr entry(ptr,fixed bin(35),fixed bin(35)) ext, */ com_err_ entry options (variable) ext, cobol_NUMS_ entry (fixed bin (35)) ext returns (char (13) var), cobol_FP_ entry (ptr) ext returns (char (16) var), (i, j, k, m, l, e, v) fixed bin (35), red (51) fixed bin (35) static internal init ((8) 0, 1, (8) 0, 2, (8) 0, 3, (2) 0, 4, (2) 0, 5, (2) 0, 6, (3) 0, 7, (3) 0, 8, (3) 0, 9, (3) 0), arg char (l) unaligned based (p), c char (1) aligned, (unspec, substr, index, length) builtin, /* Static external (bindable as internal). */ ( cobol_SM_$cmp, cobol_SM_$mcp ) entry variable ext, ( cobol_SM_$SIp, cobol_SM_$SRp, cobol_SM_$SSp, cobol_SM_$MIp ) ptr ext, ( cobol_SM_$SIi, cobol_SM_$SSi, cobol_SM_$MIi, cobol_SM_$TSIi, cobol_SM_$LTSIi, cobol_SM_$max1, cobol_SM_$max2, cobol_SM_$max3, cobol_SM_$max4, cobol_SM_$disaster2, cobol_SM_$disaster1 ) fixed bin (35) ext, cobol_SM_$sort_dir char (168) var ext; end cobol_SET_;  cobol_SM_.alm 11/11/82 1550.1rew 11/11/82 1030.7 16794 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " cobol_SM_ " External data for SORTM facility. " Bindable as static internal. " Modified July 1981 to avoid zero pages in the object segment " Benson I. Margulies. name cobol_SM_ use textc use linkc join /link/linkc join /text/textc use linkc macro null_pointer even segdef &1 &1: dup &2 its -1,1 dupend &end " cobol_SM$... entry. null_pointer cmp,3 null_pointer mcp,3 " cobol_SM$... ptr. null_pointer SIp,1 null_pointer SRp,1 null_pointer SSp,1 null_pointer MIp,1 null_pointer rp1,1 null_pointer rp2,1 null_pointer stat_ptr,1 null_pointer error_ptr,1 null_pointer RELp,1 null_pointer RETp,1 null_pointer MRp,1000 null_pointer MSp,1000 " cobol_SM$... fixed bin(35). segdef SIi bss SIi,1 segdef SSi bss SSi,1 segdef MIi bss MIi,1 segdef TSIi bss TSIi,1 segdef LTSIi bss LTSIi,1 segdef max1 bss max1,1 segdef max2 bss max2,1 segdef max3 bss max3,1 segdef max4 bss max4,1 segdef ec bss ec,1 segdef disaster1 bss disaster1,1 segdef disaster2 bss disaster2,1 segdef sn1 bss sn1,1 segdef sn2 bss sn2,1 segdef fb1 bss fb1,1 segdef fb2 bss fb2,1 segdef bl1 bss bl1,1 segdef bl2 bss bl2,1 segdef result bss result,1 segdef RELbl bss RELbl,1 segdef RELfb bss RELfb,1 segdef RETfb bss RETfb,1 segdef RETbl bss RETbl,1 segdef s bss s,36 " cobol_SM$... char var. segdef sort_dir bss sort_dir,43 end  cobol_SORTM_.pl1 05/24/89 1048.6rew 05/24/89 0837.1 16587 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_SORTM_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_SORTM_: proc; /*cobol_SORTM_ is a sort and merge facility. Procedures (SET, CPP, RELEASE & RETURN) provide for establishing the pointer to a comparison procedure, inputting records and returning the records in a sorted order. */ L = "cobol_SORTM_ is a sort and merge facility. Procedures (SET, CPP, RELEASE & RETURN) provide for establishing the pointer to a comparison procedure, inputting records and returning the"; L = L || " records in a sorted order. ec >udd>LIS>Wardd>pr_runoff SORTM will print documentation. "; /* call ios_$write_ptr(addrel(addr(L),1),0,length(L)); */ return; dcl L char (400) var, /* ios_$write_ptr entry(ptr,fixed bin(35),fixed bin(35)) ext, */ (addr, length, addrel) builtin; end cobol_SORTM_;  cobol_blank_stripper_.pl1 05/24/89 1048.6rew 05/24/89 0837.0 29475 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_blank_stripper_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 03/06/81 by FCH, [4.4-1], last line not processed unless ends in c.r. char, BUG469(TR9264) */ /* Modified on 10/03/79 by FCH, [4.0-1], ID field ignored */ /* Created for Version 4.1 by FCH */ /* format: style3 */ cobol_blank_stripper_: proc (in_ptr, out_ptr, bc); dcl (to_offset, from_offset, ret_loc, i, line_size) fixed bin (35); dcl (non_blank, quotct) fixed bin (35); dcl l_num fixed bin; dcl bc fixed bin (24); dcl (code, cct, rct) fixed bin (35); dcl (argptr, l_ptr, in_ptr, out_ptr) ptr; dcl ch char (1); dcl (divide, index, addr, substr) builtin; declare program char (cct) based (in_ptr); declare prog_array (cct) char (1) based (in_ptr); declare rest_prog char (rct) based (l_ptr); declare ln (ret_loc) char (1) based (l_ptr); cct = divide (bc, 9, 31, 0); to_offset, from_offset = 1; do while ("1"b); if from_offset > cct then do; bc = to_offset * 9 - 9; return; end; rct = cct - from_offset + 1; l_ptr = addr (prog_array (from_offset)); ret_loc = index (rest_prog, " "); if ret_loc <= 0 then do; /*[4.4-1]*/ ret_loc = rct + 1; /*[4.4-1]*/ call scan; bc = to_offset * 9 - 9; return; end; /*[4.4-1]*/ call scan; end; /*[4.4-1]*/ scan: proc; ret_loc = ret_loc - 1; if ret_loc < 8 then call move (ret_loc, ret_loc); else /*[4.0-1]*/ line_size = ret_loc; /*[4.0-1]*/ if ret_loc = 80 then ret_loc = 72; if ln (7) ^= " " /*[4.0-1]*/ then call move (ret_loc, line_size); else do; quotct = 1; non_blank = 0; do i = ret_loc by -1 to 8; ch = ln (i); if ch = """" then quotct = -quotct; if non_blank = 0 then if ch ^= " " then non_blank = i; end; if non_blank = 0 then call move (7, line_size); else if quotct < 0 /*[4.0-1]*/ then call move (ret_loc, line_size); /*[4.0-1]*/ else call move (non_blank, line_size); end; end; move: proc (to_size, from_size); declare (to_size, from_size) fixed bin (35); substr (out_ptr -> program, to_offset, to_size + 1) = substr (in_ptr -> program, from_offset, to_size) || " "; to_offset = to_offset + to_size + 1; from_offset = from_offset + from_size + 1; end; end;  cobol_control_.pl1 05/24/89 1048.6rew 05/24/89 0836.9 270612 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8090 cobol_control_.pl1 Disallow duplicate prime keys in Indexed Sequential files. END HISTORY COMMENTS */ /* Modified on 12/19/84 by FCH, [5.3-1], BUG573(phx16343), cobol_fsb_type_1.incl.pl1 now used */ /* Modified on 11/30/82 by FCH, [5.2-1], delete handlers for error and command_abort_, BUG545(phx14322) */ /* Modified on 09/08/81 by FCH, [5.0-1], rc fails if abs path name used, BUG499(phx11416) */ /* Modified on 06/09/81 by FCH, [4.4-2], cu_$cp used instead of cu_$ptr_call, BUG468 */ /* Modified on 10/24/80 by PRP, [4.4-1], bug451 phx07665 fix close with lock on internal files*/ /* Modified on 07/17/79 by PRP, [4.0-2], -db option added to rc, it sets sw 8*/ /* Modified on 06/14/79 by PRP, [4.0-2], output of detach messages eliminated except when scr is used */ /* Modified on 05/24/79 by FCH, [4.0-1], cobol_control_seg_ replaced by temp seg */ /* Modified on 01/22/79 by FCH, [3.0-1], on statements used */ /* Modified since Version 3.0 */ /* { */ /* format: style3 */ cobol_control_: proc (pr4_save_ptr); /* This is a run-time support routine which provides for getting space for all cobol programs. It also maintains a record of programs which are part of the current run-unit. */ dcl control_1 fixed bin; /* 1 = called by cobol_rts_; 0 = called directly by cobol program */ call cu_$stack_frame_ptr (stack_frame_ptr); stack_frame_ptr = stack_frame.prev_stack_frame_ptr; control_1 = 0; call start; return; /* Entry for the new control to interface with cobol_rts_ package. */ cobol_rts_control_: entry (pr4_save_ptr); call cu_$stack_frame_ptr (stack_frame_ptr); stack_frame_ptr = stack_frame.prev_stack_frame_ptr; control_1 = 1; call start; return; dcl pr4_save_ptr ptr parameter; dcl statptr ptr parameter; /* statptr a pointer to the calling program's static data area. See the include file stat.inc.pl1 } */ declare (stop_run, command_abort_, error, finish) condition; /* [3.0-1] */ /*[4.0-1]*/ dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); /*[4.0-1]*/ dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); /*[4.0-1]*/ dcl tp (1) ptr static int; dcl 1 cond based (cond_ptr), 2 next_ptr ptr, 2 action_ptr ptr, 2 action_len fixed bin (21), 2 cont fixed bin, 2 name char (32), 2 action char (0 refer (cond.action_len)); dcl mcode fixed bin (35); dcl close_code fixed bin (35); dcl stop_code fixed bin; dcl (i, j, k, m, n) fixed bin; dcl (jlen, klen) fixed bin; dcl (nargs, bl_pos, dlr_pos) fixed bin; dcl len fixed bin; dcl (arglen, arg1_len) fixed bin (21); dcl rwds fixed bin; dcl continue fixed bin; dcl bc fixed bin (21); dcl stop_run_command static bit (1); dcl stop_run_sw bit (1) static init ("0"b); dcl found bit (1); dcl others_found bit (1); dcl rseg char (rwds) based (rsegptr); dcl nl char (1) static init (" "); dcl dir char (168); dcl error_name char (3); dcl name1 char (32); dcl rname char (32); dcl progname char (32); dcl lineno char (20); dcl cobol_data_area (stat.data_len + 1) fixed bin (35) based; /* 08-26-77 */ /* only need to run pre 3.0 cobol programs */ dcl based_area area based; dcl area_ptr ptr; dcl evar entry auto; dcl bptr ptr based (addr (evar)); dcl arg char (arglen) based (argptr); dcl cond_ptr ptr; dcl (argptr, arg1_ptr) ptr; dcl save_cond_ptr ptr; dcl rsegptr ptr; dcl segptr ptr; dcl error_ptr ptr; dcl iox_$user_output ptr ext; dcl iox_$error_output ptr ext; dcl iox_$user_input ptr ext; dcl condition_ entry (char (*), entry); dcl cobol_rts_handler_ entry (ptr, char (*), ptr, ptr, bit (1)); /*[4.4-2]*/ dcl add_epilogue_handler_ entry (entry, fixed bin (35)); dcl find_command_ entry (ptr, fixed bin (21), ptr, fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl expand_path_ entry (ptr, fixed bin (21), ptr, ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl get_pdir_ entry returns (char (168)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (21), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$fs_get_ref_name entry (ptr, fixed bin, char (*), fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl hcs_$terminate_seg entry (ptr, fixed bin, fixed bin (35)); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl cobol_mcs_$stop_run entry; dcl com_err_ entry options (variable); dcl cobol_error_ entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (65) varying, ptr); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl cobol_file_control_ entry (char (*), ptr, fixed bin, char (*), bit (1) aligned, fixed bin (35)); dcl signal_ entry (char (*), ptr, ptr); dcl cu_$stack_frame_ptr entry (ptr); dcl error_table_$seg_not_found fixed bin (35) static ext; dcl error_table_$noarg fixed bin (35) ext static; dcl error_table_$badopt fixed bin (35) ext static; /* prologue */ start: proc; /*[3.0-1]*/ if controlp = null then call set_handlers (0); /*[5.2-1]*/ /* on command_abort_ call COND ("command_abort_"); */ /*[5.2-1]*/ /* on error call COND ("error"); */ /*[4.0-1]*/ on stop_run call COND ("stop_run"); /*[4.0-1]*/ on finish call COND ("finish"); if control_1 ^= 0 then do; stat_ptr = addrel (pr4_save_ptr, 8); stack_frame_ptr = stack_frame.prev_stack_frame_ptr; end; else stat_ptr = addrel (stack_frame.link_ptr, 8); /* initialize extended fixed_static area if new rts interface */ if control_1 ^= 0 then do; stat.user_output_ptr = iox_$user_output; stat.error_output_ptr = iox_$error_output; stat.user_input_ptr = iox_$user_input; stat.error_con = ""; end; j = index (stat.prog_id, "$"); if j > 0 then do; stat.prog_id_len = stat.prog_id_len - j; progname = substr (stat.prog_id, j + 1); end; else progname = substr (stat.prog_id, 1, stat.prog_id_len); rname = ""; do j = 1 to 1000 /* nominal */ while (rname = ""); if control_1 ^= 0 then call hcs_$fs_get_ref_name (pointer (stack_frame.new_return_ptr, 0), j, rname, mcode); else call hcs_$fs_get_ref_name (pointer (stack_frame.return_ptr, 0), j, rname, mcode); if mcode ^= 0 then go to control_error; end; if rname ^= stat.prog_id then do; j = index (rname, " "); if j = 0 then j = 33; stat.prog_id = substr (rname, 1, j - 1) || "$" || progname; stat.prog_id_len = stat.prog_id_len + j; end; if stat.entry_pt_ptr = control.main_prog_ptr then do; stat.main_prog_sw = 1; control.mpname = substr (stat.prog_id, 1, stat.prog_id_len); end; else do; stat.main_prog_sw = 0; control.mpname = ""; end; if control.no_of_segs > 0 then do i = 1 to control.no_of_segs; if control.statptr (i) = stat_ptr then go to set_data_ptr; if control.statptr (i) ^= null then do; j = index (control.statptr (i) -> stat.prog_id, "$"); if j = 0 then j = control.statptr (i) -> stat.prog_id_len; else j = j - 1; k = index (stat.prog_id, "$"); if k = 0 then k = stat.prog_id_len; else k = k - 1; if substr (control.statptr (i) -> stat.prog_id, 1, j) = substr (stat.prog_id, 1, k) then control.statptr (i) = null (); end; end; else control.name = stat.prog_id; /* set run-unit name */ control.no_of_segs = control.no_of_segs + 1; control.statptr (control.no_of_segs) = stat_ptr; stat.control_ptr = controlp; if sort_dir_len = 0 then do; substr (sort_dir, 1, 168) = get_pdir_ (); sort_dir_len = index (sort_dir, " ") - 1; end; set_data_ptr: if stat.data_len > 0 then if stat.data_ptr = null () then do; area_ptr = ptr (addr (i), 0) -> stack_header.user_free_ptr; allocate cobol_data_area set (stat.data_ptr) in (area_ptr -> based_area); end; end; cobol_stop_run_: entry (statptr, rdsw, rfsw, code); /* This is the entry called by the standard default condition handler for the "stop_run" condition and by the cancel command when the "-all" option is specified. It causes cancellation of every cobol program in the current run-unit. */ dcl rdsw fixed bin; /* retain data segments */ dcl rfsw fixed bin; /* retain files */ /* dcl statptr ptr parameter; statptr a pointer to the calling program's static data area. See the include file stat.incl.pl1 (input). } */ stop_run_command = "0"b; call start_cobol_stop_run; return; cobol_stop_run_command_: entry (statptr, rdsw, rfsw, code); stop_run_command = "1"b; call start_cobol_stop_run; return; /* [4.0-2] */ /* this new entry point was added so that cobol_stop_run_ can tell the difference between a call from command level and an epilogue handler call. thus some messages are suppressed unless there is a stop_cobol_run command. */ start_cobol_stop_run: proc; if statptr ^= null () then error_name = "ccp"; else error_name = "scr"; found = "0"b; if controlp ^= null () then do; if sort_dir_len ^= 0 then call hcs_$delentry_file (substr (sort_dir, 1, sort_dir_len), "cobol_temp_merge_file_", mcode); end; if controlp ^= null () then if control.no_of_segs > 0 then do i = 1 to control.no_of_segs; stat_ptr = control.statptr (i); if stat_ptr ^= null () then do; stat.call_cnt = -1; /* reset initialization switch */ if rfsw = 0 then if stat.file_info_ptr ^= null () then do; call cobol_file_control_ ("-a", stat_ptr, 0, error_name, "1"b, close_code); stat.file_info_ptr = null (); end; if rdsw = 0 then if stat.data_ptr ^= null () then do; if stat.data_len > 0 then free stat.data_ptr -> cobol_data_area; stat.data_ptr = null (); end; found = "1"b; end; end; stop_run_command = "0"b; /* purge all communication partial files. */ /*[4.4-2]*/ /* call cobol_mcs_$stop_run; */ if ^found then code = -1; else do; code = 0; if statptr ^= null () then do; stat_ptr = statptr; if stat.line_no (1) = 0 then lineno = ""; else if stat.line_no (2) = 0 then call ioa_$rsnnl (" (line ^d)", lineno, len, stat.line_no (1)); else call ioa_$rsnnl (" (line ^d-^d)", lineno, len, stat.line_no (1), stat.line_no (2)); call ioa_ ("^a: Run-unit ^a terminated^a.", statptr -> stat.prog_id, control.name, lineno); end; call hcs_$truncate_seg (controlp, 0, mcode); if mcode ^= 0 then go to multics_error; /* call hcs_$terminate_seg (controlp, 0, mcode);*/ /*[4.4-2]*/ call release_temp_segments_ ("cobol_control_", tp, mcode); if mcode ^= 0 then go to multics_error; controlp = null (); call signal_ ("command_abort_", null (), null ()); end; end; /* *********************************** */ cobol_cancel_: entry (name); dcl cancel_code fixed bin; /* always ignored */ dcl cobol_control_$cancel entry (char (*), fixed bin, fixed bin, fixed bin); cancel_code = 0; call cobol_control_$cancel (name, 0, 0, cancel_code); return; cancel: entry (name, rdsw, rfsw, code); /* This entry is called by the cancel command and by object programs compiled by cobol to cancel a program in the run-unit by name. If the named program is not currently active in the run-unit then an error code is returned. This condition is an error for the cancel command, but is ignored by the code generated for the cancel verb. */ dcl name char (*) parameter; /* dcl rfsw fixed bin; /* retain files */ /* dcl rdsw fixed bin; /* retain data segment */ dcl code fixed bin; /* name a character string up to 65 chars long identifying the program to be cancelled. This corresponds to the name recorded in stat.prog_id i.e. if the Identification Division prog-id = the segment name, then stat.prog_id = segment name; otherwise, it is segment name$prog-id (input). code set to 0 if program successfully cancelled; otherwise set to 1 (output). } */ i = index (name, "$"); if i > 0 then rname = substr (name, 1, i - 1); else rname = name; call hcs_$make_ptr (null (), rname, substr (name, i + 1), segptr, mcode); if mcode ^= 0 then go to return_multics_error; found, others_found = "0"b; if code = -3 then others_found = "1"b; /* special - don't ever stop run */ code = -2; if controlp ^= null () then if control.no_of_segs > 0 then do i = 1 to control.no_of_segs; stat_ptr = control.statptr (i); if stat_ptr ^= null () then do; if stat.entry_pt_ptr = segptr & stat.call_cnt ^= -1 then do; stat.call_cnt = -1; /* reset initialization switch */ if rfsw = 0 then if stat.file_info_ptr ^= null () then do; call cobol_file_control_ ("-a", stat_ptr, 0, "ccp", "1"b, close_code); stat.file_info_ptr = null (); end; if rdsw = 0 then if stat.data_ptr ^= null () then do; if stat.data_len > 0 then free stat.data_ptr -> cobol_data_area in (area_ptr -> based_area); stat.data_ptr = null (); end; control.statptr (i) = null (); found = "1"b; end; else if stat.call_cnt ^= -1 then others_found = "1"b; end; end; else return; else return; if ^found then code = -1; else do; code = 0; if ^others_found then do; call com_err_ (0, "cancel_cobol_program", "^a was the only active cobol program of the run-unit.^/Run-unit ^a terminated.", name, control.name); call hcs_$truncate_seg (controlp, 0, mcode); if mcode ^= 0 then go to multics_error; /* call hcs_$terminate_seg (controlp, 0, mcode);*/ /*[4.4-2]*/ call release_temp_segments_ ("cobol_control_", tp, mcode); if mcode ^= 0 then go to multics_error; controlp = null (); call signal_ ("command_abort_", null (), null ()); end; end; return; /* *********************************** */ cobol_stoprun_: entry; call cu_$stack_frame_ptr (stack_frame_ptr); stack_frame_ptr = stack_frame.prev_stack_frame_ptr; stat_ptr = addrel (stack_frame.link_ptr, 8); if controlp ^= null () then if control.main_prog_sw ^= 0 then call signal_ ("stop_run", null (), stat_ptr); stop_code = 0; call cobol_stop_run_ (stat_ptr, 0, 0, stop_code); call signal_ ("command_abort_", null (), null ()); return; /* *********************************** */ cobol_finish_: entry; if controlp ^= null () then call hcs_$delentry_file (substr (sort_dir, 1, sort_dir_len), "cobol_temp_merge_file_", mcode); if controlp ^= null () then if control.no_of_segs > 0 then do i = 1 to control.no_of_segs; stat_ptr = control.statptr (i); if stat_ptr ^= null () then if stat.file_info_ptr ^= null () then call cobol_file_control_ ("-a", stat_ptr, 0, "", "1"b, close_code); end; return; /* *********************************** */ get_pointer: entry returns (pointer); return (controlp); /* ************************************ */ rc: run_cobol: entry; if controlp ^= null () then go to recursion_error; call cu_$arg_count (nargs); if nargs < 1 then go to missing_arg_error; call cu_$arg_ptr (1, argptr, arglen, mcode); if mcode ^= 0 then go to rc_multics_error; /*[4.4-2]*/ arg1_ptr = argptr; arg1_len = arglen; /*[5.0-1]*/ call find_command_ (argptr, arglen, segptr, mcode); /*[4.4-2]*/ if mcode = error_table_$seg_not_found /*[4.4-2]*/ then do; call com_err_ (0, "run_cobol", "Segment ^a not found", arg); return; end; /* [3.0-1] */ call set_handlers (1); sort_dir_len = 0; if nargs > 1 then do i = 2 to nargs; call cu_$arg_ptr (i, argptr, arglen, mcode); if mcode ^= 0 then go to rc_multics_error; if arg = "-cs" | arg = "-cobol_switch" then do; switch_loop: i = i + 1; if i <= nargs then do; call cu_$arg_ptr (i, argptr, arglen, mcode); if mcode ^= 0 then go to rc_multics_error; if substr (arg, 1, 1) = "-" then i = i - 1; else do; if arglen > 1 | arg < "1" | arg > "8" then go to bad_arg_error; control.sense_sw (fixed (arg, 17)) = 1; go to switch_loop; end; end; end; else if arg = "-sd" | arg = "-sort_dir" then do; i = i + 1; if i <= nargs then do; call cu_$arg_ptr (i, argptr, arglen, mcode); if mcode ^= 0 then go to rc_multics_error; if substr (arg, 1, 1) = "-" then i = i - 1; else do; call expand_path_ (argptr, arglen, addr (sort_dir), null (), mcode); sort_dir_len = index (sort_dir, " ") - 1; end; end; end; else if arg = "-sfs" | arg = "-sort_file_size" then do; i = i + 1; if i <= nargs then do; call cu_$arg_ptr (i, argptr, arglen, mcode); if mcode ^= 0 then go to rc_multics_error; if substr (arg, 1, 1) = "-" then i = i - 1; else sort_file_size = float (arg, 27); end; end; else if arg = "-ctu" | arg = "-continue" then control.ind_mask = "000000001"b; else if arg = "-nsr" | arg = "-no_stop_run" then stop_run_sw = "1"b; else if arg = "-db" | arg = "-debug" then control.sense_sw (8) = 1; else go to bad_arg_error; end; control.main_prog_ptr = segptr; control.main_prog_sw = 1; if ^stop_run_sw then on stop_run call COND ("stop_run"); /* [3.0-1] */ /*[4.4-2]*/ call cu_$cp (arg1_ptr, arg1_len, mcode); /*[4.4-2]*/ if mcode ^= 0 then go to invalid_exit_error; /*[4.4-2]*/ return; bad_arg_error: call com_err_ (error_table_$badopt, "run_cobol", arg); go to rc_error; recursion_error: call com_err_ (0, "run_cobol", "A cobol run-unit already exists; stop_cobol_run must be issued before another can be created."); return; missing_arg_error: call com_err_ (error_table_$noarg, "run_cobol"); go to rc_error; invalid_exit_error: call com_err_ (0, "Error", "An invalid EXIT PROGRAM has been executed."); return; rc_multics_error: call com_err_ (mcode, "run_cobol"); rc_error: controlp = null (); return; COND: proc (cond_name); /*[3.0-1]*/ declare find_condition_info_ entry (ptr, ptr, fixed bin (35)); /*[3.0-1]*/ declare code fixed bin (35), cond_name char (*); /*[3.0-1]*/ call find_condition_info_ (null (), addr (cond_info), code); /*[3.0-1]*/ call cobol_hand (cond_name, cond_info.infoptr); /*[3.0-1]*/ /* call release_temp_segments_ ("cobol_control_", tp, mcode); */ end; /*[3.0-1]*/ /* called if controlp = null, 0(prologue), 1(run_cobol) */ set_handlers: proc (mode); /*[3.0-1]*/ /**/ declare mode fixed bin; /*[4.0-1]*/ call get_temp_segments_ ("cobol_control_", tp, mcode); /*[4.0-1]*/ if mcode ^= 0 then go to control_error; /*[4.0-1]*/ controlp = tp (1); /**/ if mode ^= 0 /**/ then do; call hcs_$truncate_seg (controlp, 0, mcode); /**/ if mcode ^= 0 then go to rc_multics_error; /**/ end; /**/ evar = cobol_control_; /**/ call hcs_$make_ptr (bptr, /**/ "cobol_rts_handler_", /**/ "cobol_rts_handler_", /**/ control.fofl_handler_ptr, /**/ mcode); /**/ if mcode ^= 0 then go to control_error; /*[4.4-2]*/ call add_epilogue_handler_ (cobol_finish_, mcode);/**/ if mcode ^= 0 then go to control_error; end; /* [3.0-1] */ /* *********************************** */ cobol_handler_: entry; /* This entry can be deleted but bound_cobol_rts_.bind must be altered */ return; cobol_hand: proc (cond_name, infoptr); /* [3.0-1] */ ; dcl cond_name char (*); dcl infoptr ptr; if ^stop_run_sw then if cond_name = "stop_run" then do; stop_code = 0; call cobol_stop_run_ (infoptr, 0, 0, stop_code); call com_err_ (0, "Error", "No cobol run-unit exists - cannot STOP RUN."); call signal_ ("command_abort_", null (), null ()); end; call com_err_ (0, "Error", "^a condition raised - internal inconsistency in the run-unit.", cond_name); end; /* *********************************** */ /* *********************************** */ cobol_file_control_: entry (ioname, statp, type, errorname, dtsw, cfc_code); dcl ioname char (*); dcl statp ptr; dcl type fixed bin; /* -1=nomes,0=norm,1=long: close; 2=norm,3=long: list */ dcl errorname char (*); dcl dtsw bit (1) aligned; dcl cfc_code fixed bin (35); begin; dcl statptr ptr; statptr = statp; dcl 1 opened_files static, 2 n fixed bin init (0), 2 pt (20) ptr; dcl 1 dup, 2 n fixed bin, 2 pt (100) ptr; dcl mcode fixed bin (35); dcl save_mode fixed bin; dcl i fixed bin; dcl j fixed bin; dcl k fixed bin; dcl m fixed bin; dcl org fixed bin; dcl acc fixed bin; dcl mode fixed bin; dcl odptr ptr; dcl adptr ptr; dcl anysw bit (1); dcl nodupsw bit (1); dcl command_sw bit (1); dcl vstring char (240) varying based; dcl save_od char (240) varying; dcl save_ad char (240) varying; dcl save_ocname char (65); dcl pname char (65); dcl file_name char (32); dcl eicon char (8); dcl pcon char (69); dcl action_con char (20); dcl oiscon char (3); dcl aiscon char (3); dcl mode_con (0:3) char (6) static init ("extend", "input", "i-o", "output"); dcl org_con (0:3) char (10) static init ("stream", "sequential", "relative", "indexed"); dcl acc_con (3) char (10) static init ("sequential", "random", "dynamic"); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); /* dcl ioa_ entry options(variable); */ /* dcl com_err_ entry options(variable); */ cfc_code = -2; if controlp = null () then return; if control.no_of_segs < 1 then return; cfc_code = -1; /* until something is done */ nodupsw = "0"b; dup.n = 0; if substr (ioname, 1, 1) = "-" then anysw = "1"b; else anysw = "0"b; if statptr ^= null () then do; stat_ptr = statptr; if stat.file_info_ptr = null () then return; pname = stat.prog_id; file_info_ptr = stat.file_info_ptr; call look; end; else do; if anysw then do; nodupsw = "1"b; do i = 1 to control.no_of_segs; stat_ptr = control.statptr (i); if stat_ptr ^= null () then do; if stat.file_info_ptr ^= null () then do; pname = stat.prog_id; file_info_ptr = stat.file_info_ptr; call look; end; end; end; end; else do; call hcs_$make_ptr (null (), "cobol_fsb_", ioname, fsb_ptr, mcode); if fsb_ptr = null () then return; call action; end; end; return; /* *********************************** */ /* SUBROUTINES */ /* *********************************** */ /* *********************************** */ look: proc; do k = 1 to divide (file_info.n, 2, 17, 0); if file_info.pt (k) ^= null () then do; fsb_ptr = file_info.pt (k); dtsw = ^fsb.attach_flag; /*[5.3-1]*/ if fsb.fsb_skel.mod1 then fsb.last_key_read = ""; if anysw then if ioname = "-a" | ioname = "-i" & fsb.internal | ioname = "-e" & ^fsb.internal then call action; else ; else do; if ioname = fsb.iocb_ptr -> iocb.name then call action; if fsb.internal then do; j = index (fsb.iocb_ptr -> iocb.name, " ") - 17; if j < 0 then j = 16; if ioname = substr (fsb.iocb_ptr -> iocb.name, 1, j) then call action; end; end; end; end; end; /* *********************************** */ action: proc; save_ocname = fsb.open_close_name; save_mode = fsb.open_mode; if nodupsw & pname ^= save_ocname then do; if substr (save_ocname, 1, 3) = "***" | save_ocname = "" then do; /* by command or non-cobol prog */ if dup.n > 0 then do m = 1 to dup.n; if dup.pt (m) = fsb_ptr then return; end; if dup.n < 100 then dup.n = dup.n + 1; /* don't be ridiculous */ dup.pt (dup.n) = fsb_ptr; command_sw = "1"b; end; else return; end; else command_sw = "0"b; if fsb.iocb_ptr ^= null () then do; if errorname = "scr" then if fsb.internal then fsb.lock = "0"b; odptr = fsb.iocb_ptr -> iocb.open_descrip_ptr; adptr = fsb.iocb_ptr -> iocb.attach_descrip_ptr; if odptr ^= null () then save_od = odptr -> vstring; if adptr ^= null () then save_ad = adptr -> vstring; end; else return; if type > 1 then cfc_code = 0; /* list only */ else if pname = save_ocname | ^anysw | command_sw then do; if save_mode > 0 then cfc_code = 0; if save_mode < 0 then do; if ^anysw then do; call com_err_ (0, "close_cobol_file", "Not closing external file ^a (it was opened by a non-cobol program).", fsb.iocb_ptr -> iocb.name); cfc_code = 0; end; return; end; if save_mode ^= 0 then do; call iox_$close (fsb.iocb_ptr, mcode); if mcode ^= 0 then go to merror; cfc_code = 0; fsb.open_mode = 0; j = index (errorname, " ") - 1; if j < 0 then j = length (errorname); fsb.open_close_name = "***" || substr (errorname, 1, j) || "***"; end; if dtsw then do; call iox_$detach_iocb (fsb.iocb_ptr, mcode); if mcode ^= 0 then do; if save_mode ^= 0 then go to merror; else return; end; else cfc_code = 0; end; else if save_mode = 0 then return; end; else return; if type < 0 then return; /* no message */ if fsb.internal then do; j = index (fsb.iocb_ptr -> iocb.name, " ") - 17; if j < 0 then j = 16; file_name = substr (fsb.iocb_ptr -> iocb.name, 1, j); eicon = "Internal"; pcon = " in " || substr (stat.prog_id, 1, stat.prog_id_len); end; else do; file_name = fsb.iocb_ptr -> iocb.name; eicon = "External"; pcon = ""; end; if type < 2 then do; if dtsw then do; if save_mode = 0 then action_con = " detached"; else action_con = " closed and detached"; end; else action_con = " closed"; pcon = ""; end; else action_con = ""; if stop_run_command then call ioa_ ("^a file ^a^a^a", eicon, file_name, action_con, pcon); else ; if save_mode = 0 then if stop_run_command then call ioa_ (" closed by ^a", save_ocname); else ; else do; if save_mode < 0 then if stop_run_command then call ioa_ (" opened by a non-cobol program"); else ; else do; org = fixed (substr (unspec (save_mode), 33, 2), 2); acc = fixed (substr (unspec (save_mode), 35, 2), 2); mode = fixed (substr (unspec (save_mode), 31, 2), 2); /* [4.0-2] */ if stop_run_command then call ioa_ (" opened by ^a for ^a with ^a organization and ^a access", save_ocname, mode_con (mode), org_con (org), acc_con (acc)); end; end; if type = 0 | type = 2 then return; /* normal message */ if stop_run_command then call ioa_ (" file state block at ^p^/ io_control_block for io_switch ^a at ^p", fsb_ptr, fsb.iocb_ptr -> iocb.name, fsb.iocb_ptr); if type = 3 then oiscon, aiscon = "is"; else do; oiscon = "was"; if dtsw then aiscon = "was"; else aiscon = "is"; end; if stop_run_command then do; if odptr ^= null () then call ioa_ (" open description ^a: ""^a""", oiscon, save_od); if adptr ^= null () then call ioa_ (" attach description ^a: ""^a""", aiscon, save_ad); call ioa_ (""); end; else ; return; merror: call com_err_ (mcode, errorname); return; end; /* *********************************** */ end; /* *********************************** */ /* *********************************** */ control_error: call cu_$stack_frame_ptr (stack_frame_ptr); stack_frame_ptr = stack_frame.prev_stack_frame_ptr; error_ptr = addrel (stack_frame.return_ptr, -1); call cobol_error_ (0, mcode, 0, 0, "cobol_control_", error_ptr); return; multics_error: call com_err_ (mcode, "stop_run"); call signal_ ("command_abort_", null (), null ()); return; return_multics_error: code = mcode; return; /* *********************************** */ /* **** Declaration for builtin function **** */ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index, float) builtin; /* **** End of declaration for builtin function **** */ %include cobol_control; %include cobol_fixed_static; %include cobol_stack_frame; %include cobol_fsb_type_1; %include cobol_fsbskel; %include iocb; %include stack_header; %include cobol_file_info; dcl 1 cond_info, /*[3.0-1]*/ %include cond_info; end;  cobol_error_.pl1 05/24/89 1048.6rew 05/24/89 0836.9 79767 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_error_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 06/08/79 by PRP, [4.0-1], print_cobol_error_ made to use error_output */ /* Modified since Version 4.0 */ /*{*/ /* format: style3 */ cobol_error_: proc (cobol_code, multics_code, line_no1, line_no2, progname, error_ptr); /* This is a run-time routine for reporting object errors which occur in cobol programs or are discovered by cobol run-time support routines. It reports the error to the error_output stream and signals the "error" condition. The sub-generators cobol_process_error and cobol_gen_error are used by code generators to set up a call to this routine. */ dcl cobol_code fixed bin parameter; dcl multics_code fixed bin (35) parameter; dcl line_no1 fixed bin parameter; dcl line_no2 fixed bin parameter; dcl progname char (65) varying parameter; dcl error_ptr ptr parameter; /* cobol_code indicates the cobol error number (input). multics_code indicates the multics status code (input). line_no1 the line number on which the error occurred. If 0, no line number is applicable and no such indication will be given in the error message (input). line_no2 the additional line number. If 0, then only a one-part line number is given (input). progname a character string containing the name of the program which produced the error. The cobol_process_error sub-generator will always set is to the name of the program for which code is being generated. Run-time support routines may identify the program which called them of themselves, depending on the nature of the error. If this is a null string, then no program name is applicable and none will be attached to the error message (input). error_ptr a pointer to the location at which the error was discovered or to the location at which cobol_error_ is called from. The cobol_process_error sub-generator will always set it to the latter (input). The following message(s) will be output to the "error_output" stream: ["progname": Multics message (from com_err_)] ["progname": COBOL error message] Error occurred at "segno|offset" [in "progname" [on line ["line_no2"] "line_no1"]] The first line is printed only if multics_code is non-zero. The second line is printed only if cobol_code is non-zero. The third line is always printed. The progname portion of it is not present if progname is null; the line_no2 portion of it is not present is line_no2 is zero; the line_no1 portion of it is not present if line_no1 is zero. }*/ /* COBOL ERROR TABLE */ dcl cet_ptr ptr static init (null ()); dcl cet char (100000) based (cet_ptr); dcl 1 cobol_error_table based (cet_ptr), 2 max fixed bin aligned, 2 error (0 refer (cobol_error_table.max)) aligned, 3 start fixed bin unal, 3 len fixed bin unal; /* DECLARATIONS */ dcl len fixed bin; dcl code fixed bin (35); dcl dname char (168); dcl ename char (32); dcl inprog char (168); dcl online char (24); dcl shortinfo char (8) aligned; dcl longinfo char (100) aligned; dcl evar entry auto; dcl bptr ptr based (addr (evar)); dcl cobol_error_$use entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (65) varying, ptr); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl com_err_ entry options (variable); dcl hcs_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl ioa_$ioa_stream entry options (variable); dcl ioa_$ioa_stream_nnl entry options (variable); dcl ioa_$rs entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl signal_ entry (char (*)); /*************************************/ start: if cet_ptr = null () then call set_cet_ptr; if multics_code ^= 0 then do; call convert_status_code_ (multics_code, shortinfo, longinfo); if progname ^= "" then call ioa_$ioa_stream_nnl ("error_output", "^a: ", progname); call ioa_$ioa_stream ("error_output", longinfo); end; if cobol_code > 0 then do; if progname ^= "" then call ioa_$ioa_stream_nnl ("error_output", "^a: ", progname); if cobol_code > cobol_error_table.max then call ioa_$ioa_stream ("error_output", "Invalid cobol error code ^d", cobol_code); else call ioa_$ioa_stream ("error_output", substr (cet, error.start (cobol_code), error.len (cobol_code))); /*-06/02/76-*/ end; call hcs_$fs_get_path_name (error_ptr, dname, len, ename, code); if code ^= 0 then inprog = ""; else inprog = " in " || substr (dname, 1, len) || ">" || ename; if line_no1 > 0 | line_no2 > 0 then if line_no1 > 0 & line_no2 > 0 then call ioa_$rsnnl (" on line ^d-^d", online, len, line_no2, line_no1); else call ioa_$rsnnl (" on line ^d", online, len, line_no1); else online = ""; call ioa_$ioa_stream ("error_output", "Error occurred at ^p^a^a", error_ptr, inprog, online); call cobol_error_$use (cobol_code, multics_code, line_no1, line_no2, progname, error_ptr); /*-05/10/76-*/ call signal_ ("error"); return; /*************************************/ use: entry (cobol_code, multics_code, line_no1, line_no2, progname, error_ptr); dcl errline char (300) static; dcl tline char (120); dcl erroff fixed bin; dcl errlen fixed bin static init (0); start_use: if cet_ptr = null () then call set_cet_ptr; erroff = 1; if multics_code ^= 0 then do; call convert_status_code_ (multics_code, shortinfo, longinfo); if progname ^= "" then do; call ioa_$rsnnl ("^a: ", tline, len, progname); substr (errline, erroff, len) = tline; erroff = erroff + len; end; call ioa_$rs (longinfo, tline, len); substr (errline, erroff, len) = tline; erroff = erroff + len; end; if cobol_code > 0 then do; if progname ^= "" then do; call ioa_$rsnnl ("^a: ", tline, len, progname); substr (errline, erroff, len) = tline; erroff = erroff + len; end; if cobol_code > cobol_error_table.max then call ioa_$rs ("Invalid cobol error code ^d", tline, len, cobol_code); /*-06/02/76-*/ else do; call ioa_$rs (substr (cet, error.start (cobol_code), error.len (cobol_code)), tline, len); /*-06/02/76-*/ substr (errline, erroff, len) = tline; erroff = erroff + len; end; end; call hcs_$fs_get_path_name (error_ptr, dname, len, ename, code); if code ^= 0 then inprog = ""; else inprog = " in " || substr (dname, 1, len) || ">" || ename; if line_no1 > 0 | line_no2 > 0 then if line_no1 > 0 & line_no2 > 0 then call ioa_$rsnnl (" on line ^d-^d", online, len, line_no2, line_no1); else call ioa_$rsnnl (" on line ^d", online, len, line_no1); else online = ""; call ioa_$rs ("Error occurred at ^p^a^a", tline, len, error_ptr, inprog, online); substr (errline, erroff, len) = tline; errlen = erroff + len - 1; return; /*************************************/ print_cobol_error_: entry; dcl stream char (32); /*[4.0-1]*/ stream = "error_output"; go to join; switch: entry (in_stream); dcl in_stream char (*) parameter; stream = in_stream; join: if errlen = 0 then call ioa_$ioa_stream (stream, "Improper call to print_cobol_error_ - no pending error recorded"); else call ioa_$ioa_stream (stream, substr (errline, 1, errlen)); return; /*************************************/ abort: call signal_ ("error"); set_cet_ptr: proc; evar = cobol_error_; call hcs_$make_ptr (bptr, "cobol_error_table_", "cobol_error_table_", cet_ptr, code); if cet_ptr = null () then do; call com_err_ (code, "cobol rts", "cobol_error_table_$cobol_error_table_"); go to abort; end; return; end set_cet_ptr; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ end cobol_error_;  cobol_error_table_.alm 11/11/82 1550.1rew 11/11/82 1030.7 131040 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** name cobol_error_table_ cobol_error_table_: segdef cobol_error_table_ oct 000000000076 oct 000375000016 oct 000413000060 oct 000473000051 oct 000544000052 oct 000616000040 oct 000656000051 oct 000727000030 oct 000757000052 oct 001031000063 oct 001114000066 oct 001202000070 oct 001272000054 oct 001346000033 oct 001401000072 oct 001473000023 oct 001516000076 oct 001614000060 oct 001674000024 oct 001720000067 oct 002007000075 oct 002104000026 oct 002132000076 oct 002230000115 oct 002345000052 oct 002417000025 oct 002444000034 oct 002500000027 oct 002527000114 oct 002643000035 oct 002700000027 oct 002727000030 oct 002757000036 oct 003015000115 oct 003132000111 oct 003243000123 oct 003366000100 oct 003466000034 oct 003522000060 oct 003602000101 oct 003703000070 oct 003773000123 oct 004116000105 oct 004223000106 oct 004331000054 oct 004405000063 oct 004470000076 oct 004566000071 oct 004657000047 oct 004726000062 oct 005010000020 oct 005030000073 oct 005123000045 oct 005170000044 oct 005234000051 oct 005305000050 oct 005355000050 oct 005425000031 oct 005456000020 oct 005476000072 oct 005570000102 oct 005672000070 oct 005762000062 oct 117142163157 oct 154145164145 oct 040145162162 oct 157162101164 oct 164145155160 oct 164040164157 oct 040145170145 oct 143165164145 oct 040142145171 oct 157156144040 oct 154157147151 oct 143141154040 oct 145156144040 oct 157146040160 oct 162157147162 oct 141155125156 oct 141142154145 oct 040164157040 oct 143157155160 oct 154145164145 oct 040144151163 oct 160154141171 oct 040164157040 oct 165163145162 oct 137157165164 oct 160165164125 oct 156141142154 oct 145040164157 oct 040143157155 oct 160154145164 oct 145040144151 oct 163160154141 oct 171040164157 oct 040145162162 oct 157162137157 oct 165164160165 oct 164111155160 oct 162157160145 oct 162154171040 oct 145170145143 oct 165164145144 oct 040104105103 oct 114101122101 oct 124111126105 oct 123125156141 oct 142154145040 oct 164157040143 oct 157155160154 oct 145164145040 oct 141143143145 oct 160164040146 oct 162157155040 oct 165163145162 oct 137151156160 oct 165164125156 oct 141142154145 oct 040164157040 oct 145163164141 oct 142154151163 oct 150040111117 oct 103102101164 oct 164145155160 oct 164040164157 oct 040157160145 oct 156040145170 oct 164145162156 oct 141154040146 oct 151154145040 oct 141154162145 oct 141144171040 oct 157160145156 oct 101164164145 oct 155160164040 oct 164157040157 oct 160145156040 oct 151156164145 oct 162156141154 oct 040146151154 oct 145040167150 oct 151143150040 oct 151163040141 oct 154162145141 oct 144171040157 oct 160145156116 oct 157040160162 oct 145166151157 oct 165163040141 oct 164164141143 oct 150155145156 oct 164040145163 oct 164141142154 oct 151163150145 oct 144040146157 oct 162040165156 oct 141164164141 oct 143150145144 oct 040146151154 oct 145125156141 oct 142154145040 oct 164157040143 oct 154157163145 oct 040146151154 oct 145040151156 oct 040157162144 oct 145162040164 oct 157040162145 oct 141164164141 oct 143150040164 oct 150145040111 oct 057117040163 oct 167151164143 oct 150125156141 oct 142154145040 oct 164157040144 oct 145164141143 oct 150040111057 oct 117040163167 oct 151164143150 oct 040146157162 oct 040162145141 oct 164164141143 oct 150155145156 oct 164125156141 oct 142154145040 oct 164157040141 oct 164164141143 oct 150040111057 oct 117040163167 oct 151164143150 oct 125156141142 oct 154145040164 oct 157040141164 oct 164141143150 oct 040111057117 oct 040163167151 oct 164143150040 oct 165163151156 oct 147040163160 oct 145143151146 oct 151145144040 oct 141164164141 oct 143150040157 oct 160164151157 oct 156163125156 oct 141142154145 oct 040164157040 oct 157160145156 oct 040146151154 oct 145125156141 oct 142154145040 oct 164157040160 oct 157163151164 oct 151157156040 oct 144171156141 oct 155151143040 oct 141143143145 oct 163163040157 oct 165164160165 oct 164040146151 oct 154145040164 oct 157040105117 oct 106040165160 oct 157156040157 oct 160145156101 oct 164164145155 oct 160164040164 oct 157040143154 oct 157163145040 oct 151156164145 oct 162156141154 oct 040146151154 oct 145040167150 oct 151143150040 oct 151163040156 oct 157164040157 oct 160145156125 oct 156141142154 oct 145040164157 oct 040143154157 oct 163145040146 oct 151154145125 oct 156141142154 oct 145040164157 oct 040144145164 oct 141143150040 oct 111057117040 oct 163167151164 oct 143150040141 oct 146164145162 oct 040143154157 oct 163151156147 oct 040151156164 oct 145162156141 oct 154040146151 oct 154145101164 oct 164145155160 oct 164040164157 oct 040145170145 oct 143165164145 oct 040141156040 oct 165156151156 oct 151164151141 oct 154151172145 oct 144040141154 oct 164145162141 oct 142154145040 oct 107117040124 oct 117040163164 oct 141164145155 oct 145156164125 oct 156141142154 oct 145040164157 oct 040167162151 oct 164145040162 oct 145143157162 oct 144125156141 oct 142154145040 oct 164157040163 oct 145145153040 oct 163160145143 oct 151146151145 oct 144040153145 oct 171040146157 oct 162040157165 oct 164160165164 oct 040055040160 oct 157163163151 oct 142154145040 oct 144165160154 oct 151143141164 oct 151157156124 oct 150145040166 oct 141154165145 oct 040157146040 oct 141040144141 oct 164141055156 oct 141155145040 oct 165163145144 oct 040167151164 oct 150040164150 oct 145040101104 oct 126101116103 oct 111116107040 oct 143154141165 oct 163145040151 oct 163040151156 oct 157162144151 oct 156141164145 oct 154171040154 oct 141162147145 oct 101164164145 oct 155160164040 oct 164157040160 oct 145162146157 oct 162155040111 oct 057117040157 oct 156040141156 oct 040165156157 oct 160145156145 oct 144040146151 oct 154145125156 oct 141142154145 oct 040164157040 oct 162145141144 oct 040162145143 oct 157162144125 oct 156141142154 oct 145040164157 oct 040163145145 oct 153040153145 oct 171040146157 oct 162040151156 oct 160165164125 oct 156141142154 oct 145040164157 oct 040162145141 oct 144040156145 oct 170164040153 oct 145171111156 oct 166141154151 oct 144040144145 oct 154145164145 oct 040141164164 oct 145155160164 oct 145144040055 oct 040160162145 oct 166151157165 oct 163040111057 oct 117040157160 oct 145162141164 oct 151157156040 oct 167141163040 oct 156157164040 oct 141040162145 oct 141144040151 oct 156040151055 oct 157040155157 oct 144145125156 oct 141142154145 oct 040164157040 oct 163145145153 oct 040153145171 oct 040146157162 oct 040144145154 oct 145164145125 oct 156141142154 oct 145040164157 oct 040144145154 oct 145164145040 oct 162145143157 oct 162144125156 oct 141142154145 oct 040164157040 oct 162145167162 oct 151164145040 oct 162145143157 oct 162144125156 oct 141142154145 oct 040164157040 oct 163145145153 oct 040153145171 oct 040146157162 oct 040162145167 oct 162151164145 oct 111156166141 oct 154151144040 oct 162145167162 oct 151164145040 oct 141164164145 oct 155160164145 oct 144040055040 oct 160162145166 oct 151157165163 oct 040111057117 oct 040157160145 oct 162141164151 oct 157156040167 oct 141163040156 oct 157164040141 oct 040162145141 oct 144040151156 oct 040151055157 oct 040155157144 oct 145111156166 oct 141154151144 oct 040162145167 oct 162151164145 oct 040141164164 oct 145155160164 oct 145144040141 oct 164164145155 oct 160164145144 oct 040055040156 oct 145167040153 oct 145171040151 oct 163040156157 oct 164040151144 oct 145156164151 oct 143141154040 oct 164157040157 oct 154144040153 oct 145171111156 oct 166141154151 oct 144040162145 oct 167162151164 oct 145040141164 oct 164145155160 oct 164145144040 oct 055040156145 oct 167040162145 oct 143157162144 oct 040154145156 oct 147164150040 oct 151163040156 oct 157164040151 oct 144145156164 oct 151143141154 oct 040164157040 oct 157154144040 oct 162145143157 oct 162144040154 oct 145156147164 oct 150111156166 oct 141154151144 oct 040111057117 oct 040157160145 oct 162141164151 oct 157156056040 oct 040101164164 oct 145155160164 oct 040164157040 oct 163164141162 oct 164040141040 oct 146151154145 oct 040157160145 oct 156145144040 oct 141163040157 oct 165164160165 oct 164125156141 oct 142154145040 oct 164157040163 oct 145145153040 oct 153145171040 oct 146157162040 oct 163164141162 oct 164125156141 oct 142154145040 oct 164157040163 oct 164141162164 oct 040146151154 oct 145040167151 oct 164150040163 oct 160145143151 oct 146151145144 oct 040153145171 oct 040162145154 oct 141164151157 oct 156101164164 oct 145155160164 oct 040164157040 oct 123105124040 oct 141156040151 oct 156144145170 oct 040157165164 oct 163151144145 oct 040164150145 oct 040162141156 oct 147145040157 oct 146040151164 oct 163040141163 oct 163157143151 oct 141164145144 oct 040164141142 oct 154145111156 oct 166141154151 oct 144040111057 oct 117040157160 oct 145162141164 oct 151157156056 oct 040040101164 oct 164145155160 oct 164040164157 oct 040162145141 oct 144040141156 oct 040165156157 oct 160145156145 oct 144040146151 oct 154145111156 oct 166141154151 oct 144040111057 oct 117040157160 oct 145162141164 oct 151157156056 oct 040040101164 oct 164145155160 oct 164040164157 oct 040167162151 oct 164145040141 oct 040163145161 oct 165145156164 oct 151141154154 oct 171040141143 oct 143145163163 oct 145144040146 oct 151154145040 oct 157160145156 oct 145144040141 oct 163040151055 oct 157111156166 oct 141154151144 oct 040111057117 oct 040157160145 oct 162141164151 oct 157156056040 oct 040101164164 oct 145155160164 oct 040164157040 oct 144145154145 oct 164145040151 oct 156040141040 oct 146151154145 oct 040156157164 oct 040157160145 oct 156145144040 oct 141163040151 oct 055157111156 oct 166141154151 oct 144040111057 oct 117040157160 oct 145162141164 oct 151157156056 oct 040040101164 oct 164145155160 oct 164040164157 oct 040162145167 oct 162151164145 oct 040151156040 oct 141040146151 oct 154145040156 oct 157164040157 oct 160145156145 oct 144040141163 oct 040151055157 oct 120145162146 oct 157162155040 oct 163164141164 oct 145155145156 oct 164040102131 oct 040151144145 oct 156164151146 oct 151145162040 oct 145161165141 oct 154163040172 oct 145162157056 oct 126141154165 oct 145040157146 oct 040104105120 oct 105116104111 oct 116107040117 oct 116040151164 oct 145155040151 oct 163040157165 oct 164163151144 oct 145040144145 oct 146151156145 oct 144040162141 oct 156147145111 oct 156144145170 oct 040144141164 oct 141040151164 oct 145155040151 oct 156040126101 oct 122131111116 oct 107040143154 oct 141165163145 oct 040157146040 oct 123105101122 oct 103110040151 oct 163040156157 oct 164040151156 oct 151164151141 oct 154151172145 oct 144105170160 oct 157156145156 oct 164151141164 oct 151157156040 oct 145162162157 oct 162040055040 oct 074156145147 oct 141164151166 oct 145040156165 oct 155142145162 oct 076040052052 oct 040074156157 oct 156055151156 oct 164145147145 oct 162076105170 oct 160157156145 oct 156164151141 oct 164151157156 oct 040145162162 oct 157162040055 oct 040074172145 oct 162157076040 oct 052052040074 oct 172145162157 oct 076105170160 oct 157156145156 oct 164151141164 oct 151157156040 oct 145162162157 oct 162040055040 oct 074172145162 oct 157076040052 oct 052040074156 oct 145147141164 oct 151166145040 oct 156165155142 oct 145162076123 oct 117122124057 oct 115105122107 oct 105040145162 oct 162157162125 oct 156141142154 oct 145040164157 oct 040141164164 oct 141143150040 oct 111057117040 oct 163167151164 oct 143150040055 oct 040160157163 oct 163151142154 oct 145040151156 oct 166141154151 oct 144040143141 oct 164141154157 oct 147055156141 oct 155145123117 oct 122124040145 oct 162162157162 oct 040055040165 oct 156141142154 oct 145040164157 oct 040122105114 oct 105101123105 oct 040162145143 oct 157162144123 oct 117122124040 oct 145162162157 oct 162040055040 oct 165156141142 oct 154145040164 oct 157040122105 oct 124125122116 oct 040162145143 oct 157162144123 oct 117122124040 oct 145162162157 oct 162040055040 oct 165156141142 oct 154145040164 oct 157040164145 oct 162155151156 oct 141164145040 oct 164150145040 oct 163157162164 oct 123117122124 oct 040145162162 oct 157162040055 oct 040165156141 oct 142154145040 oct 164157040151 oct 156151164151 oct 141164145040 oct 164150145040 oct 163157162164 oct 123117122124 oct 040145162162 oct 157162040055 oct 040165156141 oct 142154145040 oct 164157040143 oct 157155155145 oct 156143145040 oct 164150145040 oct 163157162164 oct 125156141142 oct 154145040164 oct 157040143141 oct 154154040151 oct 144145156164 oct 151146151145 oct 162116157040 oct 145162162157 oct 162040155145 oct 163163141147 oct 145101162147 oct 165155145156 oct 164040155151 oct 163155141164 oct 143150040055 oct 040151156143 oct 157162162145 oct 143164040156 oct 165155142145 oct 162040157146 oct 040141162147 oct 165155145156 oct 164163040163 oct 165160160154 oct 151145144101 oct 162147165155 oct 145156164040 oct 155151163155 oct 141164143150 oct 040055040144 oct 141164141040 oct 164171160145 oct 040151163040 oct 156157164040 oct 143157155160 oct 141164151142 oct 154145040167 oct 151164150040 oct 164150141164 oct 040145170160 oct 145143164145 oct 144101040163 oct 165142163143 oct 162151160164 oct 040151163040 oct 157165164163 oct 151144145040 oct 164150145040 oct 162141156147 oct 145040157146 oct 040164150145 oct 040162145146 oct 145162145156 oct 143145144040 oct 164141142154 oct 145101164164 oct 145155160164 oct 040164157040 oct 157160145156 oct 040141040146 oct 151154145040 oct 143154157163 oct 145144040167 oct 151164150040 oct 164150145040 oct 114117103113 oct 040157160164 oct 151157156000 end  cobol_expand_source_.pl1 05/24/89 1048.6rew 05/24/89 0836.9 323244 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_expand_source_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 04/04/83 by FCH, [5.2-1], span changed to fixed bin(24), phx14809(BUG550) */ /* Modified on 12/29/81 by FCH, [5.1-2], ecs command makes COPY and REPLACE statements into comments, phx11818(BUG519) */ /* Modified on 10/27/81 by FCH, [5.1-1], include file cobol_ecs_info changed, phx11819(BUG517) */ /* Recompiled on 12/10/79 to fix problem with leveling diags on COPY statements */ /* Modified on 04/09/79 by FCH, [4.0-3], emit text manip statement */ /* Modified on 04/05/79 by FCH, [4.0-2], detect illegal pseudo-text */ /* Modified on 02/23/79 by FCH, [4.0-1], copy file name qualification */ /* created for Version 4.0 */ /* format: style3 */ cobol_expand_source_: proc; replace: entry (ecs_info_ptr, bc, command, expand_cobol_source_area_ptr); call init; /* Main processing loop for replace statement */ replace_err: call clear_copy; do while ("1"b); lexeme_env.error = 0; call cobol_lexeme$find_replace (lexeme_ptr); next_replace: if lexeme_env.error = 1 then do; call merge_to_end; bc = (next_new_position - 1) * 9; call finish; return; end; else do; replace_active = "1"b; save_copy_line = lexeme_env.token.line; copy_line_length = lexeme_env.current_line.length; save_copy_column = lexeme_env.token.column; save_source_offset = lexeme_env.token.offset - 1; copy_line_ptr = lexeme_env.current_line.loc; call process_replace_statement; end; end; /* end processing loop for replace statement */ process_replace_statement: proc; /*[4.0-3]*/ state_pos = lexeme_env.token.offset; comp_str_used = 1; cr_used, cr_largest, semi_sw, comma_sw = 0; lexeme_env.indicators.copy_replace = "1"b; lexeme_env.pseudo_text = 1; call cobol_lexeme$cobol_lexeme (lexeme_ptr); if lexeme_env.error = 1 then return; /* replace off. */ if lexeme_env.token.type = 3 & lexeme_env.token.string = "off" then do; call cobol_lexeme$cobol_lexeme (lexeme_ptr); if lexeme_env.error = 1 then return; if lexeme_env.token.type = 4 & lexeme_env.token.string = "." then do; call merge_to_copy; last_source_offset = lexeme_env.token.offset + 2; return; end; end; /* replace statement */ if substr (word, 1, lexeme_env.token.string_size) ^= "==" then return; do while (lexeme_env.token.string ^= "."); if (cr_used + 1) > cr_max then do; call T_alloc (addr (cr_control), "0"b); cr_max = cr_cap / 3; end; cr_used = cr_used + 1; call pseudo_text ("L"); if lexeme_env.error = 1 | ^(lexeme_env.token.type = 3 & lexeme_env.token.string = "by") then return; call get_next_lexeme (""); call pseudo_text ("R"); end; call merge_to_copy; call replace_process; lexeme_env.indicators.copy_replace = "0"b; end process_replace_statement; init: proc; /* INITILIZATION */ /*[5.1-2]*/ if ecs_info_table_.command then char10 = "******* "; else char10 = " "; next_new_position, last_source_offset = 1; last_copy_line, insert_space_span = 0; fill_last_ln = "0"b; replace_active = "0"b; /* Allocate Tables for Copy Replacement */ call T_alloc (addr (cr_control), "1"b); cr_max = cr_cap / 3; call T_alloc (addr (lbw_control), "1"b); lbw_max = lbw_cap / 2; call T_alloc (addr (cs_control), "1"b); cs_max = cs_cap * 4; allocate lexeme_env in (expand_cobol_source_area) set (lexeme_ptr); call cobol_lexeme$open (lexeme_ptr); lexeme_env.ecs_ptr = expand_cobol_source_area_ptr; old_file_ptr = ecs_info_table_.input_ptr; new_file_ptr = ecs_info_table_.output_ptr; p1 = lexeme_ptr; /* Make the old file known to cobol_lexeme. */ lexeme_ptr = p1; p1 -> lexeme_env.source_table.loc = old_file_ptr; lexeme_env.error = 0; call cobol_lexeme$set (p1, "file_name", old_file_ptr); if lexeme_env.error ^= 0 then do; bc = (next_new_position - 1) * 9; call finish; return; end; end init; copy: entry (ecs_info_ptr, bc, command, expand_cobol_source_area_ptr); call init; /*[4.0-4]*/ last_char_nl = 0; cpr_error: call clear_copy; /* Main processing loop for copy replacing */ do while ("1"b); start: lexeme_env.error = 0; call cobol_lexeme$find_copy (lexeme_ptr); if lexeme_env.error = 1 /* eof */ then do; call merge_to_end; bc = (next_new_position - 1) * 9; call finish; return; end; else do; save_copy_line = lexeme_env.token.line; copy_line_length = lexeme_env.current_line.length; save_copy_column = lexeme_env.token.column; copy_line_ptr = lexeme_env.current_line.loc; save_source_offset = lexeme_env.token.offset - 1; call process_copy_statement; end; end; process_copy_statement: proc; if lexeme_env.token.col_7 = "D" | lexeme_env.token.col_7 = "d" then return; /*[4.0-3]*/ state_pos = lexeme_env.token.offset; call get_lib_name; /* get_lib_name returns with next word */ if lexeme_env.token.type = 3 then if lexeme_env.token.string = "replacing" then do; /* We now have a COPY ... REPLACING statement to process. Perform syntax on statement and generate tables. */ lexeme_env.indicators.copy_replace = "1"b; lexeme_env.pseudo_text = 1; call rep_spec; /* Merge the library file with the specified replacements. */ if valid_lib then call replace_process; else goto cpr_error; end; else goto cpr_error; else if lexeme_env.token.type = 4 then if lexeme_env.token.string = "." then do; /* This is a simple COPY so merge the library and go back to start. */ if valid_lib then call merge_library; else goto cpr_error; return; end; else goto cpr_error; else goto cpr_error; end process_copy_statement; get_lib_name: proc; /* Get copy file name without converting to lower case. */ lexeme_env.indicators.lc = "0"b; call get_next_lexeme (""); lexeme_env.indicators.lc = "1"b; /* Save copy file name. */ lib_name = substr (word, 1, lexeme_env.token.string_size); /* make library known to cobol_lexeme. */ allocate lexeme_env in (expand_cobol_source_area) set (lexeme_ptr); lexeme_env.ecs_ptr = expand_cobol_source_area_ptr; p2 = lexeme_ptr; p2 -> lexeme_env.error = 0; p2 -> lexeme_env.mem_tab_ptr = p1 -> lexeme_env.mem_tab_ptr; p2 -> lexeme_env.x_ptr = p1 -> lexeme_env.x_ptr; lexeme_ptr = p1; /* call cobol_lexeme$reset(p1); */ /* Check for qualification of copy file name. */ call get_next_lexeme (""); if lexeme_env.token.string ^= "of" & lexeme_env.token.string ^= "in" /*[4.0-1]*/ then qual_name = ""; /*[4.0-1]*/ else do; /* Get library name without converting to lower case. */ lexeme_env.indicators.lc = "0"b; call get_next_lexeme (""); lexeme_env.indicators.lc = "1"b; /*[4.0-1]*/ qual_name = substr (word, 1, lexeme_env.token.string_size); /*[4.0-1]*/ end; /*[4.0-1]*/ call expand_cobol_source$find_incl_file /*[4.0-1]*/ (substr (lib_name, 1, length (lib_name)), /*[4.0-1]*/ substr (qual_name, 1, length (qual_name)), /*[4.0-1]*/ old_file_ptr, /*[4.0-1]*/ p2 -> lexeme_env.source_table.loc, /*[4.0-1]*/ code /*[4.0-1]*/); /*[4.0-1]*/ call cobol_lexeme$envinit (p2); /*[4.0-1]*/ if code ^= 0 then do; valid_lib = "0"b; /*[4.0-1]*/ free p2 -> lexeme_env; /*[4.0-1]*/ end; /*[4.0-1]*/ else do; valid_lib = "1"b; /*[4.0-1]*/ lib_file_ptr = p2 -> lexeme_env.source_table.loc; /*[4.0-1]*/ end; /* Call cobol_lexeme so when we return we will be looking at "REPLACING". */ /*[4.0-1]*/ if qual_name ^= "" then call get_next_lexeme (""); end get_lib_name; rep_spec: proc; /* Initialize text replacement control parameters. */ semi_sw, comma_sw = 0; cr_used, cr_largest = 0; comp_str_used = 1; /* Get token after 'replacing'. */ call get_next_lexeme (""); /* Main loop for processing replacing specification. */ do while (lexeme_env.token.string ^= "."); /* Check and see if tcr_table is full. */ if (cr_used + 1) > cr_max then do; call T_alloc (addr (cr_control), "0"b); cr_max = cr_cap / 3; end; cr_used = cr_used + 1; /* Process the left specitication and build the replacement table. */ call left_spec; /* Check for the word 'by'. */ if lexeme_env.token.string ^= "by" then do; cr_used = cr_used - 1; goto cpr_error; end; call get_next_lexeme (""); /* Scan off the word 'by' and process the right specitication. */ call right_spec; /* put skip edit ("key ->", substr(compare_string,comp_start(cr_used),comp_len(cr_used)),"<-") (a); */ end; /* end of main loop */ lexeme_env.indicators.copy_replace = "0"b; end rep_spec; left_spec: proc; /* This routine calls substr_word with an indicator to process the compare text */ call subst_word ("L"); end left_spec; right_spec: proc; /* This routine calls substr_word with an indicator to process the replacement text */ call subst_word ("R"); end right_spec; subst_word: proc (mode); dcl mode char (1); /* This routines identifies ==pseudo-text== identifier literal word and calls the appropiate subroutine for process. On entry word contains the token. */ if substr (word, 1, lexeme_env.token.string_size) = "==" /* pseudo-text delimiter */ then call pseudo_text (mode); else if token.type = 3 /* word*/ then call ident (mode); else if token.type = 2 then call literal (mode); else goto cpr_error; end subst_word; pseudo_text: proc (mode); dcl mode char (1); dcl c2 char (2); text_string = ""; if mode = "R" then do; call cobol_lexeme$find_pseudo_text (lexeme_ptr); if lexeme_env.error = 1 then goto cpr_error; /* Save offset and span of replacement text. */ repl_offset (cr_used) = lexeme_env.token.offset; repl_span (cr_used) = lexeme_env.token.span; end; /* Process left specification pseudo-text. */ else do; /* Scan past current '==' and get first token in psuedo-text. */ call get_next_lexeme ("text_word"); if substr (word, 1, lexeme_env.token.string_size) = "," | substr (word, 1, lexeme_env.token.string_size) = ";" then do; /* Special processing if comma or semi-colon. */ text_string = " " || substr (word, 1, lexeme_env.token.string_size); call get_next_lexeme (""); if substr (word, 1, lexeme_env.token.string_size) ^= "==" then text_string = ""; end; do while (substr (word, 1, lexeme_env.token.string_size) ^= "=="); text_string = text_string || " " || substr (word, 1, lexeme_env.token.string_size); call get_next_lexeme (""); /*[4.0-2]*/ if lexeme_env.error ^= 0 then go to cpr_error; end; /* Insert pseudo-text into the compare_string and update the parameters in cr_table. */ text_string_length = length (text_string); comp_start (cr_used) = comp_str_used; /* Check and see if text_string will fit into compare_string. */ do while ((text_string_length + comp_str_used) > cs_max); call T_alloc (addr (cs_control), "0"b); cs_max = cs_cap * 4; end; substr (compare_string, comp_str_used, text_string_length) = text_string; comp_len (cr_used) = text_string_length; comp_str_used = comp_str_used + text_string_length; if text_string_length > cr_largest then cr_largest = text_string_length; /* Test and set an indicator if pseudo-text consists solely of a comma(,) or a semi-colon(;). */ if text_string_length = 2 then do; c2 = substr (text_string, 1, 2); if c2 = " ;" then semi_sw = cr_used; else if c2 = " ," then comma_sw = cr_used; end; end; /* Position to 'by or '.' on return. */ call get_next_lexeme (""); return; end pseudo_text; ident: proc (mode); dcl mode char (1); dcl replacement_span fixed bin; /* If this is the right specification save the offset of the source for replacement. */ if mode = "R" then do; repl_offset (cr_used) = token.offset; replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span; end; else do; text_string = ""; text_string = text_string || " " || substr (word, 1, string_size); end; call get_next_lexeme (""); /* Continue to scan and build text_string string as long as the identifier is qualified with an "of" or "in". */ do while (substr (word, 1, lexeme_env.token.string_size) = "in" | substr (word, 1, lexeme_env.token.string_size) = "of"); if mode = "R" then replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span; else text_string = text_string || " " || substr (word, 1, lexeme_env.token.string_size); call get_next_lexeme (""); if token.type ^= 3 /* type 3 = word */ then do; call copy_error (1); cr_used = cr_used - 1; goto cpr_error; end; if mode = "R" then replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span; else text_string = text_string || " " || substr (word, 1, lexeme_env.token.string_size); call get_next_lexeme (""); end; /* Check and see if the identifier is subscripted. If it is scan until a right paren ")" is found saving the tokens in text_string string; */ if substr (word, 1, lexeme_env.token.string_size) = "(" then do; if mode = "R" then replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span; else text_string = text_string || " ("; call get_next_lexeme (""); do while (substr (word, 1, lexeme_env.token.string_size) ^= ")"); if mode = "R" then replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span; else text_string = text_string || " " || substr (word, 1, lexeme_env.token.string_size); call get_next_lexeme (""); if string = "by" | string = "copy" | string = "." then do; call copy_error (5); goto cpr_error; end; end; if mode = "R" then replacement_span = (lexeme_env.token.offset - repl_offset (cr_used)) + lexeme_env.token.span; else text_string = text_string || " )"; call get_next_lexeme (""); end; /* If identifier is from right specification save the span in the source file. If the identifier is from the left specification insert the identifier into the compare string and make the entries is the cr_table for it. */ if mode = "R" then repl_span (cr_used) = replacement_span; else do; comp_start (cr_used) = comp_str_used; text_string_length = length (text_string); comp_len (cr_used) = text_string_length; /* Check and see if text_string will fit into compare_string */ do while ((text_string_length + comp_str_used) > cs_max); call T_alloc (addr (cs_control), "0"b); cs_max = cs_cap * 4; end; substr (compare_string, comp_str_used, text_string_length) = text_string; comp_str_used = comp_str_used + text_string_length; /* Check and update cr_largest if necessary. */ if text_string_length > cr_largest then cr_largest = text_string_length; end; end ident; literal: proc (mode); dcl mode char (1); if mode = "R" /* Process the left specification: Save the offset and the span of the replacement text from the source file. */ then do; repl_offset (cr_used) = lexeme_env.token.offset; repl_span (cr_used) = lexeme_env.token.span; end; /* Process the right specification: insert the literal into the compare_string and update the cr_table parameters. */ else do; comp_start (cr_used) = comp_str_used; comp_len (cr_used) = lexeme_env.token.string_size + 1; /* Check and see if literal will fit into compare_string. */ do while ((comp_len (cr_used) + comp_str_used) > cs_max); call T_alloc (addr (cs_control), "0"b); cs_max = cs_cap * 4; end; substr (compare_string, comp_str_used, lexeme_env.token.string_size + 1) = " " || substr (word, 1, lexeme_env.token.string_size); comp_str_used = comp_str_used + lexeme_env.token.string_size + 1; if (lexeme_env.token.string_size + 1) > cr_largest then cr_largest = (token.string_size + 1); end; /* Call cobol_lexeme to position to the next word on return. */ call get_next_lexeme (""); end literal; merge_library: proc; /* Copy the old source into the new source up to the copy statement. */ call merge_to_copy; span = p2 -> lexeme_env.source_table.size; substr (new_file, next_new_position, span) = substr (lib_file, 1, span); next_new_position = next_new_position + span; end merge_library; merge_to_end: proc; /* Check and see in any remaining text was on the last copy line. */ if fill_last_ln then do; substr (new_file, next_new_position, insert_space_span) = substr (spaces, 1, insert_space_span); next_new_position = next_new_position + insert_space_span; end; span = p1 -> lexeme_env.source_table.size - last_source_offset + 1; substr (new_file, next_new_position, span) = substr (old_file, last_source_offset, span); next_new_position = next_new_position + span; end merge_to_end; merge_to_copy: proc; /* Check and see if wee have to preserve the column position of remaining text on a line with a copy statement. */ /*[4.0-3]*/ state_span = lexeme_env.token.offset - state_pos + 1; if (last_copy_line = lexeme_env.token.line) | fill_last_ln then do; span = save_source_offset - last_source_offset + 1; if substr (old_file, last_source_offset, span) ^= substr (spaces, 1, span) then do; substr (new_file, next_new_position, insert_space_span) = substr (spaces, 1, insert_space_span); next_new_position = next_new_position + insert_space_span; if fill_last_ln then fill_last_ln = "0"b; end; end; /* Is the copy the first word on the current line? */ if substr (source_line, 8, save_copy_column - 8) = substr (spaces, 1, save_copy_column - 8) then fill_sw = "0"b; else fill_sw = "1"b; /* Do we want to include the beginning of the line to the copy. */ if fill_sw then span = save_source_offset - last_source_offset; else span = (save_source_offset - last_source_offset) - (save_copy_column - 2); if span > 0 then do; substr (new_file, next_new_position, span) = substr (old_file, last_source_offset, span); next_new_position = next_new_position + span; if fill_sw then do; substr (new_file, next_new_position, 1) = new_line_character; next_new_position = next_new_position + 1; end; end; if lexeme_env.token.column < (lexeme_env.current_line.length - 1) then do; ; last_source_offset = lexeme_env.token.offset + 1; fill_last_ln = "1"b; end; else do; fill_last_ln = "0"b; last_source_offset = lexeme_env.token.offset + 2; end; last_copy_line = lexeme_env.token.line; insert_space_span = lexeme_env.token.column; /*[4.0-4]*/ if ecs_info_table_.format_indicator then return; /*[4.0-3]*/ substr (new_file, next_new_position, state_span + 11) = /* emit the statement */ /*[5.1-2]*/ char10 || substr (old_file, state_pos, state_span) || " "; /*[4.0-3]*/ STR_PTR = addr (new_array (next_new_position)); /*[4.0-3]*/ SIZE = state_span + 11; /*[4.0-3]*/ do while ("1"b); /*[4.0-3]*/ CR_LOC = index (STR, " "); /*[4.0-3]*/ if CR_LOC = SIZE then go to MC; /*[4.0-3]*/ STR_PTR = addr (STR_ARRAY (CR_LOC + 1)); /*[4.0-3]*/ SIZE = SIZE - CR_LOC; /*[5.1-2]*/ if ecs_info_table_.command then substr (STR, 1, 7) = "*******"; /*[4.0-3]*/ end; MC: /*[4.0-3]*/ next_new_position = next_new_position + state_span + 11; end merge_to_copy; T_alloc: proc (TT_ptr, first_time); declare 1 TT_a based (TT_ptr), 2 loc ptr, 2 parity fixed bin, 2 cap fixed bin, 2 incr fixed bin; dcl TT_0 (TABLE_SIZE) aligned fixed bin (35) based (TABLE_PTR); dcl TT_1 (TABLE_SIZE) aligned fixed bin (35) based (TABLE_PTR); dcl TABLE_SIZE fixed bin; dcl (TT_ptr, TABLE_PTR) ptr; dcl first_time bit (1); TABLE_SIZE = TT_a.cap + TT_a.incr; if TT_a.parity = 0 then do; allocate TT_1 in (expand_cobol_source_area) set (TABLE_PTR); if ^first_time then do; do i = 1 to TT_a.cap; TT_1 (i) = TT_0 (i); end; TT_a.loc = TABLE_PTR; free TT_0; end; else TT_a.loc = TABLE_PTR; TT_a.parity = 1; end; else do; allocate TT_0 in (expand_cobol_source_area) set (TABLE_PTR); if ^first_time then do; do i = 1 to TT_a.cap; TT_0 (i) = TT_1 (i); end; TT_a.loc = TABLE_PTR; free TT_1; end; else TT_a.loc = TABLE_PTR; TT_a.parity = 0; end; TT_a.cap = TABLE_SIZE; end T_alloc; T_free: proc (TT_ptr); dcl 1 TT_a based (TT_ptr), 2 loc ptr, 2 parity fixed bin, 2 cap fixed bin, 2 incr fixed bin; dcl TT_0 (TT_a.cap) aligned fixed bin (35) based (TT_a.loc); dcl TT_1 (TT_a.cap) aligned fixed bin (35) based (TT_a.loc); dcl TT_ptr ptr; if TT_a.parity = 0 then free TT_0; else free TT_1; end T_free; clear_copy: proc; cr_used = 0; comp_str_used = 1; do i = 1 to cr_max; cr_table (i) = 0; end; do i = 1 to cs_max; substr (compare_string, i, 1) = " "; end; end clear_copy; finish: proc; lexeme_ptr = p1; free lexeme_env; call cobol_lexeme$close (p1); call T_free (addr (cs_control)); call T_free (addr (cr_control)); call T_free (addr (lbw_control)); end finish; get_next_lexeme: proc (entry); dcl entry char (9); if entry = "token" then call cobol_lexeme$token (lexeme_ptr); else if entry = "text_word" then call cobol_lexeme$text_word (lexeme_ptr); else call cobol_lexeme$cobol_lexeme (lexeme_ptr); if lexeme_env.error > 1 then if ^replace_active then goto cpr_error; else goto replace_err; end get_next_lexeme; replace_process: proc; dcl library_string char (cr_largest); /* Copy the old source into the new source up to the copy statement. */ if ^replace_active then do; call merge_to_copy; /* Make library file known to cobol lexeme. */ lexeme_ptr = p2; end; /* Initialize the replacemnt parameters and get the first library word. */ lbs_length, lbs_sum, lbw_used = 0; lbs_size = cr_largest; library_string = spaces; base_offset = 1; call build_library_string; read_more_text = "1"b; do while (read_more_text); /* end of file indicator */ matched_word_pos, spec_index = 0; call compare_text; /* If matched_word_pos returns greater than zero it will point to the first word matched in the library_string and spec_index will be the index to the specification in cr_table. */ /* put skip edit (matched_word_pos,"->",library_string,"<-") (f(4),x(2),3 a); */ if matched_word_pos > 0 then call replace_text; call build_library_string; end; /* do while not end of file */ if replace_active then do; replace_active = "0"b; goto next_replace; end; /* The remaining library text from the last replacement to the end of the segment must also be moved to the new source. */ move_span = (p2 -> lexeme_env.source_table.size - base_offset) + 1; /* Size contains the offset of the last character in the library file. Plus one is used to get the NL character. */ substr (new_file, next_new_position, move_span) = substr (lib_file, base_offset, move_span); next_new_position = next_new_position + move_span; /* Reset lexeme_ptr so cobol_lexeme will get tokens from the source file. */ free lexeme_env; lexeme_ptr = p1; /* Reset cr_table and clear compare_string. */ call clear_copy; build_library_string: proc; dcl chr char (1); read_next_word: call cobol_lexeme$text_word (lexeme_ptr); if lexeme_env.error = 1 | (replace_active & lexeme_env.token.type = 3 & lexeme_env.token.string = "replace") then do; library_string = spaces; lbw_table (*), lbs_length, lbs_sum = 0; read_more_text = "0"b; return; end; /* Is library word greater than largest compare search key if so no checking is needed and the words in the library string can be cleared */ word_length = lexeme_env.token.string_size; if (word_length + 1) > cr_largest then do; do j = 1 to lbw_max; lbw_table (j) = 0; end; lbw_used, lbs_length = 0; library_string = spaces; goto read_next_word; end; /* check for special processing for comma and semi */ if word_length = 1 then do; chr = substr (word, 1, 1); if (chr = "," & comma_sw < 1) | (chr = ";" & semi_sw < 1) then goto read_next_word; end; /* The library word will be used for comparision. Insert it into the library_string and update lbw_table. */ if lbw_used + 1 > lbw_max /* The Library Word Table is new full, allocate more space . */ then do; call T_alloc (addr (lbw_control), "0"b); lbw_max = lbw_cap / 2; end; lbw_used = lbw_used + 1; lbw_length (lbw_used) = lexeme_env.token.string_size + 1; lbw_offset (lbw_used) = token.offset; lbw_span (lbw_used) = token.span; substr (aword, 1, 1) = " "; substr (aword, 2, word_length) = substr (word, 1, word_length); word_length = word_length + 1; /* If the word will not fit into the library_string remove the oldest word from the left. Shift the remainging words to the lift to make rome for the new word and insert the new word. */ do while (lbs_length + word_length > lbs_size); lbs_sum = 0; do j = 1 to (lbw_used - 1); lbs_sum = lbs_sum + lbw_length (j); end; lbs_sum = lbs_size - lbs_sum; /* lbs_sum is now the size of the remaining space in the library_string */ if lbs_sum < word_length /* The space abailable in library_string is less than the length of the word. Remove a word from library-string */ then do; substr (library_string, lbs_sum + 1, lbw_length (1)) = substr (spaces, 1, lbw_length (1)); lbs_length = lbs_length - lbw_length (1); do j = 1 to (lbw_used - 1); lbw_table (j) = lbw_table (j + 1); end; lbw_used = lbw_used - 1; end; /* removing word from library_string */ end; /* do while */ /* Now we shift the library_string to the left to make room for the new word */ substr (library_string, 1, lbs_size) = substr (library_string, 1 + word_length, lbs_size - word_length); /* Insert word in library_string */ lbs_length = lbs_length + word_length; substr (library_string, lbs_size + 1 - word_length, word_length) = substr (aword, 1, word_length); end build_library_string; compare_text: proc; dcl ii fixed bin; ii = 1; start_compare: matched_word_pos = 0; do i = ii to cr_used while (matched_word_pos = 0); spec_index = i; if comp_len (spec_index) <= lbs_length then matched_word_pos = index (library_string, substr (compare_string, comp_start (spec_index), comp_len (spec_index))); end; /* if matched_word_pos is greater than zero it points to the first word matched in the library_string. The word matched in the library_string should be right justified. A check is made to see and if it is not the rest of the compare keys if any are used. */ if matched_word_pos > 0 then if (cr_largest - matched_word_pos + 1) ^= comp_len (spec_index) then do; ii = i; goto start_compare; end; end compare_text; replace_text: proc; /* Locate the starting word of the matched phrase from the library_string. */ lbs_sum = lbs_size - lbs_length; /* starting position of first word */ i = 0; do j = 1 to lbw_used while (lbs_sum < matched_word_pos); i = j; lbs_sum = lbs_sum + lbw_length (i); end; /* Move the library source from the last replacement to the current replacement to the new source */ /* put skip edit ("REP ->", substr(old_file,repl_offset(spec_index),repl_span(spec_index)),"<-") (a); */ if replace_active then do; move_span = lbw_offset (i) - last_source_offset; substr (new_file, next_new_position, move_span) = substr (old_file, last_source_offset, move_span); end; else do; move_span = lbw_offset (i) - base_offset; substr (new_file, next_new_position, move_span) = substr (lib_file, base_offset, move_span); end; /* Insert the replacement text from the source file */ next_new_position = next_new_position + move_span; substr (new_file, next_new_position, repl_span (spec_index)) = substr (old_file, repl_offset (spec_index), repl_span (spec_index)); /* Update next_new_position and base_offset for next time */ next_new_position = next_new_position + repl_span (spec_index); if replace_active then last_source_offset = lbw_offset (i) + lbw_span (i); else base_offset = lbw_offset (lbw_used) + lbw_span (lbw_used); /* Clear library string and library word table */ library_string = spaces; do i = 1 to lbw_max; lbw_table (i) = 0; end; lbw_used, lbs_length = 0; end replace_text; end replace_process; copy_error: proc (error_no); dcl error_no fixed bin; dcl error_msg (6) char (40) init ("A COBOL word is expected here", "End of text during error recovery", "The word BY is expected here", "Null or blank pseudo-text illegal", "Unmatched left parenthesis", "Error in finding include file"); dcl source_line char (current_line.length) based (current_line.loc); call ioa_ ("cobol: COPY REPLACING... ^a on line ^d.", error_msg (error_no), lexeme_env.token.line); end copy_error; /* STRUCTURE */ dcl 01 ecs_info_table aligned automatic structure like ecs_info_table_; /* BUILTIN */ dcl substr builtin; dcl length builtin; dcl addr builtin; dcl index builtin; /* CHARACTER */ dcl text_string char (256) varying; dcl (lib_name, qual_name) char (128) varying; /*[4.0-1]*/ dcl source_line char (copy_line_length) based (copy_line_ptr); dcl word char (32) based (lexeme_env.token.string_ptr); dcl aword char (265); dcl spaces char (254) init ((254)" "); dcl old_file char (1048576) based (old_file_ptr); dcl new_file char (1048576) based (new_file_ptr); /*[4.0-3]*/ dcl new_array (1048576) char (1) based (new_file_ptr); /*[4.0-3]*/ dcl STR char (SIZE) based (STR_PTR); /*[4.0-3]*/ dcl STR_ARRAY (SIZE) char (1) based (STR_PTR); /*[5.1-2]*/ dcl char10 char (10); dcl lib_file char (1048576) based (lib_file_ptr); dcl new_line_character char (1) init (" "); /* POINTERS */ dcl expand_cobol_source_area_ptr ptr; dcl lexeme_ptr ptr; dcl old_file_ptr ptr; dcl new_file_ptr ptr; dcl lib_file_ptr ptr; dcl (p1, p2) ptr; dcl copy_line_ptr ptr; /* BIT */ dcl read_more_text bit (1); dcl replace_active bit (1); dcl command bit (1); dcl fill_sw bit (1); dcl fill_last_ln bit (1); dcl valid_lib bit (1); /* ENTRIES */ dcl ioa_ entry options (variable); dcl expand_cobol_source$find_incl_file entry (char (*), char (*), ptr, ptr, fixed bin (35)); /*[4.0-1]*/ dcl cobol_lexeme$envinit entry (ptr); /*[4.0-1]*/ /* AREA */ dcl expand_cobol_source_area area based (expand_cobol_source_area_ptr); /* FIXED BINARY */ dcl bc fixed bin (24); dcl save_copy_line fixed bin; dcl copy_line_length fixed bin; dcl next_new_position fixed bin (35); dcl cr_used fixed bin; dcl cr_largest fixed bin; dcl comma_sw fixed bin; dcl semi_sw fixed bin; /* 550 */ dcl (span, last_char_nl) fixed bin (24); dcl (i, j) fixed bin; dcl comp_str_used fixed bin init (1); dcl text_string_length fixed bin; dcl cr_max fixed bin; dcl lbw_max fixed bin; dcl lbw_used fixed bin; dcl cs_max fixed bin; dcl code fixed bin (35); /*[4.0-1]*/ dcl last_copy_line fixed bin; dcl insert_space_span fixed bin; dcl save_copy_column fixed bin; dcl save_source_offset fixed bin; dcl last_source_offset fixed bin (35); dcl base_offset fixed bin; dcl lbs_size fixed bin; dcl lbs_length fixed bin; dcl lbs_sum fixed bin; dcl word_length fixed bin; dcl move_span fixed bin; dcl matched_word_pos fixed bin; dcl spec_index fixed bin; /*[4.0-3]*/ dcl (state_span, state_pos, SIZE, CR_LOC) fixed bin, STR_PTR ptr; /* */ /* Compare String */ dcl compare_string char (cs_max) aligned based (cs_ptr); dcl /* Copy Replaceing Table */ 1 cr_table (cr_max) aligned based (cr_ptr), 2 comp_start unaligned fixed bin, /* begin char pos in compare string */ 2 comp_len unaligned fixed bin, /* length of compare key in string */ 2 repl_offset unaligned fixed bin (35), /* offset of replacement text in source */ 2 repl_span unaligned fixed bin (35); /* span of replacement text in source */ dcl /* Library Word Table */ 1 lbw_table (lbw_max) aligned based (lbw_ptr), 2 lbw_length unaligned fixed bin, /* length of word */ 2 lbw_offset unaligned fixed bin (35), /* offset of word in library */ 2 lbw_span unaligned fixed bin; /* span of word in library */ dcl /* Control table for compare string */ 1 cs_control, 2 cs_ptr ptr, 2 cs_parity fixed bin init (1), 2 cs_cap fixed bin init (100), /* 400 bytes */ 2 cs_incr fixed bin init (10); /* increase by 40 bytes */ dcl /* Control table for library word table */ 1 lbw_control, 2 lbw_ptr ptr, 2 lbw_parity fixed bin init (1), 2 lbw_cap fixed bin init (40), /* room for 25 library words */ 2 lbw_incr fixed bin init (10); /* add space for 5 more library words */ dcl /* Control Table for Copy Replaceing Table */ 1 cr_control, 2 cr_ptr ptr, 2 cr_parity fixed bin initial (1), 2 cr_cap fixed bin initial (60), /* room for 25 entries in cr_table */ 2 cr_incr fixed bin initial (15); /* increase cr_table by 5 entries */ /* */ %include cobol_lexeme_env; %include cobol_ecs_info; end cobol_expand_source_;  cobol_lexeme.pl1 05/24/89 1048.6rew 05/24/89 0836.9 327510 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8089), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8089 cobol_lexeme.pl1 Remove requirement for write permission to input files. END HISTORY COMMENTS */ /* Modified on 12/20/84 by FCH, [5.3-2], source prog with r access caused abort */ /* Modified on 10/24/83 by FCH, [5.3-1], ignore COPY in ID, phx14180(BUG599) */ /* Modified on 02/26/79 by FCH, [4.0-1], qualified copy file names */ /* Created for Version 4.0 */ /* format: style3 */ cobol_lexeme: proc (lexeme_ptr); declare lexeme_ptr ptr; dcl (addr, fixed, index, null, substr, translate, unspec) builtin; declare hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); declare hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); declare hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); declare (env_ptr, s_ptr) ptr, sname char (*); declare bc fixed bin (24), code fixed bin (35); declare lc fixed bin; declare ch char (1), ch2 char (2), ch_val fixed bin; declare key_word char (32) varying; declare saved_offset fixed bin (35); declare (cont, new_line, more, scan_mode) bit (1); declare (res, dec_pt_count, sign_count) fixed bin, mask bit (8); declare (i, j) fixed bin, p ptr; declare file_name char (44); declare (old, new, size, tok_size) fixed bin; declare dir_name char (168), entry_name char (32); declare (e_offset, e_span) fixed bin (35); declare 1 b, 2 line fixed bin, 2 column fixed bin, 2 type fixed bin, 2 offset fixed bin (35), 2 span fixed bin, 2 string_size fixed bin (35), 2 string_cap fixed bin, 2 string_ptr ptr, 2 string char (32) varying, 2 col_7 char (1); declare ldn fixed bin; declare last_token_space bit (1); declare error_table_$zero_length_seg fixed bin (35) ext; declare error_table_$segknown fixed bin (35) ext; declare ss char (1000000) based; declare sa (1000000) char (1) based; declare bit9 bit (9) based; dcl alloc_1 char (lexeme_env.alloc.cap1) based (lexeme_env.alloc.ptr1); dcl alloc_2 char (lexeme_env.alloc.cap2) based (lexeme_env.alloc.ptr2); declare mem_tab (0:511) bit (8) based (mem_tab_ptr); declare x (0:511) fixed bin (8) based (x_ptr); declare expand_cobol_source_area area based (ecs_ptr); declare find_include_file_$initiate_count entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35)); /* ignore space tokens, separator comma and separator semi-colon */ call get_token; ch = lexeme_env.token.string_ptr -> sa (1); do while (lexeme_env.error = 0 & (lexeme_env.token.type = 1 | (lexeme_env.token.type = 4 & lexeme_env.token.string_size = 1 & (ch = ";" | ch = ",")))); call get_token; ch = lexeme_env.token.string_ptr -> sa (1); end; return; /* initiate usage of cobol_lexeme.pl1 */ open: entry (lexeme_ptr); allocate mem_tab in (expand_cobol_source_area); do i = 0 by 1 to 127; mem_tab (i) = m_t (i); end; do i = 128 by 1 to 511; mem_tab (i) = "0"b; end; allocate x in (expand_cobol_source_area); do i = 0 by 1 to 127; x (i) = x_i (i); end; do i = 128 by 1 to 511; x (i) = 10; end; /*5.3-1]*/ state = 1; tf = "0"b; return; /* terminate usage of cobol_lexeme.pl1 */ close: entry (lexeme_ptr); free mem_tab; free x; return; /* initialize scanning of source file */ envinit: entry (lexeme_ptr); /*[4.0-1]*/ call set_bc (lexeme_env.source_table.loc); /*[4.0-1]*/ return; set: entry (lexeme_ptr, sname, s_ptr); file_name = sname; i = 44; do while (i > 0 & substr (file_name, i, 1) = " "); i = i - 1; end; if i > 11 then if substr (file_name, i - 10, 11) = ".incl.cobol" then do; call find_include_file_$initiate_count ("cobol", s_ptr, sname, bc, lexeme_env.source_table.loc, code); if code = error_table_$zero_length_seg then lexeme_env.error = 2; else call env_set; return; end; lexeme_env.source_table.loc = s_ptr; /*[4.0-1]*/ call set_bc (lexeme_env.source_table.loc); /*[4.0-1]*/ return; set_bc: proc (p); /*[4.0-1]*/ dcl p ptr; call hcs_$fs_get_path_name (p, dir_name, ldn, entry_name, code); call hcs_$initiate_count (dir_name, entry_name, "", bc, 1, p, code); if code = error_table_$segknown then code = 0; call env_set; /*[4.0-1]*/ end; env_set: proc; /*[4.0-1]*/ dcl ch char (1), p ptr; /*[4.0-1]*/ if code = 0 /*[4.0-1]*/ then do; i, j = divide (bc, 9, 31, 0); /*[4.0-1]*/ p = lexeme_env.source_table.loc; /*[4.0-1]*/ ch = p -> sa (j); /*[4.0-1]*/ do while (ch ^= " "); /*[4.0-1]*/ j = j - 1; /*[4.0-1]*/ ch = p -> sa (j); /*[4.0-1]*/ end; /*[4.0-1]*/ call hcs_$set_bc_seg (p, j * 9, code); /*[5.3-2]*/ call env_init; /*[5.3-2]*/ return; /*[4.0-1]*/ end; /*[4.0-1]*/ lexeme_env.error = 2; end; env_init: proc; lexeme_env.source_table.offset = 1; lexeme_env.source_table.line = 0; lexeme_env.current_line.loc = null (); lexeme_env.next_line.loc = null (); addr (lexeme_env.indicators) -> bit9 = "01"b; lexeme_env.alloc.cap1 = 512; /*[4.0-1]*/ lexeme_env.alloc.parity = 0; allocate alloc_1 in (expand_cobol_source_area); lexeme_env.token.string_cap = 512; lexeme_env.token.string_ptr = lexeme_env.alloc.ptr1; lexeme_env.source_table.size = j; call get_line; end; find_copy: entry (lexeme_ptr); key_word = "copy"; call seek_word; return; /* scan to the word "replace" */ find_replace: entry (lexeme_ptr); /* scan to the word "copy" */ key_word = "replace"; call seek_word; return; /* scan to closing pseudo-text delimiter */ find_pseudo_text: entry (lexeme_ptr); lexeme_env.pseudo_text = 2; call get_token; if lexeme_env.error ^= 0 then return; if lexeme_env.token.type = 4 then do; if lexeme_env.token.string = "==" then do; lexeme_env.token.span = 0; return; end; end; else if lexeme_env.token.type = 1 /* space token */ then do; lexeme_env.token.type = 6; b = lexeme_env.token; call get_token; if lexeme_env.error ^= 0 then return; if lexeme_env.token.type = 4 then if lexeme_env.token.string = "==" then do; lexeme_env.token = b; return; end; end; lexeme_env.token.type = 6; b = lexeme_env.token; do while ("1"b); call get_token; if lexeme_env.error ^= 0 then go to fpt_1; e_offset = lexeme_env.token.offset; if lexeme_env.token.type = 1 then do; call get_token; if lexeme_env.error ^= 0 then go to fpt_1; end; if lexeme_env.token.type = 4 then if lexeme_env.token.string = "==" then go to fpt_2; end; fpt_1: lexeme_env.token = b; return; fpt_2: lexeme_env.token = b; lexeme_env.token.span = e_offset - b.offset; lexeme_env.pseudo_text = 1; return; /* ignore space tokens */ text_word: entry (lexeme_ptr); call get_token; do while (lexeme_env.error = 0 & lexeme_env.token.type = 1); call get_token; end; return; /* find the next token */ token: entry (lexeme_ptr); call get_token; return; get_token: proc; if lexeme_env.current_line.length = 0 then do; lexeme_env.error = 1; res = 1; end; else do; lexeme_env.error = 0; dec_pt_count, sign_count = 0; lexeme_env.token.line = lexeme_env.source_table.line; lexeme_env.token.column = lexeme_env.current_line.column; lexeme_env.token.offset = lexeme_env.current_line.offset + lexeme_env.current_line.column - 1; lexeme_env.token.span, lexeme_env.token.string_size = 0; if lexeme_env.current_line.size >= 7 then lexeme_env.token.col_7 = lexeme_env.current_line.loc -> sa (7); if lexeme_env.current_line.column < 8 then do; lexeme_env.token.type = 1; if lexeme_env.current_line.length < 8 then do; lexeme_env.token.span = lexeme_env.current_line.length - lexeme_env.current_line.column; lexeme_env.current_line.column = lexeme_env.current_line.length; end; else do; lexeme_env.token.span = 8 - lexeme_env.current_line.column; lexeme_env.current_line.column = 8; end; call space; res = 1; end; else do; ch = lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column); if ch = " " | ch = " " then do; lexeme_env.token.type = 1; call space; res = 1; end; else res = 2; end; end; go to st (res); st (1): return; st (2): go to l (x (fixed (unspec (ch), 15))); /* cobol word */ l (1): lexeme_env.token.type = 3; word: mask = "1"b; call swm; call look; go to w (res); w (1): wd_1: if lexeme_env.token.string_ptr -> sa (lexeme_env.token.string_size) = "-" then lexeme_env.token.type = 5; if lexeme_env.indicators.lc then substr (lexeme_env.token.string_ptr -> ss, 1, lexeme_env.token.string_size) = translate (substr (lexeme_env.token.string_ptr -> ss, 1, lexeme_env.token.string_size), lower_case_alphabet); ss1: if lexeme_env.token.string_size <= 32 then lexeme_env.token.string = substr (lexeme_env.token.string_ptr -> ss, 1, lexeme_env.token.string_size); return; w (2): if lexeme_env.current_line.column + 1 < lexeme_env.current_line.length then if substr (lexeme_env.current_line.loc -> ss, lexeme_env.current_line.column + 1, 2) = "==" then go to wd_1; go to comm; w (3): go to comm; /* numeric literal */ l (2): lexeme_env.token.type = 2; num_lit: mask = "01"b; call swm; call look; go to nl1 (res); nl1 (1): return; nl1 (2): if dec_pt_count > 0 then go to comm; if ch = ";" then go to comm; call move_char; dec_pt_count = 1; go to num_lit; nl1 (3): if ch = "-" | ("1"b & mem_tab (fixed (unspec (ch), 15))) then if dec_pt_count = 0 & sign_count = 0 then do; lexeme_env.token.type = 3; go to word; end; go to comm; /* " */ l (3): lexeme_env.token.type = 2; call move_char; mask = "0000001"b; al_1: call swnm; if lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column) = " " then do; call cont_lit; go to al1 (res); al1 (1): al1 (2): go to comm; al1 (3): lexeme_env.token.span = lexeme_env.token.span + 1; go to al_1; end; call move_lit_char; al_2: call look; go to al2 (res); al2 (1): if ch = " " then do; call cont_lit; go to al21 (res); al21 (1): al21 (2): go to ss1; al21 (3): lexeme_env.token.span = lexeme_env.token.span + 1; go to al_2; end; go to ss1; al2 (2): go to ss1; al2 (3): al_3: call swnm; if lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column) = " " then do; call cont_lit; go to al3 (res); al3 (1): al3 (2): go to comm; al3 (3): go to al_3; end; go to al_1; /* ,; */ l (5): lexeme_env.token.type = 4; call move_char; call look; go to sep (res); sep (1): go to ss1; sep (2): if "01"b & mem_tab (fixed (unspec (ch), 15)) then do; dec_pt_count = 1; lexeme_env.token.type = 2; go to num_lit; end; go to comm; sep (3): go to comm; /* +- */ l (6): l (18): sign_count = 1; lexeme_env.token.type = 3; call move_char; call look; go to sgn (res); sgn (1): lexeme_env.token.type = 3; go to ss1; sgn (2): go to comm; sgn (3): if "01"b & mem_tab (fixed (unspec (ch), 15)) then do; lexeme_env.token.type = 2; go to num_lit; end; go to comm; /* * */ l (7): lexeme_env.token.type = 3; call move_char; call look; go to ask (res); ask (1): go to ss1; ask (2): go to comm; ask (3): if ch = "*" then do; call move_char; call look; go to exp (res); exp (1): go to ss1; exp (2): exp (3): go to comm; end; go to comm; /* */ l (9): l (16): l (17): lexeme_env.token.type = 3; dlm: call move_char; dlm_1: call look; go to wd (res); wd (1): go to ss1; wd (2): wd (3): go to comm; /* other characters */ l (8): l (10): comm: lexeme_env.token.type = 5; com_ent: mask = "00000001"b; call swnm; if new_line then do; call merge; if cont then do; cont = "0"b; go to com_ent; end; end; if lexeme_env.current_line.column >= 9 then do; if lexeme_env.token.string_size > 2 then do; if lexeme_env.indicators.copy_replace & lexeme_env.pseudo_text = 2 then do; if substr (lexeme_env.current_line.loc -> ss, lexeme_env.current_line.column - 2, 2) = "==" then do; lexeme_env.token.span = lexeme_env.token.span - 2; lexeme_env.token.string_size = lexeme_env.token.string_size - 2; lexeme_env.current_line.column = lexeme_env.current_line.column - 2; end; end; end; end; return; /* ( */ l (11): lexeme_env.token.type = 4; call move_char; go to ss1; /* ) */ l (13): lexeme_env.token.type = 4; call move_char; go to ss1; /* . */ l (14): lexeme_env.token.type = 4; call move_char; call look; go to per (res); per (1): go to ss1; per (2): if "01"b & mem_tab (fixed (unspec (ch), 15)) then do; dec_pt_count = 1; lexeme_env.token.type = 2; go to num_lit; end; go to comm; per (3): go to comm; /* = */ l (15): lexeme_env.token.type = 4; if lexeme_env.current_line.column < lexeme_env.current_line.size then do; call move_char; ch = lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column); if ch = "=" then do; call move_char; if ^lexeme_env.indicators.copy_replace then go to dlm_1; go to ptxt (lexeme_env.pseudo_text); ptxt (1): lexeme_env.pseudo_text = 2; go to ss1; ptxt (2): ptxt (3): lexeme_env.pseudo_text = 1; go to dlm_1; end; go to dlm_1; end; go to dlm; end; cont_lit: proc; /* res = 1 not continuation card res = 2 first non blank character character not QUOTE res = 3 first non blank character character QUOTE not followed by CR */ call next_cont; if ^cont then do; res = 1; return; end; call get_line; do while ("1"b); if j >= 13 then do; p = lexeme_env.current_line.loc; j = 12; do while (p -> sa (j) = " "); j = j + 1; end; if p -> sa (j) ^= """" then do; res = 2; return; end; if p -> sa (j + 1) ^= " " then do; lexeme_env.token.span = lexeme_env.token.span + j; lexeme_env.current_line.column = j + 1; res = 3; return; end; end; call next_cont; if ^cont then do; res = 1; return; end; lexeme_env.token.span = lexeme_env.token.span + lexeme_env.current_line.length; call get_line; end; end; space: proc; /* form the space token */ do while ("1"b); i = lexeme_env.current_line.column; /* find non-blank character */ p = lexeme_env.current_line.loc; do while (p -> sa (i) = " "); i = i + 1; end; lexeme_env.token.span = lexeme_env.token.span + i - lexeme_env.current_line.column; /* adjust span */ lexeme_env.current_line.column = i; if p -> sa (i) ^= " " then return; lexeme_env.token.span = lexeme_env.token.span + 1; more = "1"b; do while (more); call get_line; if lexeme_env.current_line.length = 0 then return; /* card too small */ if lexeme_env.current_line.length < 8 then lexeme_env.token.span = lexeme_env.token.span + lexeme_env.current_line.length; else /* comment line */ if lexeme_env.current_line.loc -> sa (7) = "*" then lexeme_env.token.span = lexeme_env.token.span + lexeme_env.current_line.length; else /* continuation line */ if lexeme_env.current_line.loc -> sa (7) = "-" then if lexeme_env.current_line.length < 13 then lexeme_env.token.span = lexeme_env.token.span + lexeme_env.current_line.length; else do; lexeme_env.token.span = lexeme_env.token.span + 11; lexeme_env.current_line.column = 12; more = "0"b; end; else do; lexeme_env.token.span = lexeme_env.token.span + 7; lexeme_env.current_line.column = 8; more = "0"b; end; end; end; end; look: proc; /* res = 1 space new_line )( EOF .,;-separator == res = 2 .,; res = 3 other */ res = 1; ch = ""; if lexeme_env.current_line.length = 0 then return; ch = lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column); if ch = " " | ch = " " then return; if ch = "." | ch = "," | ch = ";" then if lexeme_env.current_line.column = lexeme_env.current_line.size then do; call next_cont; if cont then do; res = 2; return; end; else do; res = 1; return; end; end; else do; ch2 = substr (lexeme_env.current_line.loc -> ss, lexeme_env.current_line.column + 1, 2); if substr (ch2, 1, 1) = " " then do; res = 1; return; end; else do; res = 2; if ch2 = "==" then res = 1; return; end; end; else if ch = "(" | ch = ")" then do; res = 1; return; end; else do; res = 3; call p_test; end; end; p_test: proc; if ch = "=" & lexeme_env.current_line.column + 1 < lexeme_env.current_line.length then if lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column + 1) = "=" then res = 1; end; merge: proc; call next_cont; if ^cont then return; lexeme_env.token.span = lexeme_env.token.span + lexeme_env.current_line.length - lexeme_env.current_line.column + 1; do while (cont); call get_line; if lexeme_env.current_line.size ^= 7 then do; i = 12; do while (lexeme_env.current_line.loc -> sa (i) = " "); i = i + 1; end; lexeme_env.token.span = lexeme_env.token.span + i - 1; lexeme_env.current_line.column = i; return; end; call next_cont; end; end; next_cont: proc; cont = "0"b; if lexeme_env.next_line.length = 0 then return; if lexeme_env.next_line.size < 12 then return; if lexeme_env.next_line.loc -> sa (7) ^= "-" then return; cont = "1"b; end; move_char: proc; scan_mode = "0"b; call m_c; end; move_lit_char: proc; scan_mode = "1"b; call m_c; end; m_c: proc; if lexeme_env.token.string_size = lexeme_env.token.string_cap then call alloc_lexeme; lexeme_env.token.string_size = lexeme_env.token.string_size + 1; lexeme_env.token.string_ptr -> sa (lexeme_env.token.string_size) = lexeme_env.current_line.loc -> sa (lexeme_env.current_line.column); lexeme_env.current_line.column = lexeme_env.current_line.column + 1; lexeme_env.token.span = lexeme_env.token.span + 1; if scan_mode | lexeme_env.current_line.column <= lexeme_env.current_line.size then return; call merge; end; get_line: proc; if lexeme_env.current_line.loc = null () then do; call fill_next_line; lexeme_env.current_line = lexeme_env.next_line; lexeme_env.source_table.line = lexeme_env.source_table.line + 1; if lexeme_env.current_line.size ^= 0 then call fill_next_line; return; end; else if lexeme_env.current_line.length = 0 then return; lexeme_env.current_line = lexeme_env.next_line; lexeme_env.source_table.line = lexeme_env.source_table.line + 1; if lexeme_env.current_line.length = 0 then return; call fill_next_line; end; fill_next_line: proc; declare (sl, sz) fixed bin; declare ch char (1), p ptr; if lexeme_env.source_table.offset > lexeme_env.source_table.size then do; lexeme_env.next_line.length = 0; lexeme_env.next_line.loc = addr (lexeme_env.source_table.loc -> sa (lexeme_env.source_table.size)); end; else do; p, lexeme_env.next_line.loc = addr (lexeme_env.source_table.loc -> sa (lexeme_env.source_table.offset)); sl = lexeme_env.source_table.size - lexeme_env.source_table.offset + 1; sz = index (substr (lexeme_env.next_line.loc -> ss, 1, sl), " "); lexeme_env.next_line.offset = lexeme_env.source_table.offset; lexeme_env.next_line.length = sz; lexeme_env.next_line.column = 1; lexeme_env.source_table.offset = lexeme_env.source_table.offset + sz; sz = sz - 1; if sz ^= 0 then do; ch = p -> sa (sz); do while (ch = " "); sz = sz - 1; if sz = 0 then ch = "~"; else ch = p -> sa (sz); end; end; lexeme_env.next_line.size = sz; end; end; /* Find a copy or replace statement not contained within a comment entry in the IDENTIFICATION DIVISION 1: XT: eof, copy, replace 2: ed, dd, pd 3: id 1: otherwise 2: find COPY/REPLACE 3: XT: eof 2: ed, dd, pd 4: pn. 3: otherwise 4: XT: eof, copy, replace 2: ed, dd, pd 5: otherwise 5: XT: eof 2: ed, dd, pd 4: pn. 5: otherwise */ /*[5.3-1]*/ dcl tf bit (1), found bit (1); /*[5.3-1]*/ dcl state fixed bin static internal; /*[5.3-1]*/ dcl swexit label; /*[5.3-1]*/ dcl ident char (14) varying init ("identification"); /*[5.3-1]*/ dcl div char (8) varying init ("division"); /*[5.3-1]*/ dcl env char (11) varying init ("environment"); /*[5.3-1]*/ dcl dat char (4) varying init ("data"); /*[5.3-1]*/ dcl proc char (9) varying init ("procedure"); /*[5.3-1]*/ dcl cpy char (4) varying init ("copy"); /*[5.3-1]*/ dcl rpl char (7) varying init ("replace"); seek_word: proc; /* find COPY or REPLACE */ /*[5.3-1]*/ swexit = swx1; /*[5.3-1]*/ do while ("1"b); /*[5.3-1]*/ go to sw (state); sw (1): /* initial state */ /*[5.3-1]*/ call sw1; /*[5.3-1]*/ go to swx; sw (2): /* ID, DD, PD found */ /*[5.3-1]*/ call SW; /*[5.3-1]*/ return; sw (3): /* ID found */ /*[5.3-1]*/ call sw3; /*[5.3-1]*/ go to swx; sw (4): /* proc-name found */ /*[5.3-1]*/ call sw4; /*[5.3-1]*/ go to swx; sw (5): /* COPY, REPLACE found */ /*[5.3-1]*/ call sw5; /*[5.3-1]*/ go to swx; swx: /*[5.3-1]*/ end; swx1: end; sw1: proc; /* initial state */ /*[5.3-1]*/ do while ("1"b); /*[5.3-1]*/ call GT; /* get a token */ /*[5.3-1]*/ call test_hdr ("0"b, 3); /* test for ID */ /*[5.3-1]*/ if found then return; /*[5.3-1]*/ call test_hdr ("1"b, 2); /* test for ED, DD, PD */ /*[5.3-1]*/ if found then return; /*[5.3-1]*/ call test_word (addr (key_word)); /* COPY, REPLACE */ /*[5.3-1]*/ if found then go to swexit; /*[5.3-1]*/ end; end; sw3: proc; /* after ID */ /*[5.3-1]*/ do while ("1"b); /*[5.3-1]*/ call GT; /* get a token */ /*[5.3-1]*/ call test_hdr ("1"b, 2); /* test for ED, DD, PD */ /*[5.3-1]*/ if found then return; /* get a token */ /*[5.3-1]*/ call test_pn (4); /* test for proc-name. */ /*[5.3-1]*/ if found then return; /*[5.3-1]*/ call test_word (addr (key_word)); /* COPY, REPLACE */ /*[5.3-1]*/ if found then go to swexit; /*[5.3-1]*/ end; end; sw4: proc; /* after proc-name. */ /*[5.3-1]*/ call GT1; /* get a token */ /*[5.3-1]*/ call test_hdr ("1"b, 2); /* test for ED, DD, PD */ /*[5.3-1]*/ if found then return; /*[5.3-1]*/ call test_word (addr (key_word)); /* COPY, REPLACE */ /*[5.3-1]*/ if found then go to swexit; /*[5.3-1]*/ tf = "1"b; /*[5.3-1]*/ state = 5; end; sw5: proc; /* after proc-name. */ /*[5.3-1]*/ do while ("1"b); /*[5.3-1]*/ call GT; /* get a token */ /*[5.3-1]*/ call test_hdr ("1"b, 2); /* test for ED, DD, PD */ /*[5.3-1]*/ if found then return; /*[5.3-1]*/ call test_pn (4); /* test for proc-name. */ /*[5.3-1]*/ if found then return; /*[5.3-1]*/ end; end; test_hdr: proc (md, st); /* test for division header */ /*[5.3-1]*/ dcl md bit (1), st fixed bin; /*[5.3-1]*/ if md /*[5.3-1]*/ then call tedp; /* ED, DD, PD */ /*[5.3-1]*/ else call test_word (addr (ident)); /* ID */ /*[5.3-1]*/ if ^found then return; /*[5.3-1]*/ call GT1; /* get token */ /*[5.3-1]*/ call test_word (addr (div)); /* DIVISION */ /*[5.3-1]*/ if ^found then go to test_id_xf; /*[5.3-1]*/ call gt; /* get token */ /*[5.3-1]*/ call per_test; /* . */ /*[5.3-1]*/ if ^found then go to test_id_xf; /*[5.3-1]*/ state = st; /*[5.3-1]*/ return; /* XT */ test_id_xf: /* XF */ /*[5.3-1]*/ tf = "1"b; end; tedp: proc; /* test for ED, DD, PD */ /*[5.3-1]*/ call test_word (addr (env)); /* ENVIRONMENT */ /*[5.3-1]*/ if found then return; /*[5.3-1]*/ call test_word (addr (dat)); /* DATA */ /*[5.3-1]*/ if found then return; /*[5.3-1]*/ call test_word (addr (proc)); /* PROCEDURE */ end; per_test: proc; /* test for period */ /*[5.3-1]*/ if lexeme_env.token.type = 4 /*[5.3-1]*/ then if lexeme_env.token.string = "." /*[5.3-1]*/ then found = "1"b; /*[5.3-1]*/ else found = "0"b; end; test_word: proc (p); /* test for specified string */ /*[5.3-1]*/ dcl p ptr; /*[5.3-1]*/ dcl word char (32) varying based (p); /*[5.3-1]*/ if lexeme_env.token.type = 3 & lexeme_env.token.string = word then found = "1"b; else found = "0"b; end; test_pn: proc (st); /* test for proc-name. */ /*[5.3-1]*/ dcl st fixed bin; /*[5.3-1]*/ call gt; /* get a token */ /*[5.3-1]*/ call per_test; /* . */ /*[5.3-1]*/ if ^found then go to test_pn_xf; /*[5.3-1]*/ found = "1"b; /*[5.3-1]*/ state = st; /*[5.3-1]*/ return; /* XT */ test_pn_xf: /* XF */ /*[5.3-1]*/ tf = "1"b; end; gt: proc; /* get a token */ /*[5.3-1]*/ if tf /* token already read */ /*[5.3-1]*/ then do; tf = "0"b; /*[5.3-1]*/ return; /*[5.3-1]*/ end; /*[5.3-1]*/ call get_token; /* read a token */ /*[5.3-1]*/ if lexeme_env.error ^= 0 then go to swexit; /* eof */ end; GT: proc; /* find word in margin A */ /*[5.3-1]*/ call gt; /* get a token */ /*[5.3-1]*/ do while (lexeme_env.token.column > 11 | lexeme_env.token.type ^= 3); /*[5.3-1]*/ call gt; /* get a token */ /*[5.3-1]*/ end; end; GT1: proc; /* find next real token */ /*[5.3-1]*/ call gt; /* get a token */ /*[5.3-1]*/ do while (lexeme_env.token.type = 1); /*[5.3-1]*/ call gt; /* get a token */ /*[5.3-1]*/ end; end; SW: proc; call get_token; do while (lexeme_env.error = 0 & ((lexeme_env.token.type ^= 3 & lexeme_env.token.type ^= 4) | ((lexeme_env.token.type = 3 | lexeme_env.token.type = 4) & substr (lexeme_env.token.string_ptr -> ss, 1, lexeme_env.token.string_size) ^= key_word))); call get_token; end; end; swm: proc; declare p ptr; swm_2: if lexeme_env.current_line.length = 0 then return; old, new = lexeme_env.current_line.column; p = lexeme_env.current_line.loc; tok_size = lexeme_env.current_line.size; swm_1: if new <= tok_size then if mask & mem_tab (fixed (unspec (p -> sa (new)), 35)) then do; new = new + 1; go to swm_1; end; call form_str; if new_line then do; call merge; if cont then do; cont = "0"b; go to swm_2; end; end; end; swnm: proc; declare p ptr; if lexeme_env.current_line.length = 0 then return; old, new = lexeme_env.current_line.column; p = lexeme_env.current_line.loc; tok_size = lexeme_env.current_line.size; swnm_1: if new <= tok_size then if mask & ^mem_tab (fixed (unspec (p -> sa (new)), 35)) then do; new = new + 1; go to swnm_1; end; call form_str; end swnm; form_str: proc; size = new - old; if new > tok_size then new_line = "1"b; else new_line = "0"b; if size = 0 then return; tok_size = size + lexeme_env.token.string_size; if tok_size > lexeme_env.token.string_cap then call alloc_lexeme; substr (lexeme_env.token.string_ptr -> ss, lexeme_env.token.string_size + 1, size) = substr (lexeme_env.current_line.loc -> ss, old); lexeme_env.token.string_size = lexeme_env.token.string_size + size; lexeme_env.token.span = lexeme_env.token.span + size; lexeme_env.current_line.column = new; end; alloc_lexeme: proc; if lexeme_env.alloc.parity = 0 then do; lexeme_env.alloc.parity = 1; lexeme_env.alloc.cap2 = 2 * lexeme_env.alloc.cap1; allocate alloc_2 in (expand_cobol_source_area); if lexeme_env.token.string_size ^= 0 then alloc_2 = substr (alloc_1, 1, lexeme_env.token.string_size); free alloc_1; lexeme_env.token.string_cap = lexeme_env.alloc.cap2; lexeme_env.token.string_ptr = lexeme_env.alloc.ptr2; end; else do; lexeme_env.alloc.parity = 0; lexeme_env.alloc.cap1 = 2 * lexeme_env.alloc.cap2; allocate alloc_1 in (expand_cobol_source_area); if lexeme_env.token.string_size ^= 0 then alloc_1 = substr (alloc_2, 1, lexeme_env.token.string_size); free alloc_2; lexeme_env.token.string_cap = lexeme_env.alloc.cap1; lexeme_env.token.string_ptr = lexeme_env.alloc.ptr1; end; end; /* Membership table for scans and character look-ups column 1: alphanumeric characters [0...9 a...z alloc...Z -] column 2: digits [0...9] column 3: picture characters [all printable characters except " ;] column 4: binary characters [0 1] column 5: delimiters [nl space " ( ) , . ;] column 6: delimiters [. ; ,] column 7: delimiters [nl "] column 8: delimiters [nl sp . ; ,] */ dcl m_t (0:127) bit (8) init ("00000000"b /* (NUL) 000 0 */, "00000000"b /* (SOH) 001 1 */, "00000000"b /* (STX) 002 2 */, "00000000"b /* (ETX) 003 3 */, "00000000"b /* (EOT) 004 4 */, "00000000"b /* (ENQ) 005 5 */, "00000000"b /* (ACK) 006 6 */, "00000000"b /* BEL 007 7 */, "00000000"b /* BS 010 8 */, "00000000"b /* HT 011 9 */, "00001011"b /* NL(LF) 012 10 */, "00000000"b /* VT 013 11 */, "00000000"b /* NP(FF) 014 12 */, "00000000"b /* (CR) 015 13 */, "00000000"b /* RRS(S0) 016 14 */, "00000000"b /* BRS(S1) 017 15 */, "00000000"b /* (DLE) 020 16 */, "00000000"b /* (DC1) 021 17 */, "00000000"b /* HLF(DC2) 022 18 */, "00000000"b /* (DC3) 023 19 */, "00000000"b /* HLR(DC4) 024 20 */, "00000000"b /* (NAK) 025 21 */, "00000000"b /* (SYN) 026 22 */, "00000000"b /* (ETB) 027 23 */, "00000000"b /* (CAN) 030 24 */, "00000000"b /* (EM) 031 25 */, "00000000"b /* (SUB) 032 26 */, "00000000"b /* (ESC) 033 27 */, "00000000"b /* (FS) 034 28 */, "00000000"b /* (GS) 035 29 */, "00000000"b /* (RS) 036 30 */, "00000000"b /* (US) 037 31 */, "00001001"b /* Space 040 32 */, "00100000"b /* ! 041 33 */, "00001010"b /* " 042 34 */, "00100000"b /* # 043 35 */, "00100000"b /* $ 044 36 */, "00100000"b /* % 045 37 */, "00100000"b /* & 046 38 */, "00100000"b /* ' 047 39 */, "00101001"b /* ( 050 40 */, "00101001"b /* ) 051 41 */, "00100000"b /* * 052 42 */, "00100000"b /* + 053 43 */, "00101101"b /* , 054 44 */, "10100000"b /* - 055 45 */, "00101101"b /* . 056 46 */, "00100000"b /* / 057 47 */, "11110000"b /* 0 060 48 */, "11110000"b /* 1 061 49 */, "11100000"b /* 2 062 50 */, "11100000"b /* 3 063 51 */, "11100000"b /* 4 064 52 */, "11100000"b /* 5 065 53 */, "11100000"b /* 6 066 54 */, "11100000"b /* 7 067 55 */, "11100000"b /* 8 070 56 */, "11100000"b /* 9 071 57 */, "00100000"b /* : 072 58 */, "00001101"b /* ; 073 59 */, "00100000"b /* < 074 60 */, "00100000"b /* = 075 61 */, "00100000"b /* > 076 62 */, "00100000"b /* ? 077 63 */, "00100000"b /* @ 100 64 */, "10100000"b /* A 101 65 */, "10100000"b /* B 102 66 */, "10100000"b /* C 103 67 */, "10100000"b /* D 104 68 */, "10100000"b /* E 105 69 */, "10100000"b /* F 106 70 */, "10100000"b /* G 107 71 */, "10100000"b /* H 110 72 */, "10100000"b /* I 111 73 */, "10100000"b /* J 112 74 */, "10100000"b /* K 113 75 */, "10100000"b /* L 114 76 */, "10100000"b /* M 115 77 */, "10100000"b /* N 116 78 */, "10100000"b /* O 117 79 */, "10100000"b /* P 120 80 */, "10100000"b /* Q 121 81 */, "10100000"b /* R 122 82 */, "10100000"b /* S 123 83 */, "10100000"b /* T 124 84 */, "10100000"b /* U 125 85 */, "10100000"b /* V 126 86 */, "10100000"b /* W 127 87 */, "10100000"b /* X 130 88 */, "10100000"b /* Y 131 89 */, "10100000"b /* Z 132 90 */, "00100000"b /* [ 133 91 */, "00100000"b /* \ 134 92 */, "00100000"b /* ] 135 93 */, "00100000"b /* ^ 136 94 */, "00100000"b /* _ 137 95 */, "00100000"b /* ` 140 96 */, "10100000"b /* a 141 97 */, "10100000"b /* b 142 98 */, "10100000"b /* c 143 99 */, "10100000"b /* d 144 100 */, "10100000"b /* e 145 101 */, "10100000"b /* f 146 102 */, "10100000"b /* g 147 103 */, "10100000"b /* h 150 104 */, "10100000"b /* i 151 105 */, "10100000"b /* j 152 106 */, "10100000"b /* k 153 107 */, "10100000"b /* l 154 108 */, "10100000"b /* m 155 109 */, "10100000"b /* n 156 110 */, "10100000"b /* o 157 111 */, "10100000"b /* p 160 112 */, "10100000"b /* q 161 113 */, "10100000"b /* r 162 114 */, "10100000"b /* s 163 115 */, "10100000"b /* t 164 116 */, "10100000"b /* u 165 117 */, "10100000"b /* v 166 118 */, "10100000"b /* w 167 119 */, "10100000"b /* x 170 120 */, "10100000"b /* y 171 121 */, "10100000"b /* z 172 122 */, "00100000"b /* { 173 123 */, "00100000"b /* | 174 124 */, "00100000"b /* } 175 125 */, "00100000"b /* ~ 176 126 */, "00000000"b /* DEL 177 127 */); /* character classes defined by the x table */ /* 1 A...Za...z 2 0...9 3 " 4 5 ,; 6 + 7 * 8 % 9 / 10 illegal 11 ( 12 nl , SP 13 ) 14 . 15 = 16 < 17 > 18 - */ dcl x_i (0:127) fixed bin (8) init (10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 12, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 12, 10, 3, 10, 10, 8, 10, 10, 11, 13, 7, 6, 5, 18, 14, 9, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 10, 5, 16, 15, 17, 10, 10, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 10, 10, 10, 10, 10, 10, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 10, 10, 10, 10, 10); dcl lower_case_alphabet char (128) static options (constant) init ("  !""#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"); %include cobol_lexeme_env; end;  cobol_operator_names_.alm 11/11/82 1550.1rew 11/11/82 1030.7 46629 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " Modified on 06/30/81 by FCH op 94 stop_cd_run added " Modified on 02/18/81 by FCH op 93 alt_rewrite added " Modified on 08/24/79 by PRP op 83 changed to alt_start_control " Modified on 05/09/77 by Bob Chang to add name for close_reel. " Modified on 04/14/77 by Bob Chang to add communication operator names. " Modified on 03/17/77 by Bob Chang to add new operator names. " Modified on 03/15/77 by Bob Chang to fix the bug for missing entry for operator 62. " Table of cobol operator names. " " Created on 1/17/77 by Bob Chang " name cobol_operator_names_ segdef cobol_operator_names_ cobol_operator_names_: equ first_n,0 first: zero 0,first_n last: zero 0,first_n+last_normal-first_normal-1) first_special: zero 0,0 last_special: zero 0,0 number_special: zero 0,0 use text first_normal: zero s0,17 zero s1,12 zero s2,16 zero s3,10 zero s4,11 zero s5,17 zero s6,12 zero s7,4 zero s8,8 zero s9,8 zero s10,14 zero s11,12 zero s12,13 zero s13,11 zero s14,13 zero s15,12 zero s16,17 zero s17,14 zero s18,14 zero s19,9 zero s20,11 zero s21,10 zero s22,13 zero s23,13 zero s24,19 zero s25,15 zero s26,17 zero s27,10 zero s28,18 zero s29,13 zero s30,13 zero s31,13 zero s32,9 zero s33,12 zero s34,11 zero s35,9 zero s36,15 zero s37,10 zero s38,15 zero s39,10 zero s40,12 zero s41,8 zero s42,12 zero s43,12 zero s44,11 zero s45,10 zero s46,11 zero s47,18 zero s48,8 zero s49,6 zero s50,13 zero s51,15 zero s52,6 zero s53,6 zero s54,12 zero s55,8 zero s56,11 zero s57,14 zero s58,15 zero s59,7 zero s60,10 zero s61,10 zero s62,12 zero s63,9 zero s64,8 zero s65,11 zero s66,18 zero s67,13 zero s68,19 zero s69,17 zero s70,12 zero s71,11 zero s72,10 zero s73,9 zero s74,11 zero s75,12 zero s76,10 zero s77,7 zero s78,13 zero s79,9 zero s80,13 zero s81,15 zero s82,13 zero s83,16 zero s84,12 zero s85,18 zero s86,10 zero s87,14 zero s88,15 zero s89,14 zero s90,18 zero s91,18 zero s92,12 zero s93,11 zero s94,11 last_normal: " s0: aci "call_ent_var_desc" 0 s1: aci "call_ent_var" 1 s2: aci "call_ext_in_desc" 2 s3: aci "return_mac" 3 s4: aci "call_ext_in" 4 s5: aci "call_ext_out_desc" 5 s6: aci "call_ext_out" 6 s7: aci "opch" 7 s8: aci "enable" 8 s9: aci "enable_1" 9 s10: aci "sort_entry_seq" 10 s11: aci "sort_release" 11 s12: aci "runtime_check" 12 s13: aci "sort_return" 13 s14: aci "sort_initiate" 14 s15: aci "real_to_real" 15 s16: aci "establish_cleanup" 16 s17: aci "sort_terminate" 17 s18: aci "revert_cleanup" 18 s19: aci "sort_comp" 19 s20: aci "accept_line" 20 s21: aci "init_start" 21 s22: aci "sort_commence" 22 s23: aci "start_control" 23 s24: aci "set_lin_file_status" 24 s25: aci "set_file_status" 25 s26: aci "dsply_user_output" 26 s27: aci "close_file" 27 s28: aci "dsply_error_output" 28 s29: aci "close_op_file" 29 s30: aci "open_ext_file" 30 s31: aci "open_int_file" 31 s32: aci "find_iocb" 32 s33: aci "check_attach" 33 s34: aci "attach_iocb" 34 s35: aci "open_file" 35 s36: aci "open_close_file" 36 s37: aci "check_file" 37 s38: aci "close_file_only" 38 s39: aci "init_write" 39 s40: aci "write_stream" 40 s41: aci "seek_key" 41 s42: aci "write_record" 42 s43: aci "stop_literal" 43 s44: aci "accept_date" 44 s45: aci "accept_day" 45 s46: aci "accept_time" 46 s47: aci "accept_day_of_week" 47 s48: aci "stop_run" 48 s49: aci "cancel" 49 s50: aci "inspect_tally" 50 s51: aci "inspect_replace" 51 s52: aci "linage" 52 s53: aci "delete" 53 s54: aci "delete_error" 54 s55: aci "read_key" 55 s56: aci "init_delete" 56 s57: aci "special_delete" 57 s58: aci "special_rewrite" 58 s59: aci "rewrite" 59 s60: aci "merge_init" 60 s61: aci "merge_comp" 61 s62: aci "merge_return" 62 s63: aci "init_read" 63 s64: aci "get_line" 64 s65: aci "read_record" 65 s66: aci "nonseq_read_record" 66 s67: aci "read_seek_key" 67 s68: aci "write_stream_linage" 68 s69: aci "read_key_for_read" 69 s70: aci "receive_comm" 70 s71: aci "accept_comm" 71 s72: aci "purge_comm" 72 s73: aci "send_comm" 73 s74: aci "enable_comm" 74 s75: aci "disable_comm" 75 s76: aci "close_reel" 76 s77: aci "init_cd" 77 s78: aci "alt_open_file" 78 s79: aci "alt_start" 79 s80: aci "alt_read_next" 80 s81: aci "alt_read_record" 81 s82: aci "alt_key_check" 82 s83: aci "alt_start_control" 83 s84: aci "alt_read_key" 84 s85: aci "alt_special_delete" 85 s86: aci "alt_delete" 86 s87: aci "alt_key_delete" 87 s88: aci "alt_rewrite_add" 88 s89: aci "alt_close_file" 89 s90: aci "alt_add_write_keys" 90 s91: aci "alt_write_seek_key" 91 s92: aci "alt_find_rec" 92 s93: aci "alt_rewrite" 93 s94: aci "stop_cd_run" 94 end  cobol_operators_.alm 05/24/89 1048.6rew 05/24/89 0837.5 861471 " *********************************************************** " * * " * Copyright, (C) BULL HN Information Systems Inc., 1989 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " HISTORY COMMENTS: " 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090), " audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): " MCR8090 cobol_operators_.alm Disallow duplicate prime keys in Indexed " Sequential files. " END HISTORY COMMENTS "Modified on 12/19/84 by FCH, [5.3-1], BUG573(phx16343), error detection can fail if ark used "Modified on 10/29/82 by FCH, [5.1-1], set mcode ptr, BUG536(phx12688) "Modified on 02/18/81 by FCH, [4.4-1], operator 93(alt_rewrite) added " Modified on 12/14/79 by PRP, cause ipr for bad overpunch data. "Modified on 11/05/79 by PRP, prevent close if file previously open " Modified on 10/31/79 by PRP, pass more system error messages to user "Modified on 09/06/79 by FCH, key of ref was being destroyed "Modified on 08/24/79 by PrP, [4.0-3], alt_start_control added " Modified on 07/10/79 by MHD, [4.0-2], fix linage problem " Modified on 07/17/79 by PRP, [4.0-1], MPM standard for attach and detach files "MODIFIED on 11/30/78 by FCH, [3.0-1], alternate record keys added "Modified on 051678 by FCH, [3.0-1], save and restore $x6 " Modified on 09/20/77 by Peter Krupp to extend trace interface to COBOL programs "Modified since Version 3.0 " " " " " " /*{*/ " cobol_operators_ segment " Bob Chang " March, 1976 " " NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE " " To add a new operator: " (1). Insert the "tra" instruction before the line with the comment: " " Please insert the next "tra" instruction before theis line. " (2). Put the operator calling sequence number on "tra" instruction. " The number is obtained by incrementing the last operator calling sequence " number by 1. " (3). Insert the operator before the line with the comment: " " Please insert the next operator before theis line. " (4). Be sure that no "end" statement exists at the end of the operator segment " which is to be inserted into cobol_operators_. " (5). Please put some comment before the operator. " " NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE " name cobol_operators_ " /*}*/ use text1 use text2 use text3 use text4 use text5 join /text/text1,text2,text3,text4,text5 use text1 include stack_header include stack_frame include eis_bits " segdef operator_table segdef cobol_operators_ " " Definitions of variables used by operators. Since all " of the operators execute using the stack frame of the " cobol program for their temporary storage, locations 32-61 " of the cobol stack frame are reserved for operator use. " " sp|6 has been reserved for probe. " equ cobol_code,1 code identifying cobol compiled prog equ maxpr,71 max precision of double fixed " equ display_ptr,32 equ descriptor_ptr,34 equ linkage_ptr,36 equ on_unit_ptr,30 equ op_return_offset,31 equ text_base_ptr,38 equ text_base_off,39 equ mcode,40 equ icode,41 equ status12,42 equ status3,43 equ retrycode,44 equ return_to_main_ptr,64 equ return_to_main_off,65 equ rts_code_ptr,66 equ rts_code,72 equ cobol_error_code,89 " " Definitions for cobol linkage variables used by operators. " equ cobol_data_ptr,8 equ control_ptr,10 equ ind_mask,116 equ file_info_ptr,12 equ call_cnt,14 equ x6_save,100 [3.0-1] equ subr_return_save,106 equ subr_return_save_off,107 equ pr4_save,108 equ rts_save,114 equ pr3_save,110 equ pr5_save,112 " equ ap,0 TEMP equ ab,1 TEMP equ bp,2 TEMP equ bb,3 TEMP equ sp,6 TEMP " bool blank,40 " cobol_operators_: " " THE FOLLOWING SECTION IS DIRECTLY REFERENCED FROM cobol PROGRAMS BY MEANS OF " ap|offset. FOR THIS REASON, THE ORDER OF THE FOLLOWING INSTRUCTIONS MUST " NOT BE CHANGED. " even operator_table: " " transfer vector for operators not referenced directly " by the cobol program. new operators may be added at the " end of the list only. " op_vector: entry_operators: tra call_ent_var_desc 0 tra call_ent_var 1 tra call_ext_in_desc 2 tra return_mac 3 tra call_ext_in 4 tra call_ext_out_desc 5 tra call_ext_out 6 tra opch 7 tra enable 8 tra enable_1 9 tra sort_entry_seq 10 tra sort_release 11 tra runtime_check 12 tra sort_return 13 tra sort_initiate 14 tra real_to_real 15 tra establish_cleanup 16 tra sort_terminate 17 tra revert_cleanup 18 tra sort_comp 19 tra accept_line 20 tra init_start 21 tra sort_commence 22 tra start_control 23 tra set_lin_file_status 24 tra set_file_status 25 tra dsply_user_output 26 tra close_file 27 tra dsply_error_output 28 tra close_op_file 29 tra open_ext_file 30 tra open_int_file 31 tra find_iocb 32 tra check_attach 33 tra attach_iocb 34 tra open_file 35 tra open_close_file 36 tra check_file 37 tra close_file_only 38 tra init_write 39 tra write_stream 40 tra seek_key 41 tra write_record 42 tra stop_literal 43 tra accept_date 44 tra accept_day 45 tra accept_time 46 tra accept_day_of_week 47 tra stop_run 48 tra cancel 49 tra inspect_tally 50 tra inspect_replace 51 tra linage 52 tra delete 53 tra delete_error 54 tra read_key 55 tra init_delete 56 tra special_delete 57 tra special_rewrite 58 tra rewrite 59 tra merge_init 60 tra merge_comp 61 tra merge_return 62 tra init_read 63 tra get_line 64 tra read_record 65 tra nonseq_read_record 66 tra read_seek_key 67 tra write_stream_linage 68 tra read_key_for_read 69 tra receive_comm 70 tra accept_comm 71 tra purge_comm 72 tra send_comm 73 tra enable_comm 74 tra disable_comm 75 tra close_reel 76 tra init_cd 77 tra alt_open_file 78 [3.0-1] tra alt_start 79 [3.0-1] tra alt_read_next 80 [3.0-1] tra alt_read_record 81 [3.0-1] tra alt_seek_key 82 [3.0-1] tra alt_start_control 83 [4.0-3] tra alt_read_key 84 [3.0-1] tra alt_special_delete 85 [3.0-1] tra alt_delete 86 [3.0-1] tra alt_key_delete 87 [3.0-1] tra alt_rewrite_add 88 [3.0-1] tra alt_close_file 89 [3.0-1] tra alt_add_write_keys 90 [3.0-1] tra alt_write_seek_key 91 [3.0-1] tra alt_find_rec 92 [3.0-1] tra alt_rewrite 93 [4.4-1] tra stop_cd_run 94 [4.4-3] " Please insert the next tra instruction before this line. " " " **************************************** " " The following operators are high used operators. " " **************************************** " " operators to call an entry variable " entered with pointer to entry in bp and number " of arguments in position in a, offset of arg list is in x0 " call_ent_var_desc_from_op: eaq 0,au there are descriptors tra call_ent_var_from_op do not use x0 call_ent_var_desc: eaq 0,au there are descriptors " call_ent_var: inhibit on stx0 pr6|return_to_main_off inhibit off call_ent_var_from_op: ora 4,dl insert cobol code epbpsb sp|0 get ptr to base of stack staq sb|0,1 save at head of list eppbp bp|0,* and ptr to entry save_display: eppap sb|0,1 get ptr to arg list var_call: sti sp|stack_frame.return_ptr+1 callsp bp|0 and transfer to entry " " operator to call an external procedure (same or diff seg). " entered with pointer to entry in bp and number of args " in position in a, offset of arg list is in x0 " call_ext_in_desc_from_op: call_ext_out_desc_from_op: eaq 0,au there are descriptors tra call_ext_in_from_op do not use x0 call_ext_in_desc: call_ext_out_desc: eaq 0,au there are descriptors " call_ext_in: call_ext_out: inhibit on stx0 pr6|return_to_main_off inhibit off call_ext_in_from_op: call_ext_out_from_op: epbpsb sp|0 get ptr to base of stack ora 4,dl insert cobol code (do this for now) staq sb|0,1 save at head of list eppap sb|0,1 get pointer to arg list " " This label is 'segdef'ed but is never transfered to directly. The segdef is " merely to allow default_error_handler to see if a fault occured as a result " of this particular instruction so that it can print a more informative " error message. " forward_call: sti sp|stack_frame.return_ptr+1 callsp bp|0 transfer to entry " " " Macro to generate the calling sequence for |[catch_pl1_]. When " invoked by the COBOL entry operator it will allow trace to monitor COBOL calls " to external procedures. (P. Krupp 09/20/77) macro trace " BEGIN MACRO trace ife &1,trace_ epaq * get segment number of cobol_operators_ lprp4 7|stack_header.lot_ptr,*au cobol_operators_ linkage pointer sprp2 7|stack_header.stack_end_ptr,* save entry pointer tsp2 |[catch_pl1_] invoke trace lprp2 7|stack_header.stack_end_ptr,* restore entry pointer ldx0 2|3 restore relocation offset ifend " END MACRO trace &end " Macro to generate code for the COBOL entry operator. The macro will generate " code for two entry operators. One for normal use and the other for using trace " in conjunction with COBOL programs. (P. Krupp 09/20/77) macro cobol_entry " BEGIN MACRO cobol_entry " " " entry for entry_version_1. " entry for setting up the pr0 for cobol operators_ and initializing " the stack frame and/or header. segdef &1entry_version_1 &1entry_version_1: ldx0 bp|0 get the relocation offset eppbp bp|-3 set pr2 to cobol entry location trace &1 epaq bp|0 get segment number of text lprplp sb|stack_header.lot_ptr,*au get seg no, offset of linkage from packed ptr eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame sprisp bb|stack_frame.prev_sp set back ptr of new frame spriap bb|stack_frame.arg_ptr save arg pointer eppab bb|0,7 get pointer to end of new frame spriab bb|stack_frame.next_sp set next pointer of new frame spriab sb|stack_header.stack_end_ptr set new stack end ptr eppsp bb|0 update sp " END MACRO cobol_entry &end cobol_entry trace_ tra eed trace has been invoked, finish rest of entry operator cobol_entry eed: lda ap|0 get 2*n_args in au, code in al cana 8,dl is there an extra arg tze 2,ic no ada 2,du yes, allow for it eppbb ap|2,au get ptr to descriptors spribb sp|descriptor_ptr set ptr in stack frame save_link: sprilp sp|linkage_ptr save ptr to linkage in stack head spribp sp|stack_frame.entry_ptr save ptr to entry point init_stack_join: spbpbp sp|text_base_ptr save ptr to base of text segment spbpbp sp|return_to_main_ptr set the segment number for cobol return location stz sp|stack_frame.operator_ret_ptr init operator return offset " eppap operator_table and pointer to operators spriap sp|stack_frame.operator_ptr save pointer to operator segment spriab sp|4 save pointer to end of frame for temp extensions " set the parameter for cobol_rts " pr6|68 and pr6|70 are reserved for cobol_rts_ epp0 pr6|rts_code_ptr spri0 pr6|70 point to the storage for rts_code_ptr epp0 pr6|rts_code spri0 pr6|rts_code_ptr point to the base of rts stack lda pr2|6 get the cobol_rts_ epp1 pr4|0,au* obtain the link of cobol_rts_ spri1 pr6|rts_save store the rts_save fld 2048,dl ora 4,dl staq pr6|68 stz pr6|73 set 0 for the use_code on error_stack epp4 pr4|0,0 get pr4 for operator spri2 pr6|return_to_main_ptr spri4 pr6|pr4_save save for future use spri2 pr4|16 store stat.entry_ptr lda pr4|call_cnt get the call_cnt tpl return_from_control data already initialized spri4 pr6|74 store the parameter epp0 return_from_control preset the return point spri0 pr6|stack_frame.return_ptr lda 2,dl load rts_code for cobol_control sta pr6|rts_code tra call_rts_from_op call cobol_control even return_from_control: epp3 return_from_call reset the return_ptr to cobol operators_ spri3 pr6|stack_frame.return_ptr epp1 pr6|pr4_save,* load pr4 epp3 pr1|control_ptr,* lxl1 pr3|27 anx1 1,du eaa 0,x1 arl 7 sta pr6|ind_mask ldi pr6|ind_mask epp3 pr1|cobol_data_ptr,* adwp3 16384,du spri3 pr6|pr3_save epp5 pr1|cobol_data_ptr,* adwp5 49152,du spri5 pr6|pr5_save epp0 pr6|stack_frame.operator_ptr,* spri0 pr6|subr_return_save set for subroutine calls within operators epp4 pr6|linkage_ptr,* epp2 pr6|stack_frame.entry_ptr,* aos pr1|call_cnt update the call_cnt lda pr1|call_cnt check the call_cnt tnz bp|6 skip one instruction, data already initialized. tra bp|5 " " " The operator for saveing the pointer register pr0, pr3 and pr5 " even return_from_pl1_op: epbp0 pr6|return_to_main_ptr,* reset the text base ptr to normal spri0 pr6|text_base_ptr even return_from_call: ldi pr6|ind_mask epp4 pr6|linkage_ptr,* reload pr4 epp3 pr6|pr3_save,* reload pr3 epp5 pr6|pr5_save,* reload pr5 epp0 pr6|stack_frame.operator_ptr,* reload pr0 tra pr6|return_to_main_ptr,* return to the cobol program " " The label for io return. " It skip one instruction in cobol program and reset return_ptr to normal " even io_return_to_reset: lda 1,du skip one instruction for io return asa pr6|return_to_main_off " " The label for reset the return_ptr before return. " even return_to_reset: epp0 return_from_call reset return_ptr back to normal spri0 pr6|stack_frame.return_ptr tra return_from_call " " " " " The operator for calling the cobol_rts_ routine. " " call_rts: epp2 pr6|rts_code get the stack pointer for rts call_rts_special: spri2 pr6|rts_code_ptr sotre the cobol_rts parameter call_rts_load_code: sta pr6|rts_code " call from cobol operator and the parameter is set already call_rts_from_op: epp2 pr6|rts_save,* get cobol_rts_ epbp7 pr6|0 set the stack header pointer epp0 pr6|68 set the argument pointer callsp bp|0 " " " " " " " The operator for the DISPLAY. " PR5 set to display area info. " " " main line code tsx0 pr0|32 = dsply_user_output, and " tsx0 pr0|34 = dsply_error_output. dsply_error_output: inhibit on stx0 pr6|return_to_main_off inhibit off epp4 pr6|pr4_save,* epp1 pr4|50 pointer to iox_$error_output lda 4,dl use retrycode as error switch tra display_op dsply_user_output: inhibit on stx0 pr6|return_to_main_off inhibit off epp4 pr6|pr4_save,* epp1 pr4|48 pointer to iox_$user_output lda 3,dl use retrycode as error switch display_op: tsx6 pr0|subr_put_chars szn pr6|mcode tze io_return_to_reset display good, NO retry lda pr6|retrycode sta pr6|cobol_error_code tra cobol_error_from_op output error message, and retry " " " " The sort entry for compare procedure. " sort_entry_seq: eppbp bp|-4 eppbb sb|stack_header.stack_end_ptr,* get ptr to next stack frame sprisp bb|stack_frame.prev_sp set back ptr of new frame spriap bb|stack_frame.arg_ptr save arg pointer eppab bb|0,7 get pointer to end of new frame spriab bb|stack_frame.next_sp set next pointer of new frame spriab sb|stack_header.stack_end_ptr set new stack end ptr eppsp bb|0 update sp epp3 return_from_call reset the return_ptr to cobol operators_ spri3 pr6|stack_frame.return_ptr spri3 pr6|pr3_save save any pointer in case of restoration spri3 pr6|pr5_save save any pointer in case of restoration spri3 pr6|pr4_save save any pointer in case of restoration spri3 pr6|linkage_ptr lda ap|0 get 2*n_args in au, code in al cana 8,dl is there an extra arg tze 2,ic no ada 2,du yes, allow for it eppbb ap|2,au get ptr to descriptors spribb sp|descriptor_ptr set ptr in stack frame spribp sp|stack_frame.entry_ptr save ptr to entry point spbpbp sp|text_base_ptr save ptr to base of text segment eppap operator_table and pointer to operators spriap sp|stack_frame.operator_ptr save pointer to operator segment tra bp|5 " " " init_write check file condition " " init_write: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 set pr 1 stz pr6|icode reset on each entry to zero szn pr1|2 is file opened tnz pr6|text_base_ptr,*0 YES, " set status lda io30_con ldq s4031con staq pr6|status12 ldx1 24,du attempt to perform io on an unopened file tra return_thru_text_base_pone " " " write_stream call iox_$put_chars OPERATOR(40)********** " " write_stream: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 set iocb_ptr tsx6 pr0|subr_put_chars szn pr6|mcode tze return_to_reset tra write_stream_error " " **********OPERATOR(68)********** " " write_stream_linage: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 set iocb_ptr tsx6 pr0|subr_put_chars epp1 pr6|86,* reset pr 1 lda pr6|47 load A with advancing value dtb (pr),(pr) store cobol_fsb.linage_counter into stack word desc9ns pr1|88,6,0 desc9a pr6|46,4 " lxl3 0,dl " szn pr6|46 if linage counter zero then set to one " tnz 8,ic NOT zero then bypass " aos pr6|46 set linage counter to one start of new page " lxl3 1,dl " stz pr6|icode reset, as linage counter is 1 " btd (pr),(pr) " desc9a pr6|46,4 " desc9ns pr1|88,6,0 " tra 8,ic szn pr6|46 [4.0-2], by MHD tnz 2,ic [4.0-2], by MHD lda 1,dl [4.0-2], by MHD ada pr6|46 increment linage counter by advancing value sta pr6|46 store new linage_counter btd (pr),(pr) store stack word into cobol_fsb.linage_counter desc9a pr6|46,4 desc9ns pr1|88,6,0 cmpa pr1|93 is new linage_counter >= footing tmi cont_write_stream lda pr6|41 tze return_to_reset tra io_return_to_reset cont_write_stream: szn pr6|mcode tze return_to_reset " set status write_stream_error: lda io30_con ldq s4430con staq pr6|status12 ldx1 21,du unable to write record tra io_return_to_reset " " " seek_key call iox_$seek_key OPERATOR(67)********** " " read_seek_key: inhibit on stx0 pr6|return_to_main_off inhibit off lda 1,dl sta pr6|54 tra seek_common " " **********OPERATOR(41)********** " " seek_key: inhibit on stx0 pr6|return_to_main_off inhibit off stz pr6|54 for write seek_common: spri1 pr6|86 set iocb_ptr epp2 pr1|7 spri2 pr6|88 store pointer to key area epp2 pr6|62 work area not used as seek key returns length spri2 pr6|90 store pointer to key len lda 16,dl sta pr6|rts_code store rts code tsx6 pr0|subr_seek_op szn pr6|mcode tze return_to_reset " set status ldx1 26,du szn pr6|54 read or write? tnz io_return_to_reset read. lda io30_con ldq s4632con staq pr6|status12 tra io_return_to_reset " " " SUBROUTINE to iox_$seek_key " " subr_seek_op: stx6 pr6|subr_return_save_off epp2 pr6|mcode spri2 pr6|92 store pointer to mcode spri2 pr6|76 mcode_ptr eax1 pr6|84 fld 8192,dl 4 args epp2 pr1|0,* epp2 pr2|74 offset for iox_$seek_key epp0 return_seek_key spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op return_seek_key: epp4 pr6|linkage_ptr,* reset linkage pointer " rts code must be set by caller to this SUBROUTINE epp0 pr6|subr_return_save,* EXIT FROM SUBROUTINE spri0 pr6|stack_frame.return_ptr tra call_rts_from_op handle seek errors " " " SUBROUTINE to set up for iox_$write_record and iox_$rewrite_record " " subr_write_record: stx6 pr6|subr_return_save_off epp1 pr6|86,* reset pr 1 spri5 pr6|78 store_buff_ptr epp2 pr6|78 spri2 pr6|88 store pointer to buffptr epp2 pr6|80 spri2 pr6|90 store pointer to buff_len epp2 pr6|mcode spri2 pr6|92 eax1 pr6|84 fld 8192,dl 4 args epp2 pr1|0,* tra pr6|subr_return_save,* EXIT FROM SUBROUTINE " " **********OPERATOR(42)********** " write record op call iox_$write_record " " write_record: inhibit on stx0 pr6|return_to_main_off inhibit off tsx6 pr0|subr_write_record epp2 pr2|62 offset for iox_$write_record epp0 return_write_record spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op return_write_record: szn pr6|mcode tze return_to_reset " set status lda io30_con ldq s4432con staq pr6|status12 ldx1 41,du Write is an invalid operatoin for current open mode tra io_return_to_reset " " " SUBROUTINE to put_chars " " subr_put_chars: stx6 pr6|subr_return_save_off sta pr6|retrycode spri1 pr6|86 set iocb_ptr spri5 pr6|78 store buff_ptr epp2 pr6|78 spri2 pr6|88 store pointer to buff_ptr epp2 pr6|80 spri2 pr6|90 store pointer to buff_len epp2 pr6|mcode spri2 pr6|92 store pointer to mcode eax1 pr6|84 fld 8192,dl 4 args epp2 pr1|0,* indirect thru fsb to iocb epp2 pr2|42 offset for iox_$put_chars epp0 pr6|subr_return_save,* EXIT FROM SUBROUTINE spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op call iox_$put_chars " " " linage " A reg set with advancing value " " linage: inhibit on stx0 pr6|return_to_main_off inhibit off lxl3 0,dl [4.0-2], by MHD epp1 pr6|86,* reset pr 1 cmpa 1000,dl Is the PAGE force value tze force_page YES, lda pr6|47 ldq pr6|47 sta pr6|81 set advancing value adq pr6|80 increment Q with buff length stq pr6|81 = buff length +advancing value dtb (pr),(pr) store the linage_counter into a stack word desc9ns pr1|88,6,0 desc9a pr6|46,4 ada pr6|46 increment A with current linage_counter cmpa pr1|92 is linage_counter + advancing value > page_size tpnz finish_curr_page YES, do finish current page,include TOP, LC = 1 lda pr6|80 reset A to buff length ldq pr6|47 reset q to adv value btd (pr),(pr) desc9a pr6|46,4 desc9ns pr1|88,6,0 tra return_to_reset force_page: finish_curr_page: ldq pr1|92 load Q with page_size sbq pr6|46 subtract linage_counter from Q adq 1,dl adq pr6|80 add advancing + buff length adq pr1|94 add top_size to Q adq pr1|95 add bottom_size to Q stq pr6|81 = total amount from last write to new write on next page stz pr6|46 initialize linage_counter to 0 btd (pr),(pr) store the stack word back to the linage counter desc9a pr6|46,4 desc9ns pr1|88,6,0 lxl3 1,dl [4.0-2],by MHD. shows page overflow occured lda pr6|80 reset A to length of buffer ldq pr6|47 reset q to adv value tra return_to_reset " " " Please insert the new highly used cobol operator before this line. " " " **************************************** " " " " This is the overpunch operator. " " **************************************** " " " " cobol_opch_operator_: opch: " Modified on 3/12/76 by Bob Chang for cobol operator. " " This ALM procedure is the cobol_operator_ that does conversion " to and from overpunch sign decimal data. " For this first implementation some simplifying assumptions are made: " 1. Only three formats of data can be converted. " a. unpacked decimal, trailing sign. " b. overpunch decimal, leading sign. " c. overpunch decimal, trailing sign. " " 2. Before this operator is called, any data, other than overpunch " or unpacked decimal trailing sign, is converted to unpacked " decimal trailing sign data in a temporary. " " Subsequent implementations may provide for direct conversion by this " operator of the following data formats: " 1. long fixed binary " 2. short fixed binary " 3. packed decimal, leading or trailing sign " " ENTRY CONDITIONS " " Data is passed to this operator in the following registers: " " " 1. pr1 points to the target of the conversion. " " 2. pr2 points to the source of the conversion. " " 3. pr5 points to a block of work space, at the top of the " stack. This work space must be aligned on a double word " boundary. " " 4. Q register contains the scale and precision of the source of " conversion. " " a. bits 0-17 of the Q register contains the scale. " Scale is obtained from data_name.places_right of a " data name token. " " b. Bits 18-36 of the Q contain precision. " Precision is obtained from data_name.item_length of a " data name token. " " 5. A register contains the scale and precision of the target " of conversion. Bits 0-17 contain the scale, " bits 18-36 contain the precision. Scale and precision are obtained " as for the source of conversion. " " 6. X7 contains a code that identifies the data type of the " source of conversion. This code is defined in the following " table: " " x7 contents | type of source " __________________________________________ " 1 | overpunch,leading sign " 2 | overpunch, trailing sign " 3 | unpacked decimal, trailing sign " " 7. X6 contains a code that identifies the data type of the " target of conversion. This code is the same as that described " above for X7. " " 8. pr3 is used to store the location to which the cobol " overpunch conversion operator is to return. " segdef cobol_opch_operator_ " definition of offsets within the work space equ scales,0 equ s_scale,1 equ t_scale,0 equ temp1,2 equ temp2,3 equ temp3,4 equ source_desc,5 equ target_desc,6 equ pr_store,8 equ x_store,10 equ save_t_scale,11 equ temp_source,12 equ udts_source_ret,32 equ opch_udts_ret,33 equ opch_opch_ret,34 " definition of the names of pointer registers equ work_pr,5 equ source_pr,2 equ target_pr,1 equ return_pr,3 " *************************************** " * " * ENTRY POINT * " * * " *************************************** cobol_opch_operator_: spri3 pr6|return_to_main_ptr staq work_pr|scales cmpx7 3,du is source unpacked decimal? tnz opch_source no, must be overpunch tsx5 udts_source yes tra operator_exit opch_source: cmpx6 3,du Is destination unpacked decimal? tnz opch_dest no, must be overpunch udts_dest: tsx5 opch_udts tra operator_exit opch_dest: tsx5 opch_opch operator_exit: epp7 pr3|0 epp4 pr6|linkage_ptr,* epp3 pr6|pr3_save,* epp5 pr6|pr5_save,* tra pr7|0 " ************************************** " * udts_source * " *************************************** udts_source: stx5 work_pr|udts_source_ret store return point " calculate the number of characters to move from the source, and the character " position in the source at which to start the move tsx5 calc_length " Set up to insert scale factors into the indirect descriptors lda dec_ns_source_desc ldq opch_target_desc tsx5 insert_scale_factor " Move the source to the target with scaling, but without moving the sign mvn (pr,rl,id,x2),(pr,rl,id) arg work_pr|source_desc arg work_pr|target_desc " Get the character offset of the sign byte of the source lxl1 work_pr|s_scale adx1 -1,du " Test to see if the sign is plus or minus cmpc (pr,x1),(0,0),fill(000) desc9a source_pr|0,1 desc9a plus_sign,1 tze trailing_dec_plus " Must be trailing minus sign ldx2 1,du set to indicate trailing sign was negative tra check_target_sign trailing_dec_plus: ldx2 0,du offset of plus overpunch characters in the dec_to_op_sign table check_target_sign: " Determine whether target is leading or trailing sign overpunch. cmpx6 2,du Is target trailing sign overpunch? tze op_ts yes " Must be leading sign overpunch ldx3 0,du tra insert_op_sign op_ts: " Calculate the offset of the last byte in the target lxl3 work_pr|t_scale adx3 -1,du insert_op_sign: " Insert the overpunch character into the leading or trailing byte of the target. cmpx2 0,du tnz insert_neg_op trailing sign was negative mvt (pr,x3),(pr,x3),(0,0),fill(000) desc9a target_pr|0,1 desc9a target_pr|0,1 arg plus_dec_op_sign_table tra udts_source_exit insert_neg_op: mvt (pr,x3),(pr,x3),(0,0),fill(000) desc9a target_pr|0,1 desc9a target_pr|0,1 arg minus_dec_op_sign_table udts_source_exit: " Return to the entry sequence of this program ldx5 work_pr|udts_source_ret restore return point tra 0,x5 return " ************************************** " * opch_udts * " *************************************** opch_udts: stx5 work_pr|opch_udts_ret store return point " Move the overpunch sign source into an unpacked decimal unsigned temporary. tsx5 unpack_opch " Move the sign from the sign table into the trailing sign byte of the temporary " Note that x1 contains the length of the source, which is the character position of " the trailing sign byte. mlr (x3),(pr,x1) desc9a sign_table,1 desc9a work_pr|temp_source,1 " Calculate the length of the temporary to move, and the character position at which " to start the move. tsx5 calc_length " Increment length of source, because length was derived for overpunch source, and we " are moving an unpacked decimal, trailing sign temporary. adx1 1,du " Set up to insert the scale factor into the indirect descriptors. lda dec_ts_temp_source_desc ldq dec_ts_target_desc tsx5 insert_scale_factor " Move the unpacked dec, trailing sign temporary to the unpacked dec, target mvn (pr,id,rl,x2),(pr,id,rl) nop work_pr|source_desc nop work_pr|target_desc " Return to the calling sequence ldx5 work_pr|opch_udts_ret tra 0,x5 " ************************************** " * opch_opch * " *************************************** opch_opch: stx5 work_pr|opch_opch_ret store return point " Store the pointer to the target field and the type code of the target spri1 work_pr|pr_store stx6 work_pr|x_store " Set pointer to target to a temporary. Set the target type code to unpacked decimal epp target_pr,work_pr|temp_source ldx6 3,du " Save the scale and precision of the original target lda work_pr|t_scale sta work_pr|save_t_scale " Increment the precision of the target, since we are " adding a trailing sign byte when converting to unpacked decimal. lxl1 work_pr|t_scale adx1 1,du sxl1 work_pr|t_scale " Convert the overpunch source to an unpacked decimal into the temporary tsx5 opch_udts " Set the source pointer to the imal temporary, and the source type code to " unpacked decimal. epp source_pr,target_pr|0 ldx7 3,du " unpacked decimal target now becomes the source " Set source scale and precision to the scale and precision of the " unpacked decimal temporary. lda work_pr|t_scale sta work_pr|s_scale " restore the target scale and precision lda work_pr|save_t_scale sta work_pr|t_scale " Restore the target pointer and type code to the overpunch target epp target_pr,work_pr|pr_store,* ldx6 work_pr|x_store " Convert the unpacked dec temporary to the overpunch sign target tsx5 udts_source " Return to the calling sequence ldx5 work_pr|opch_opch_ret restore return point tra 0,x5 return " *************************************** " * unpack_opch* " *************************************** unpack_opch: " Move the overpunch sign source into a temporary lxl1 work_pr|s_scale get length of source mlr (pr,rl),(pr,rl) desc9a source_pr|0,x1 desc9a work_pr|temp_source,x1 " Get the character position of the overpunch sign character into x2 cmpx7 1,du Is source leading overpunch sign? tnz t_opch no ldx2 0,du Yes, overpunch character is in zeroth byte position tra common1 t_opch: lxl2 work_pr|s_scale get length of source adx2 -1,du Decrement by one to get char position of last byte common1: " Translate the overpunch sign character into a subscript into the digit_table and sign_table stz work_pr|temp1 mvt (pr,x2),(pr) desc9a source_pr|0,1 desc9a work_pr|temp1(1),1 arg mvt_table " Load the subscript into x3 ldx3 work_pr|temp1 " Test to see if overpunch char is legal. adx3 -1,du tmi bad_oph " Char OK keep going " Move the digit from the digit table into the leading or trailing byte of the temporary. mlr (x3),(pr,x2) desc9a digit_table,1 desc9a work_pr|temp_source,1 " Return to the calling sequence tra 0,x5 " Cause ipr for bad overpunch char. bad_oph: stx3 work_pr|temp1 cmpn (pr),(pr) desc9a work_pr|temp1(1),1 desc9a work_pr|temp1(1),1 " *************************************** " * calc_length * " *************************************** calc_length: " This sequence of code calculates: " 1. The length of the source field to be moved. (Returned in x1) " 2. The character offset of the leftmost character of the source field " to be moved. (Returned in x2) " The length of the target field. (Returned ix x3) " The calling sequence return point is contained in x5, so x5 must not be modified by " this code. Also x4 is used as a work register. " Calculate source places left lxl2 work_pr|s_scale precision (length) of source cmpx7 3,du is source unpacked decimal? tnz s_non_dec no adx2 -1,du decrement length to exclude the sign byte s_non_dec: stx2 work_pr|temp1 ldx1 work_pr|temp1 load length into x1 sbx2 work_pr|s_scale subtract scale to get source places left in x2. " Calculate destination places left lxl4 work_pr|t_scale precision (length) of the target lxl3 work_pr|t_scale cmpx6 3,du Is target unpacked decimal? tnz t_non_dec no adx4 -1,du decrement by 1 to exclude the sign byte t_non_dec: stz work_pr|temp1 stx4 work_pr|temp1 " Subtract scale to get target places left sbx4 work_pr|t_scale stx4 work_pr|temp1 save places left " Subtrace target places left from source places left. ssx2 work_pr|temp1 tmoz target_big_enough " Target places left less than source places left, must adjust source legnth. " Note that if the difference is positive, it contains the character position at which to start moving characters ldx2 work_pr|temp1 sbx1 work_pr|temp1 adjust length tra calc_length_return target_big_enough: " It is not necessary to start the move at a characterhother than the first. Set x2 to zero, so " that the first character in the source will be moved. ldx2 0,du calc_length_return: tra 0,x5 " *************************************** " * insert_scale_factor * " *************************************** insert_scale_factor: " This sequence of code inserts the scale factor of the source and target fields into indirect " descriptors. " ENTRY CONDITIONS " 1. A register contains the source field indirect descriptor " 2. Q register contains the target field indirect descriptor " 3. x5 conatins the return address. " Insert scale factor into the source indirect descriptor sta work_pr|source_desc lda work_pr|s_scale scale factor in upper ars 18 extend sign neg als 6 shift to SF position ana scale_factor_mask and out junk orsa work_pr|source_desc insert SF inot indirect descriptor " Insert scale factor into the target indirect descriptor stq work_pr|target_desc lda work_pr|t_scale scale factor in upper of a now ars 18 extend sign neg als 6 shift to SF position ana scale_factor_mask mask out junk orsa work_pr|target_desc insert SF into indirect descriptor " Return to caller tra 0,x5 " *************************************** " * CONSTANTS AND TABLES * " *************************************** dec_ts_temp_source_desc: desc9ts work_pr|temp_source,x1,0 dec_ts_target_desc: desc9ts target_pr|0,x3,0 dec_ns_source_desc: desc9ns source_pr|0,x1,0 opch_target_desc: desc9ns target_pr|0,x3,0 dec_ns_temp_source_desc: desc9ns work_pr|temp_source,x1,0 scale_factor_mask: oct 000000007700 plus_sign: aci /+/ plus_dec_op_sign_table: empty1: oct 0 oct 0 sign_table: aci /++++/ minus_dec_op_sign_table: aci /++++/ aci /++--/ aci /----/ aci /----/ digit_table: aci /0123/ aci /4567/ aci /8901/ aci /2345/ aci /6789/ aci /{ABC/ PLUS OVERPUNCH DIGITS aci /DEFG/ PLUS OVERPUNCH DIGITS aci /HI / PLUS OVERPUNCH DIGITS aci /}JKL/ MINUS OVERPUNCH DIGITS aci /MNOP/ MINUS OVERPUNCH DIGITS aci /QR / MINUS OVERPUNCH DIGITS oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 mvt_table: oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 001002003004 oct 005006007010 oct 011012000000 oct 0 mvt_data1: oct 000002003004 maps overpunch digits into subscript into sign_table oct 005006007010 and digit_table. oct 011012014015 ditto oct 016017020021 ditto oct 022023024000 ditto empty2: oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 mvt_data2: oct 000000000001 maps "{" into digit_table and sign_table mvt_data3: oct 000013000000 maps "}" into digit_table and sign_table oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 oct 0 " " " " This was added to get rid of a page of zeroes in the object segment " When the previos table reaches 2000 octal remove the following two statements org 1024 nop 1 org 2048 use text2 include cobol_op_fix_con " " " This was added to get rid of a page of zeroes in the object segment " When the previous table reaches 6030 octal remove the following two statements org 792 nop 1 org 1792 use text4 " **************************************** " " This page is for the cobol_error. tra instruction. " " **************************************** " " " tsx7 cobol_error_no_mcode 1 tsx7 cobol_error_no_mcode 2 tsx7 cobol_error 3 tsx7 cobol_error 4 tsx7 cobol_error_no_mcode 5 tsx7 cobol_error 6 tsx7 cobol_error 7 tsx7 cobol_error_no_mcode 8 tsx7 cobol_error_no_mcode 9 tsx7 cobol_error_no_mcode 10 tsx7 cobol_error 11 tsx7 cobol_error 12 tsx7 cobol_error 13 tsx7 cobol_error 14 tsx7 cobol_error 15 tsx7 cobol_error 16 tsx7 cobol_error_no_mcode 17 tsx7 cobol_error 18 tsx7 cobol_error 19 tsx7 cobol_error_no_mcode 20 tsx7 cobol_error 21 tsx7 cobol_error 22 tsx7 cobol_error_no_mcode 23 tsx7 cobol_error_no_mcode 24 tsx7 cobol_error 25 tsx7 cobol_error 26 tsx7 cobol_error 27 tsx7 cobol_error_no_mcode 28 tsx7 cobol_error 29 tsx7 cobol_error 30 tsx7 cobol_error 31 tsx7 cobol_error 32 tsx7 cobol_error_no_mcode 33 tsx7 cobol_error_no_mcode 34 tsx7 cobol_error_no_mcode 35 tsx7 cobol_error_no_mcode 36 tsx7 cobol_error 37 tsx7 cobol_error 38 tsx7 cobol_error_no_mcode 39 tsx7 cobol_error_no_mcode 40 tsx7 cobol_error 41 [4.1-1] tsx7 cobol_error_no_mcode 42 tsx7 cobol_error 43 [4.1-1] tsx7 cobol_error_no_mcode 44 tsx7 cobol_error_no_mcode 45 tsx7 cobol_error_no_mcode 46 tsx7 cobol_error_no_mcode 47 tsx7 cobol_error_no_mcode 48 tsx7 cobol_error_no_mcode 49 tsx7 cobol_error 50 tsx7 cobol_error 51 tsx7 cobol_error 52 tsx7 cobol_error_53 53 tsx7 cobol_error 54 tsx7 cobol_error 55 tsx7 cobol_error 56 tsx7 cobol_error 57 tsx7 cobol_error 58 tsx7 cobol_error_no_mcode 59 tsx7 cobol_error_no_mcode 60 tsx7 cobol_error_no_mcode 61 tsx7 cobol_error_no_mcode 62 tsx7 cobol_error_no_mcode 63 tsx7 cobol_error_no_mcode 64 tsx7 cobol_error_no_mcode 65 tsx7 cobol_error_no_mcode 66 tsx7 cobol_error_no_mcode 67 tsx7 cobol_error_no_mcode 68 tsx7 cobol_error_no_mcode 69 tsx7 cobol_error_no_mcode 70 tsx7 cobol_error_no_mcode 71 tsx7 cobol_error_no_mcode 72 tsx7 cobol_error_no_mcode 73 tsx7 cobol_error_no_mcode 74 tsx7 cobol_error_no_mcode 75 tsx7 cobol_error_no_mcode 76 tsx7 cobol_error_no_mcode 77 tsx7 cobol_error_no_mcode 78 tsx7 cobol_error_no_mcode 79 tsx7 cobol_error_no_mcode 80 tsx7 cobol_error_no_mcode 81 tsx7 cobol_error_no_mcode 82 " " org 1024 use text5 " include cobol_op_var_con " **************************************** " " This page is for the cobol_error operator. " " **************************************** " " cobol_error_no_mcode: stz pr6|mcode cobol_error: inhibit on stx0 pr6|return_to_main_off inhibit off lda 1,dl Set the rts_code for cobol_error_ sta pr6|rts_code sbx7 4096,du Get the cobol_error_code stz pr6|89 sxl7 pr6|89 epp0 pr6|stack_frame.entry_ptr,* Get the entry pointer stz pr6|92 Zero out the line number stz pr6|93 ldx0 pr0|4 entry_seq for the symbol section tze line_no_done epp4 pr6|pr4_save,* load pr4 epp0 pr4|0,0* get the symbol section lxl0 pr0|14 get the area offset lxl1 pr0|6,0 get the upper bound offset stx1 pr6|76 store into temporary location ldx0 pr0|6,0 get the lower bound offset ldx1 pr0|0,0 start the loop cmpx1 pr6|return_to_main_off tze 7,ic the current line number tpl 5,ic the next line number cmpx0 pr6|76 check with the upper bound tpl line_no_done no line number obtainable adx0 2,du tra -7,ic back to loop sbx0 2,du lda pr0|0,0 get_statement_map ldq pr0|1,0 load seperately in case of odd loc. anaq line_mask mask the line number part. lrl 10 get the file number in a reg sta pr6|93 qrl 22 get the line number in q stq pr6|92 line_no_done: epp0 pr6|return_to_main_ptr,* get the error pointer spri0 pr6|94 lda 1,dl get the rts code 1 sta pr6|rts_code epp0 pr4|19 load the location of program name spri0 pr6|96 lda pr4|18 get program name length sta pr6|98 lda pr6|mcode get status code of multics sta pr6|90 tra call_rts_from_op " constant for cobol_error even line_mask: oct 000000777777 oct 740000000000 " " " " ****************************** " " cobol_error_53 " cobol_error_53: " epp4 pr6|linkage_ptr,* reload pr4 after call out " lda 6,dl load rts code for sort_terminate " sta pr6|rts_code " epp0 return_from_term overset the return pointer " spri0 pr6|stack_frame.return_ptr " tra call_rts_from_op even return_from_term: lda pr6|80 get the multics status code sta pr6|mcode cobol_error_from_op: ldx0 pr6|return_to_main_off load x0 before transfer to cobol_error epp4 pr6|linkage_ptr,* reload pr4 after call out epp0 return_from_call reset the return pointer back to noraml spri0 pr6|stack_frame.return_ptr lxl7 pr6|89 get the cobol error code adx7 4096,du put the adjust error code into x7 tra cobol_error " " " " " Please insert the next cobol error operator before this line " " **************************************** " " The following operators are low used operators. " " **************************************** " " operator to do a procedure return " return_mac: epbpsb sp|0 get ptr to base of stack inhibit on sprisp sb|stack_header.stack_end_ptr reset stack end pointer eppsp sp|stack_frame.prev_sp,* pop stack inhibit off epbpsb sp|0 set sb up in case we just switched stacks eppap sp|stack_frame.operator_ptr,* set up operator pointer ldi sp|stack_frame.return_ptr+1 rtcd sp|stack_frame.return_ptr continue execution after call " " " " " operator to enable a condition. calling sequence is: " eppbp name " lxl6 name_size " tsx0 ap|enable " tra on_unit_body " arg on_unit (snap & system flags in RHS if used) " tra skip_around_body " body of on unit starts here " include on_unit enable_1: " " enable: inhibit on stx0 pr6|return_to_main_off inhibit off sxl0 sp|stack_frame.operator_ret_ptr epp1 sp|text_base_ptr,*0 lda =o100,dl is there a valid on_unit_list cana sp|stack_frame.prev_sp check bit 29 of sp|stack_frame.prev_sp tnz 3,ic non-zero means ok stz sp|stack_frame.on_unit_rel_ptrs init ptr orsa sp|stack_frame.prev_sp and set bit " ldx1 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first enabled unit tze add_on zero means chain empty on_1: cmpx1 pr1|0 is this the unit we want tze have_on yes, go process ldx1 sp|on_unit.next,1 no, get ptr to next on chain tnz on_1 and repeat if end not reached add_on: ldx1 pr1|0 get rel ptr to new unit ldx0 sp|stack_frame.on_unit_rel_ptrs get rel ptr to first unit stx0 sp|on_unit.next,1 set next ptr of new unit stx1 sp|stack_frame.on_unit_rel_ptrs make new unit first on chain have_on: spribp sp|on_unit.name,1 set name of new unit spri3 sp|on_unit.body,1 set ptr to body stz sp|on_unit.size,1 clear size field sxl6 sp|on_unit.size,1 set size of unit name lxl0 pr1|0 get snap & system flags sxl0 sp|on_unit.flags,1 and save in on unit stz sp|stack_frame.operator_ret_ptr epp3 pr6|pr3_save,* epp5 pr6|pr5_save,* tra pr1|1 return to cobol program " " " " " **************************************** " " The following operators are used for sort interface. " " **************************************** " " " The operator for sort_commence " **********OPERATOR(22)********** " " sort_commence: inhibit on stx0 pr6|return_to_main_off inhibit off " RTS(7) lda 7,dl load rts_code sta pr6|rts_code epp0 return_from_sort_commence set the return_ptr to special location spri0 pr6|stack_frame.return_ptr tra call_rts_from_op even return_from_sort_commence: szn pr6|80 check the status code tze sort_good return to good sort label lda 56,dl lda the error code and store sta pr6|89 tra cobol_error_53 " " The operator for sort release " pr3 for the address od the data to be released " Q for the length of the data in bytes. " **********OPERATOR(11)********** sort_release: inhibit on stx0 pr6|return_to_main_off inhibit off spri3 pr6|74 store the data pointer stq pr6|76 store the length of the data " RTS(4) lda 4,dl store the rts_code sta pr6|rts_code epp0 return_from_sort_release set the return_ptr to special location spri0 pr6|stack_frame.return_ptr tra call_rts_from_op even return_from_sort_release: szn pr6|80 check the status code tze sort_good return to good sort label lda 52,dl lda the error code and store sta pr6|89 tra cobol_error_53 " " " **********OPERATOR(13)********** " " 14 words in stack are needed " sort_return: inhibit on stx0 pr6|return_to_main_off inhibit off " RTS(5) lda 5,dl load the rts_code sta pr6|rts_code epp0 return_from_sort_return lda the error code and store spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " " even return_from_sort_return: lda pr6|80 check the status code tze sort_good return to good sort label lda 53,dl load the error code sta pr6|89 tra cobol_error_53 " " " " " The operator for the sort initiate. " It needs the following parameters: " pr3 for compare entry ptr " pr7 for sort_$noexit " x2 for the stack offset " 14 word are used to set up parameter list for soit exit. " " **********OPERATOR(14)********** sort_initiate: sort_exit: inhibit on stx0 pr6|return_to_main_off inhibit off cmpx2 0,du check same sort merge possibility tpl 5,ic epp0 pr6|pr4_save,* stx2 pr0|41 complement x2 lcx2 pr0|41 stz pr0|41 for sort spri3 pr6|2,2 store the compare entry ldaq null_con staq pr6|4,2 stz pr6|0,2 store 1 in the version number aos pr6|0,2 epp3 pr6|0,2 get pointer for the exit ptr " sort_initiate_call: spri3 pr6|74 store the exit_ptr into the argument epp0 return_from_sort_init set the return_ptr to special location spri0 pr6|stack_frame.return_ptr " RTS(3) lda 3,dl load the rts_code sta pr6|rts_code epp0 pr6|pr4_save,* epp0 pr0|control_ptr,* spri0 pr6|76 tra call_rts_from_op even return_from_sort_init: szn pr6|80 check the status code tze sort_good return to good sort label lda 55,dl lda the error code and store sta pr6|89 tra cobol_error_53 " " " For good sort result, skip the retry instruction. " sort_good: lda 1,du asa pr6|return_to_main_off tra return_to_reset " " " Establish the cleanup handler for sort. " The cobol_rts_handler_ is called to call sort_$terminate. " " **********OPERATOR(16)********** establish_cleanup: inhibit on stx0 pr6|return_to_main_off inhibit off epp1 pr6|text_base_ptr,*0 get the return location lda =o100,dl check the condition bit cana pr6|stack_frame.condition_word tnz 3,ic some conditions are on stz pr6|stack_frame.on_unit_rel_ptrs zero out the condition offset orsa pr6|stack_frame.condition_word set the condition bit ldx0 pr6|stack_frame.on_unit_rel_ptrs get the last condition tze 4,ic no condition ldx1 pr6|stack_frame.on_unit_rel_ptrs get the last condition adx1 10,ic 10 words for the last condition tra 2,ic ldx1 118,du it is the 1st cond. Put it in pr6|118 stx0 pr6|on_unit.next,1 reset this as the last cond stx1 pr6|stack_frame.on_unit_rel_ptrs epp2 sort_con+1 store the name cleanup spri2 pr6|on_unit.name,1 epp4 pr6|pr4_save,* load pr4 epp3 pr4|control_ptr,* get control_seg epp3 pr3|46,* get cobol_rts_handler_ spri3 pr6|on_unit.body,1 store into the condition body lda 7,dl store the length sta pr6|on_unit.size,1 lxl0 0,dl no flag sxl0 pr6|on_unit.flags,1 tra return_cond " " The operator for calling the sort_$terminate " " **********OPERATOR(17)********** sort_terminate: inhibit on stx0 pr6|return_to_main_off inhibit off stz pr6|74 zero out the status code. It is needed, unfortunately " RTS(6) lda 6,dl load the rts_code sta pr6|rts_code epp0 return_from_sort_term set the return_ptr to special location spri0 pr6|stack_frame.return_ptr tra call_rts_from_op even return_from_sort_term: lda pr6|74 check the status code tze return_to_reset sta pr6|80 lda 54,dl lda the error code and store sta pr6|89 tra return_from_term " " " The operator for reverting the cleanup condition. " " **********OPERATOR(18)********** revert_cleanup: inhibit on stx0 pr6|return_to_main_off inhibit off epp1 pr6|text_base_ptr,*0 store the return_ptr in pr1 epbp7 pr6|0 pr7 for stack header epp0 pr6|118 first condition start from pr6|118 epp2 sort_con+1 get the cleanup character string eax6 7 7 characters tsx7 find_unit " unit found null out the current condition stz pr6|on_unit.size,1 start searching ldaq null_con staq pr6|on_unit.name,1 staq pr6|on_unit.body,1 " If this is the first unit then reset pr6|stack_frame.on_unit_rel_ptrs eaa 0,1 cmpa pr6|stack_frame.on_unit_rel_ptrs tnz return_cond ldx1 pr6|on_unit.next,1 stx1 pr6|stack_frame.on_unit_rel_ptrs " restore pr0, pr3 and pr4 return_cond: epp0 pr6|stack_frame.operator_ptr,* epp4 pr6|linkage_ptr,* epp3 pr6|pr3_save,* tra pr1|0 " This subroutine tries to find the unit for the given condition. find_unit: lda stack_frame.condition_bit,dl make sure this is a condition stack cana sp|stack_frame.condition_word .. tnz get_length .. stz sp|stack_frame.on_unit_rel_ptrs .. orsa sp|stack_frame.condition_word .. get_length: eaa 0,6 get length of name in chars tze return_cond if zero then done lrs 20 convert to words eax6 0,al place number of words in x6 qrl 16 get extra chars eax5 1,qu place extra chars in x5 previous_char: eax5 -1,5 reduce chars by 1 tnz next_word have we gone over word boundary eax6 -1,6 if so reduce number of words tmi return_cond name of all blanks eax5 4 have four chars in new word next_word: lda bp|0,6 get word and check for blanks ldq masks1-1,5 .. cmk blanks .. tze previous_char if blank reduce length by 1 ldx1 sp|stack_frame.on_unit_rel_ptrs get offset of first on unit tra next_length .. next_on_unit: ldx1 sp|on_unit.next,1 get offset of next on unit next_length: tze return_cond cannot find unit eaa 0,6 compute length of name ars 16 .. ada char_count-1,5 .. cmpa sp|on_unit.size,1 are names the same length tnz next_on_unit if not go to next on unit epplp sp|on_unit.name,1* get pointer to name for this unit lda bp|0,6 compare extra chars ldq masks2-1,5 .. cmk lp|0,6 .. tnz next_on_unit no match, try next eax4 0,6 compare rest of name compare_next_word: eax4 -1,4 .. tmi 0,7 match, we are done lda bp|0,4 .. cmpa lp|0,4 .. tze compare_next_word .. tra next_on_unit no match, try next blanks: aci " " word of blanks masks1: oct 000777777777 masks for lookin at individual chars oct 777000777777 oct 777777000777 oct 777777777000 masks2: oct 000777777777 masks for comparing strings oct 000000777777 oct 000000000777 oct 000000000000 char_count: oct 1 number of chars in last word oct 2 oct 3 oct 4 " " " This operator is called from sort_gen to set up parameter for compare " procedure. " " **********OPERATOR(19)********** sort_comp: inhibit on stx0 pr6|return_to_main_off inhibit off epp7 pr6|stack_frame.arg_ptr,* get the argument pointer epp2 pr7|4,* pr2 for second operand epp1 pr7|2,* pr1 for first operand epp2 pr2|0,* epp1 pr1|0,* stz pr7|6,* prestore 0 for equal compare tra pr6|text_base_ptr,*0 " " " The operator for calling the pl1 operator real_to_real. " This operator is used for exponential computation. " " " **********OPERATOR(15)********** real_to_real: inhibit on stx0 pr6|return_to_main_off inhibit off epp0 cobol_operators_ reset text_base_ptr to cobol_operators_ spri0 pr6|text_base_ptr epbp0 pr6|0 epp0 pr0|28,* eax0 return_from_pl1_op rest x0 befor transfer to pl1_operators_ tra pr0|684 " " " **************************************** " " This page is for merge statement interface " " **************************************** " " merge_init **********OPERATOR(60)********** " " Input: x2 for merge stack offset " x3 for no of using files " pr3 for compare entry merge_init: inhibit on stx0 pr6|return_to_main_off inhibit off cmpx2 0,du check same sort merge possibility tpl 4,ic epp0 pr6|pr4_save,* stx2 pr0|41 complement x2 lcx2 pr0|41 stz pr6|80 sxl2 pr6|80 merge stack offset stz pr6|81 sxl3 pr6|81 no of using files epp2 pr6|0,2 stack_off loaction spri2 pr6|82 eaq 0,3 qls 1 multiply by 2 and put into Q upper epp2 pr2|0,qu tree loaction spri2 pr6|84 epp2 pr2|0,qu compare entry loaction spri2 pr6|86 epp0 pr6|pr4_save,* epp0 pr0|control_ptr,* get controlp for temp dir spri0 pr6|88 spri3 pr2|0 strore the compare entry ldaq null_con staq pr2|2 lda 30,dl tra call_rts_load_code " " merge_comp **********OPERATOR(61)********** " " Input: none " merge_comp: inhibit on stx0 pr6|return_to_main_off inhibit off lda 31,dl tra call_rts_load_code " " " merge_return **********OPERATOR(62)********** " "Input: none " merge_return: inhibit on stx0 pr6|return_to_main_off inhibit off lda 32,dl tra call_rts_load_code " " **********OPERATOR(24)********** " This page is for communication interface. " " **************************************** " " **********OPERATOR(70)********** receive_comm: inhibit on stx0 pr6|return_to_main_off inhibit off lda 40,dl tra call_rts_load_code " " **********OPERATOR(71)********** accept_comm: inhibit on stx0 pr6|return_to_main_off inhibit off lda 41,dl tra call_rts_load_code " " **********OPERATOR(72)********** purge_comm: inhibit on stx0 pr6|return_to_main_off inhibit off lda 42,dl tra call_rts_load_code " " **********OPERATOR(73)********** send_comm: inhibit on stx0 pr6|return_to_main_off inhibit off lda 43,dl tra call_rts_load_code " " **********OPERATOR(74)********** enable_comm: inhibit on stx0 pr6|return_to_main_off inhibit off lda 44,dl tra call_rts_load_code " " **********OPERATOR(75)********** disable_comm: inhibit on stx0 pr6|return_to_main_off inhibit off lda 45,dl tra call_rts_load_code " " **************************************** " " This page is for low used general operators. " " **************************************** " " " " " " The operator for managing the files within OPEN and CLOSE. " X5 set to 2*no_of_files " X6 set to 2*file_no " " " **********OPERATOR(24)********** set_lin_file_status: inhibit on stx0 pr6|return_to_main_off inhibit off stz pr6|46 zero work area aos pr6|46 set init linage counter to 1. btd (pr),(pr) desc9a pr6|46,4 desc9ns pr1|88,6,0 lda pr1|94 get TOP value mlr (ic),(pr,rl),fill(012) desc9a -1,0 desc9a pr5|0,al sta pr6|80 set length value stx6 pr6|x6_save [3.0-1] tsx6 pr0|subr_put_chars [3.0-1] ldx6 pr6|x6_save [3.0-1] epp1 pr6|86,* epp3 pr6|pr3_save,* " " **********OPERATOR(25)********** " " set_file_status: inhibit on stx0 pr6|return_to_main_off inhibit off epp4 pr6|pr4_save,* load static data pointer ldaq pr4|file_info_ptr eraq null_con anaq mask_con tnz 19,ic epp2 pr4|control_ptr,* adwp2 100000,du szn pr2|0 tnz 4,ic spri2 pr2|0 lda 2,du asa pr2|1 ldaq pr2|0 staq pr4|file_info_ptr ldx4 2,du asx4 pr2|1 asx5 pr2|1 epp2 pr4|file_info_ptr,* sxl5 pr2|0 ldaq null_con staq pr2|0,5 sbx5 2,du tnz -2,ic epp2 pr4|file_info_ptr,* spri1 pr2|0,6 epp4 pr6|linkage_ptr,* tra pr6|text_base_ptr,*0 " " " " **********OPERATOR(27)********** " This operator handles the FILE CLOSE and DETACH. " " close_file: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 store iocb ptr tsx6 pr0|subr_close_file tra return_to_reset "[3.0-1] "[3.0-1] alt_close_file **********OPERATOR(89)********** "[3.0-1] "[3.0-1] alt_close_file: inhibit on stx0 pr6|return_to_main_off inhibit off " spri7 pr6|80 set file desc ptr " lda 47,dl RTS(47) sta pr6|rts_code set fields in FSB epp0 return_from_alt_close spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_close: tra return_to_reset " " " **********OPERATOR(38)********** " This operator handles the FILE CLOSE only NO detach " " close_file_only: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 tsx6 pr0|subr_close_file_only epp1 pr6|86,* reset pr 1 to fsb stz pr1|2 reset open mode tra return_to_reset " " " " **********OPERATOR(43)********** " This operator is for stop literal code to call cu_$cl " stop_literal: inhibit on stx0 pr6|return_to_main_off inhibit off " RTS(8) lda 8,dl sta pr6|rts_code tra call_rts_from_op " " **********OPERATOR(48)********** " This operator is for "stop run" code to call cobol_stoprun_ " stop_run: inhibit on stx0 pr6|return_to_main_off inhibit off epp4 pr6|pr4_save,* load pr4 staq pr4|36 store the line number " RTS(9) lda 9,dl load the rts_code sta pr6|rts_code tra call_rts_from_op " " **********OPERATOR(94)********** [4.4-3] " This operator is for "stop run" code to call cobol_stoprun_ if CD INITIAL used " stop_cd_run: inhibit on stx0 pr6|return_to_main_off inhibit off epp4 pr6|pr4_save,* load pr4 staq pr4|36 save the line number " RTS(62) lda 62,dl load the rts code sta pr6|rts_code tra call_rts_from_op " " " the cancel operator used to call cobol_cantrol_$cancel. " " **********OPERATOR(49)********** cancel: inhibit on stx0 pr6|return_to_main_off inhibit off spri3 pr6|74 store the name sta pr6|76 store the name length " RTS(10) lda 10,dl load the rts_code sta pr6|rts_code tra call_rts_from_op " " The operator for calling cobol_su_$tally and cobol_su_$replace. " " **********OPERATOR(51)********** inspect_replace: inhibit on stx0 pr6|return_to_main_off inhibit off lda 24,dl tra 3,ic " " **********OPERATOR(50)********** " inspect_tally: inhibit on stx0 pr6|return_to_main_off inhibit off " RTS(23) lda 23,dl spri2 pr6|74 load tally pointer sta pr6|rts_code load the rts_code tra call_rts_from_op " " **********OPERATOR(12)********** " " " **********OPERATOR(77)********** " The operator for initialize cd token (77) " init_cd: inhibit on stx0 pr6|return_to_main_off inhibit off epp2 pr6|26,* ldx1 pr2|0 tze init_cd_space epp2 pr2|0,1* mlr (pr),(pr) desc9a pr2|0,48 desc9a pr1|0,48 tra pr6|text_base_ptr,*0 init_cd_space: mlr (0),(pr),fill(040) desc9a 0,0 desc9a pr1|0,48 tra pr6|text_base_ptr,*0 " " " " The operator for the runtime_check option. " pack_mask: oct 775777777777 desc_mask: oct 000000100000 runtime_check: inhibit on stx0 pr6|return_to_main_off inhibit off epp5 pr6|stack_frame.arg_ptr,* get arg_ptr from the caller epp3 pr6|stack_frame.entry_ptr,* get the stack_frame.entry for the callee stz pr6|mcode set the status code to 0. epp0 pr6|text_base_ptr,* load the text_base into pr0 lda pr3|-1 ana desc_mask check the descriptor bit tnz 3,ic ldx3 0,du tra 4,ic ldx1 pr3|-2 get the descr_relp_offset ldx3 pr0|0,1 obtain the number of arguments tnz 4,ic there are arguments cmpx3 pr5|0 check caller tze return_from_call both have no argument tra n_args_error caller has some arguments, call error routine adx3 pr0|0,1 double x3 to get 2*n_args cmpx3 pr5|0 compare n_args with the caller's tze 3,ic n_args equal, passed the first check n_args_error: lxl7 4155,dl load the error_code tra cobol_error ldx2 pr5|1 load the desc_count cmpx2 0,du Is there descriptor? tnz 2,ic yes. check descriptors. tra return_from_call no. restore registers and back epp2 pr6|descriptor_ptr,* load descriptor_ptr for the caller epp3 pr0|0,1 find parm_desc_ptr for the caller stx2 pr6|74 ldx5 0,du initialization for the loop ldx2 0,du ldx7 0,du loop_compare: cmpx7 0,du tnz upper_half lxl1 pr3|0,5 tra desc_join upper_half: adx5 1,du next desc_relp in next word ldx1 pr3|0,5 obtain the next desc_relp for the caller desc_join: epp1 pr0|0,1 epp5 pr2|0,2* lxl3 pr1|-1 desc_loop: sbx3 1,du tmi desc_exit lda pr1|0,3 ana pack_mask sta pr6|75 lda pr5|0,3 ana pack_mask cmpa pr6|75 tnz desc_error not equal, call cobol_error_ tra desc_loop desc_exit: adx2 2,du yes. get the next one cmpx2 pr6|74 more descriptor? tpl return_from_call no. back to main procedure adx7 1,du anx7 1,du tra loop_compare back to loop desc_error: ldx7 4156,du load the error_code tra cobol_error call cobol_error_ " " " " " open_ext_file **********OPERATOR(30)********** " " open_ext_file: inhibit on stx0 pr6|return_to_main_off inhibit off lda pr1|90 if file LOCKed then don't OPEN. ana 8192,du tze cont_open_ext " set status lda io30_con ldq s1090con staq pr6|status12 ldx1 62,du Attempt to OPEN a file closed with the LOCK option. adx0 1,du force skip over tra instr tra return_thru_text_base_pone cont_open_ext: sta pr6|55 temp save A reg value lda pr1|2 tmoz pr6|text_base_ptr,*0 minus or zero cont processing cmpa pr6|55 do the cobol modes match tze return_thru_text_base_pone YES " set status lda io30_con ldq s1032con staq pr6|status12 ldx1 8,du attempt to open ext file already opened in inconsistent mode. adx0 1,du force skip over tra instruction return_thru_text_base_pone: adx0 1,du skip one instruction tra pr6|text_base_ptr,*0 " " " open_int_file cobol **********OPERATOR(31)********** " " open_int_file: inhibit on stx0 pr6|return_to_main_off inhibit off lda pr1|90 if file LOCKed then don't OPEN. ana 8192,du tze cont_open_int " set status lda io30_con ldq s1090con staq pr6|status12 ldx1 62,du Attempt to OPEN a file closed with the LOCK option. tra return_thru_text_base_pone cont_open_int: szn pr1|2 tze pr6|text_base_ptr,*0 " set status lda io30_con ldq s1036con staq pr6|status12 ldx1 9,du attempt to open int file already opened. tra return_thru_text_base_pone " " " find_iocb cobol **********OPERATOR(32)********** " A reg = length of switch name " X5 = stack offset value for ioname " " find_iocb: inhibit on stx0 pr6|return_to_main_off inhibit off spri6 pr6|48 store stack_offset ptr for ioname spri6 pr6|50 adx5 pr6|49 add base offset to x5 stx5 pr6|49 set correct offset adx5 2,du stx5 pr6|51 spri1 pr6|86 store pr1 spri1 pr6|48,* store fsb pointer sta pr6|50,* store switch length epp2 pr6|40 spri2 pr6|76 store mcode_ptr " lda 14,dl RTS(14) sta pr6|rts_code store rts_code epp0 return_find_iocb spri0 pr6|stack_frame.return_ptr tra call_rts_from_op iox_find_iocb return_find_iocb: szn pr6|40 tze return_to_reset " set status lda io30_con ldq s1193con staq pr6|status12 ldx1 7,du unable to establish iocb tra io_return_to_reset " " check_attach cobol **********OPERATOR(33)********** " check_attach: inhibit on stx0 pr6|return_to_main_off inhibit off epp1 pr6|86,* reset pr1 epp2 pr1|0,* ldaq pr2|12 eraq null_con anaq mask_con " [4.0-1] The following 7 lines are used to set a bit in the fsb if the " file is already attched otherwise the bit is zero tnz 4,ic transfer if already attached lda atd_con load zeroes stba pr1|87,20 store a byte of a into fsb tra return_thru_text_base_pone lda =o000400000000 load bit to be set stba pr1|87,20 store the set byte of a ino fsb tnz pr6|text_base_ptr,*0 " " " close_op_file cobol **********OPERATOR(29)********** " " close_op_file: inhibit on stx0 pr6|return_to_main_off inhibit off staq pr6|44 save open mode & optional/opened bit stz pr6|46 sxl5 pr6|46 store open mode(multics_mode) epp1 pr6|86,* tsx6 pr0|subr_close_file_only epp1 pr6|86,* tsx6 pr0|subr_open_file tra open_ok " " " attach_iocb cobol_ **********OPERATOR(34)********** " A reg = length of attach description " X5 = stack offset value for atd " " attach_iocb: inhibit on stx0 pr6|return_to_main_off inhibit off epp1 pr6|86,* spri6 pr6|48 store stack offset for atd adx5 pr6|49 stx5 pr6|49 adx5 2,du stx5 pr6|51 sta pr6|50,* store atd length epp2 pr6|40 spri2 pr6|76 store mcode_ptr " RTS(15) lda 15,dl sta pr6|rts_code store rts_code epp0 return_attach_iocb spri0 pr6|stack_frame.return_ptr tra call_rts_from_op iox_$attach_iocb even return_attach_iocb: szn pr6|40 tze return_to_reset " set status lda io30_con ldq s1293con staq pr6|status12 ldx1 13,du unable to attach IO switch. tra io_return_to_reset " " open_file cobol **********OPERATOR(35)********** " A reg = open mode " open_file: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 staq pr6|44 save open mode & optional/opened bit stz pr6|46 sxl5 pr6|46 store open mode(multics_mode) lda pr1|90 if file LOCKed then don't open , return tsx6 pr0|subr_open_file tra open_ok "[3.0-1] "[3.0-1] alt_open_file **********OPERATOR 78********** "[3.0-1] "[3.0-1] alt_open_file: inhibit on stx0 pr6|return_to_main_off inhibit off " spri7 pr6|80 set file desc ptr epp7 pr6|mcode mcode_ptr spri7 pr6|76 lda pr6|44 move cobol_open_mode to rts_ stack frame sta pr6|82 lda pr6|46 move vfile_open_mode to rts_ stack frame sta pr6|84 " lda 46,dl RTS(46) sta pr6|rts_code set fields in FSB epp0 return_from_alt_open spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_open: tra return_to_reset " " " **********OPERATOR(36)********** " open close op no. 36 " A reg = open mode " " open_close_file: inhibit on stx0 pr6|return_to_main_off inhibit off lda 9,dl [3.0-1] sta pr6|46 [3.0-1] spri1 pr6|74 iocb_ptr spri1 pr6|86 fsb_ptr tsx6 pr0|subr_open_file epp1 pr6|86,* tsx6 pr0|subr_close_file_only tra return_to_reset " " **********OPERATOR(37)********** " check non cobol no. 37 " " check_file: inhibit on stx0 pr6|return_to_main_off inhibit off epp1 pr6|86,* reset pr1 epp2 pr1|0,* ldaq pr2|16 iocb, open_descrip_ptr eraq null_con anaq mask_con tze return_thru_text_base_pone fall though to OPEN lda -1,du noncobol open status sta pr1|2 set fsb open mode tra pr6|text_base_ptr,*0 " " " SUBROUTINE to open files " " subr_open_file: stx6 pr6|subr_return_save_off save return offset within operators epp2 pr6|46 spri2 pr6|88 store pointer to open mode stz pr6|47 epp2 pr6|47 spri2 pr6|90 unused epp2 pr6|40 spri2 pr6|76 mcode_ptr spri2 pr6|92 store pointer to mcode eax1 pr6|84 fld 8192,dl 4 args epp2 pr1|0,* indirect thru fsb to iocb epp2 pr2|26 offset for iox_$open epp0 return_from_open spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op return_from_open: epp4 pr6|linkage_ptr,* szn pr6|40 tze pr6|subr_return_save,* EXIT FROM SUBROUTINE epp1 pr6|86,* stz pr1|2 " check if optional bit is on lda pr6|45 cmpa optional_int tze pr6|subr_return_save,* EXIT FROM SUBR cmpa optional_ext tze pr6|subr_return_save,* EXIT FROM SUBR " set status RTS(13) lda 13,dl sta pr6|rts_code store rts(13) call ldx1 15,du set open error code epp0 return_from_open_rts spri0 pr6|stack_frame.return_ptr exit to main line +1 tra call_rts_from_op return_from_open_rts: epp4 pr6|linkage_ptr,* reset_linkage pointer ldx1 15,du ldq s1295con cmpq pr6|status12 tnz io_return_to_reset tra pr6|subr_return_save,* EXIT FROM SUBROUTINE open_ok: epp1 pr6|86,* reset pr 1 szn pr6|40 tze set_open_mode lda pr6|45 cmpa optional_int tze skip_open_mode cmpa optional_ext tze skip_open_mode set_open_mode: lda pr6|44 sta pr1|2 cobol open mode skip_open_mode: epp4 pr6|pr4_save,* load pr4 lxl5 pr4|18 length of program name mlr (pr,rl),(pr),fill(040) desc9a pr4|19,x5 set name desc9a pr1|71,65 stz pr1|6 set fsb.relkeylen to zero mlr (pr),(pr),fill(060) reset key on each open desc9a 0,0 desc9a pr1|7,16 ldx5 high_con,du set optional bit ansx5 pr1|90 ldx5 pr6|45 set how opened bit 100000=ext 140000=int orsx5 pr1|90 opened bit tra return_to_reset " " " SUBROUTINE to close files " " subr_close_file: stx6 pr6|subr_return_save_off epp2 pr6|mcode [5.1-1] spri2 pr6|88 store ptr to mcode_ptr [5.1-1] spri2 pr6|76 mcode_ptr [5.1-1] " check if optional bit is on lda pr1|90 cmpa optional_int tze check_if_open cmpa optional_ext tnz 3,ic check_if_open: szn pr1|2 tze close_ok szn pr6|retrycode op retry code tnz detach_op szn pr1|2 tmi detach_op syn attachment don't close tnz close_file_begin " set status 1,2,3 handle unopen error lda io30_con ldq s2036con staq pr6|status12 ldx1 17,du set unopened error code to X1 tra io_return_to_reset " This section handles the close. close_file_begin: eax1 pr6|84 argument list offset fld 4096,dl 2 args epp2 pr1|0,* indirect thru fsb to iocb epp2 pr2|30 offset for close epp0 return_from_io_close spri0 pr6|stack_frame.return_ptr adjust return from call_rts tra call_ent_var_from_op iox_$close even return_from_io_close: epp4 pr6|linkage_ptr,* reset linkage pointer szn pr6|mcode tze close_ok lda 12,dl sta pr6|rts_code store rts_code " RTS(18) ldx1 18,du set close error code to X1 epp0 io_return_to_reset exit to main line +1 spri0 pr6|stack_frame.return_ptr tra call_rts_from_op handle close error " This section handles the detach after a close. close_ok: epp1 pr6|86,* reset pr1 with fsb_ptr stz pr1|2 detach_op: lda pr1|87 load bit to see if file was previously attached ana =o000400000000 isolate bit tnz pr6|subr_return_save,* do not detach if file was previously attached lda space_con cmpa pr1|71 is attach name spaces tze pr6|subr_return_save,* yes, then NO DETACH SUBR EXIT epp4 pr6|pr4_save,* load pr4 cmpc (pr),(pr),fill(000) attach name to program name desc9a pr1|71,65 desc9a pr4|19,65 tnz pr6|subr_return_save,* don't detach names differ SUBR EXIT eax1 pr6|84 fld 4096,dl 2 args epp2 pr1|0,* epp2 pr2|22 offset for detach_iocb epp0 return_from_io_detach spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op iox_$detach even return_from_io_detach: szn pr6|mcode tze detach_ok " set status 1,2,3 handle detach error aos pr6|retrycode set retry code to close complete lda io30_con ldq s2393con staq pr6|status12 ldx1 19,du set detach error code to X1 tra io_return_to_reset detach_ok: epp1 pr6|86,* reset pr1 with fsb_ptr mlr (pr),(pr),fill(040) space fill attach name desc9a 0,0 desc9a pr1|71,65 tra pr6|subr_return_save,* EXIT FROM SUBROUTINE " " " SUBROUTINE to close files only, NO detach " " subr_close_file_only: stx6 pr6|subr_return_save_off epp2 pr6|mcode spri2 pr6|88 szn pr1|2 [4.1-2] tmi pr6|subr_return_save,* eax1 pr6|84 argument list offset fld 4096,dl 2 args epp2 pr1|0,* indirect thru fsb to iocb epp2 pr2|30 offset for close epp0 return_from_io_close_only spri0 pr6|stack_frame.return_ptr adjust return from call_rts tra call_ent_var_from_op iox_$close even return_from_io_close_only: epp4 pr6|linkage_ptr,* reset linkage pointer szn pr6|mcode tze pr6|subr_return_save,* lda 12,dl sta pr6|rts_code store rts_code " RTS(18) ldx1 18,du set close error code to X1 epp0 io_return_to_reset exit to main line +1 spri0 pr6|stack_frame.return_ptr tra call_rts_from_op handle close error " " " " This operator is for accept the user's word.**********OPERATOR(20)********** " accept_line: inhibit on stx0 pr6|return_to_main_off inhibit off sta pr6|80 length of the buff spri2 pr6|78 buff_ptr epp2 pr6|0,5 spri2 pr6|82 address of the buffer on the stack epp2 pr6|40 spri2 pr6|76 store the mcode_ptr " RTS(18) lda 18,dl sta pr6|rts_code for accept in cobol_rts_ epp0 return_from_accept preset the return pointer spri0 pr6|stack_frame.return_ptr tra call_rts_from_op even return_from_accept: szn pr6|40 tnz accept_error output the error message epp2 pr6|78,* obtain the buff_ptr lxl5 pr6|81 load the actual record length tze return_accept return sbx5 1,du get rid of the new line character sxl5 pr6|81 store the actual lengthwith new_line off lda pr6|80 load the buffer length sba pr6|81 get the length for the unfilled buffer mlr (),(pr,rl,x5),fill(040) fill the unfilled area with spaces desc9a 0,0 desc9a pr2|0,al return_accept: lda 1,du asa pr6|return_to_main_off skip the retry error instruction tra return_to_reset return accept_error: lda 6,dl sta pr6|89 store the cobol error code tra cobol_error_from_op join the common error label to output the error message " " " **********OPERATOR(44)********** " This operator is for the use of "accept from date. " " accept_date: inhibit on stx0 pr6|return_to_main_off inhibit off " RTS(22) lda 22,dl sta pr6|rts_code save the rts_code tra call_rts_from_op " " " **********OPERATOR(45)********** " This operator is for "accept from day". " accept_day: inhibit on stx0 pr6|return_to_main_off inhibit off epp0 return_from_day reset the retunr point spri0 pr6|stack_frame.return_ptr " RTS(20) lda 20,dl sta pr6|rts_code save the rts_code tra call_rts_from_op even return_from_day: btd (pr),(pr) desc9a pr6|86,4 desc9ns pr6|80(2),3,0 btd (pr),(pr) desc9a pr6|78,4 desc9ns pr6|79(2),4,0 tra return_to_reset return " " **********OPERATOR(46)********** " This operator is for accept from time. " accept_time: inhibit on stx0 pr6|return_to_main_off inhibit off epp0 return_from_time reset the return point spri0 pr6|stack_frame.return_ptr lda 21,dl load the rts_code sta pr6|rts_code tra call_rts_from_op even return_from_time: ldaq pr6|80 load the time of day(tod) dvf 5000,dl lrl 36 div 6000,dl sta pr6|91 div 60,dl sta pr6|90 stq pr6|87 btd (pr),(pr) desc9a pr6|87,4 desc9ns pr6|88,2,0 btd (pr),(pr) desc9a pr6|90,4 desc9ns pr6|88(2),2,0 btd (pr),(pr) desc9a pr6|91,4 desc9ns pr6|89,4,0 tra return_to_reset " " **********OPERATOR(47)********** " This operator is for accepr from day of week. " accept_day_of_week: inhibit on stx0 pr6|return_to_main_off inhibit off epp0 return_from_dow spri0 pr6|stack_frame.return_ptr reset return pointer " RTS(21) lda 21,dl sta pr6|rts_code tra call_rts_from_op even return_from_dow: lda pr6|82 load the day of the week als 27 convert to decimal ora 24576,du sta pr6|82 store the converted decimal back tra return_to_reset return " " " init_delete check file condition **********OPERATOR(56)********** " " init_delete: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 set fsb_ptr stz pr6|icode each entry to zero szn pr1|2 is file opened tnz pr6|text_base_ptr,*0 YES, " set status lda io30_con ldq s7031con staq pr6|status12 ldx1 24,du attempt to perform io on an unopened file tra return_thru_text_base_pone " " " delete_error **********OPERATOR(54)********** " X5 = error number for RTS interface " delete_error: inhibit on stx0 pr6|return_to_main_off inhibit off sxl5 pr6|45 io_error_no " RTS(16) lda 16,dl sta pr6|rts_code store rts_code tra call_rts_from_op " " **********OPERATOR(55)********** " read_key call iox_$read_key " A = offset for TEMP key storage " 1st word = length of saved key " remainder = actual key " " read_key: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 set iocb_ptr spri1 pr6|74 iocb_ptr spri6 pr6|52 get any pointer value in area ada pr6|53 sta pr6|53 insert correct value in pointer offset epp2 pr6|52,* point to TEMP area spri2 pr6|90 store pointer to key length adwp2 1,du read_delete_join: spri2 pr6|88 store pointer to key area epp2 pr6|mcode spri2 pr6|92 store pointer to mcode spri2 pr6|76 mcode_ptr eax1 pr6|84 fld 8192,dl 4 args epp2 pr1|0,* epp2 pr2|78 offset for iox_$read_key epp0 return_read_key spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op even return_read_key: stz pr6|83 set read_key_eof to zero szn pr6|mcode tze return_to_reset epp4 pr6|linkage_ptr,* reset linkage pointer epp2 pr6|mcode spri2 pr6|76 " RTS(17) lda 17,dl sta pr6|rts_code store rts code epp0 return_rts_read_key spri0 pr6|stack_frame.return_ptr tra call_rts_from_op handle read key errors return_rts_read_key: szn pr6|mcode tze return_to_reset ldx1 27,du set read error code tra io_return_to_reset " " **********OPERATOR(69)********** " " read_key_for_read: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 set fsb_ptr spri1 pr6|74 iocb_ptr spri6 pr6|52 get any pointer value in area ada pr6|53 sta pr6|53 insert correct value in pointer offset epp2 pr6|52,* point to TEMP area spri2 pr6|90 store pointer to key length epp2 pr1|7 spri2 pr6|88 store pointer to key area epp2 pr6|mcode spri2 pr6|92 store pointer to mcode spri2 pr6|76 mcode_ptr eax1 pr6|84 fld 8192,dl 4 args epp2 pr1|0,* epp2 pr2|78 offset for iox_$read_key epp0 return_for_read_key spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op even return_for_read_key: szn pr6|mcode tze return_to_reset epp4 pr6|linkage_ptr,* reset linkage pointer epp2 pr6|mcode spri2 pr6|76 " RTS(26) lda 26,dl sta pr6|rts_code store rts code epp0 return_rts_for_read_key spri0 pr6|stack_frame.return_ptr tra call_rts_from_op handle read key errors return_rts_for_read_key: ldx1 27,du set read error code tra io_return_to_reset " " **********OPERATOR(53)********** " delete call iox_$delete_record " " delete: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 set fsb_ptr tsx6 pr0|subr_delete szn pr6|mcode tze return_to_reset " set status lda io30_con ldq s7430con staq pr6|status12 ldx1 30,du Unable to delete record tra io_return_to_reset " " " SUBROUTINE to iox_$delete_record " " subr_delete: stx6 pr6|subr_return_save_off epp2 pr6|mcode spri2 pr6|88 store pointer to mcode eax1 pr6|84 fld 4096,dl 2 args epp2 pr1|0,* epp2 pr2|70 offset for iox_$delete_record epp0 pr6|subr_return_save,* EXIT FROM SUBROUTINE spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op " " **********OPERATOR(57)********** " special_delete seek BUFF, delete, seek TEMP, if EOF position " " special_delete: inhibit on stx0 pr6|return_to_main_off inhibit off sta pr6|53 save a for future use spri1 pr6|86 set fsb_ptr epp2 pr1|7 spri2 pr6|88 epp2 pr6|62 work area not used as seek key returns length spri2 pr6|90 " RTS(25) lda 25,dl sta pr6|rts_code store rts code tsx6 pr0|subr_seek_op from BUFF area szn pr6|mcode tnz io_return_to_reset epp1 pr6|86,* tsx6 pr0|subr_delete szn pr6|mcode tze return_special_delete " set status lda io30_con ldq s7430con staq pr6|status12 ldx1 30,du Unable to delete record tra io_return_to_reset return_special_delete: epp1 pr6|86,* szn pr6|83 is read_key_eof set tnz eof_position lda pr6|53 reset A from previous save spri6 pr6|52 set any pointer value in area ada pr6|53 sta pr6|53 insert correct value in pointer offset epp2 pr6|52,* point to TEMP area spri2 pr6|90 store pointer to key length adwp2 1,du increment pointer offset up by one spri2 pr6|88 store pointer to key area tsx6 pr0|subr_seek_op from TEMP area tra return_to_reset eof_position: stz pr6|52 aos pr6|52 set to +1 stz pr6|53 epp2 pr6|52 spri2 pr6|88 store pointer to type = +1 epp2 pr6|53 spri2 pr6|90 store pointer for n = 0 epp2 pr6|40 spri2 pr6|92 store pointer to mcode eax1 pr6|84 fld 8192,dl 4args epp2 pr1|0,* epp2 pr2|50 offset for iox_$position epp0 return_to_reset spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op " " " special_rewrite seek and position**********OPERATOR(58)********** " " special_rewrite: inhibit on stx0 pr6|return_to_main_off inhibit off sta pr6|53 save offset to key area spri1 pr6|86 set fsb_ptr spri5 pr6|60 save pr 5 for rewrite epp2 pr1|7 spri2 pr6|88 epp2 pr6|62 work area not used as seek key returns length spri2 pr6|90 " RTS(25) lda 25,dl sta pr6|rts_code store rts code tsx6 pr0|subr_seek_op from BUFF area szn pr6|mcode tnz io_return_to_reset epp1 pr6|86,* epp5 pr6|60,* save area points to buffer area tsx6 pr0|subr_write_record epp2 pr2|66 offset for iox_$rewrite_record epp0 return_special_rewrite spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op return_special_rewrite: epp1 pr6|86,* szn pr6|mcode tze return_special_delete " set status lda io30_con ldq s5432con staq pr6|status12 ldx1 43,du Attempt to rewrite a file not opened as i-o tra io_return_to_reset " " " rewrite **********OPERATOR(59)********** " " rewrite: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 set fsb_ptr tsx6 pr0|subr_write_record epp2 pr2|66 offset for iox_$rewrite_record " RTS(64) lda 64,dl [5.3-1] sta pr6|rts_code [5.3-1] epp0 return_rewrite_record spri0 pr6|stack_frame.return_ptr tra call_rts_from_op [5.3-1] return_rewrite_record: szn pr6|mcode tze return_to_reset " set status " lda io30_con [5.3-1] " ldq s5432con [5.3-1] " staq pr6|status12 [5.3-1] ldx1 43,du Attempt to rewrite a file not opened as i-o tra io_return_to_reset " " " init_read check file condition **********OPERATOR(63)********** " " init_read: inhibit on stx0 pr6|return_to_main_off inhibit off spri1 pr6|86 set fsb_ptr stz pr6|icode reset on each entry to zero stz pr6|46 szn pr1|2 is file open tnz pr6|text_base_ptr,*0 YES, " check if optional bit is on perform AT END condition lda pr1|90 cmpa optional_int tze read_optional cmpa optional_ext tze read_optional " set status lda io30_con ldq s3031con staq pr6|status12 ldx1 40,du attempt to perform io on unopened file tra return_thru_text_base_pone read_optional: lda io10_con set status for at end condition ldq s3410con staq pr6|status12 aos pr6|icode aos pr6|46 tra io_return_to_reset " " **********OPERATOR(64)********** " get_line used for cobol_read_gen " " get_line: inhibit on stx0 pr6|return_to_main_off inhibit off epp1 pr6|86,* set iocb_ptr spri5 pr6|78 store buff_ptr epp2 pr6|78 spri2 pr6|88 store pointer to buff_ptr epp2 pr6|80 spri2 pr6|90 store pointer to buff_len stz pr6|47 epp2 pr6|47 spri2 pr6|92 no of bytes read into buffer output epp2 pr6|mcode spri2 pr6|94 store pointer to mcode eax1 pr6|84 fld 10240,dl 5 args epp2 pr1|0,* indirect thru fsb to iocb epp2 pr2|34 offset for iox_$get_line epp0 return_get_line spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op iox_get_line even return_get_line: szn pr6|mcode tze return_to_reset epp4 pr6|linkage_ptr,* epp2 pr6|mcode spri2 pr6|76 " RTS(28) lda 28,dl sta pr6|rts_code epp0 return_read_record_exit spri0 pr6|stack_frame.return_ptr tra call_rts_from_op even "[3.0-1] "[3.0-1] alt_start **********OPERATOR(79)********** "[3.0-1] "[3.0-1] " alt_start: inhibit on stx0 pr6|return_to_main_off inhibit off " spri7 pr6|80 set file descr ptr " lda 48,dl RTS(48) sta pr6|rts_code set fields in FSB epp0 return_from_alt_start spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_start: tra return_to_reset " "[3.0-1] "[3.0-1] alt_read_next **********OPERATOR(80)********** "[3.0-1] "[3.0-1] " alt_read_next: inhibit on stx0 pr6|return_to_main_off inhibit off " spri7 pr6|80 set file descr ptr " lda 49,dl RTS(49) sta pr6|rts_code set fields in FSB epp0 return_from_alt_read spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_read: tra return_to_reset " "[3.0-1] "[3.0-1] alt_read_record **********OPERATOR(81)********** "[3.0-1] "[3.0-1] " alt_read_record: inhibit on stx0 pr6|return_to_main_off inhibit off " spri7 pr6|80 set file descr ptr " lda 50,dl RTS(50) sta pr6|rts_code set fields in FSB epp0 return_from_alt_key spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_key: tra return_to_reset " "[3.0-1] "[3.0-1] alt_seek_key **********OPERATOR(82)********** "[3.0-1] "[3.0-1] " alt_seek_key: inhibit on stx0 pr6|return_to_main_off inhibit off " spri1 pr6|74 loc of file key for start spri7 pr6|80 set file descr ptr sta pr6|85 store key number " lda 54,dl RTS(54) sta pr6|rts_code move key in FSB one position epp0 return_from_alt_seek prefix by key number spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_seek: tra return_to_reset " "[4.0-3] " " " iox_$control perform control order on io switch.**********OPERATOR(83)********** " " alt_start_control: inhibit on stx0 pr6|return_to_main_off inhibit off epp1 pr6|86,* set iocb_ptr spri6 pr6|48 store stack_offset ptr for order name spri6 pr6|50 adx5 pr6|49 add base offset to x5 stx5 pr6|49 set correct offset adx5 2,du stx5 pr6|51 spri1 pr6|48,* store fsb pointer epp2 pr6|50,* adwp2 2,du spri2 pr6|50,* store control pointer epp2 pr6|mcode spri2 pr6|76 store mcode_ptr lda 60,dl RTS(60) sta pr6|rts_code epp0 return_alt_start_control spri0 pr6|stack_frame.return_ptr tra call_rts_from_op iox_control return_alt_start_control: szn pr6|mcode tze return_to_reset " set status ldx1 38,du unable to start a file with specified key tra io_return_to_reset " "[3.0-1] "[3.0-1] alt_read_key **********OPERATOR(84)********** "[3.0-1] "[3.0-1] " alt_read_key: inhibit on stx0 pr6|return_to_main_off inhibit off " spri1 pr6|74 loc of file key spri7 pr6|80 set file descr ptr sta pr6|85 store key number " lda 59,dl RTS(59) sta pr6|rts_code " epp0 return_from_alt_read_key spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_read_key: tra return_to_reset "[3.0-1] "[3.0-1] alt_special_delete **********OPERATOR(85)********** "[3.0-1] "[3.0-1] " alt_special_delete: inhibit on stx0 pr6|return_to_main_off inhibit off " spri1 pr6|74 loc of file key [4.4-2] lda pr6|80 save rec length sta pr6|100 spri7 pr6|80 set file descr ptr epp7 pr6|mcode mcode_ptr spri7 pr6|76 " lda 55,dl RTS(55) sta pr6|rts_code move key in FSB one pos epp0 return_from_alt_spec prefix by 511 spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_spec: lda pr6|100 restore rec length sta pr6|80 tra return_to_reset "[3.0-1] "[3.0-1] alt_delete **********OPERATOR(86)********** "[3.0-1] "[3.0-1] " alt_delete: inhibit on stx0 pr6|return_to_main_off inhibit off " lda 53,dl RTS(53) sta pr6|rts_code set fields in FSB after rewrite epp0 return_from_alt_fsb spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_fsb: tra return_to_reset "[3.0-1] "[3.0-1] alt_key_delete **********OPERATOR(87)********** "[3.0-1] "[3.0-1] " alt_key_delete: inhibit on stx0 pr6|return_to_main_off inhibit off " stz pr6|mcode epp7 pr6|mcode mcode_ptr spri7 pr6|76 " lda 52,dl RTS(52) sta pr6|rts_code $control("record_status") epp0 return_from_rew_del delete alt key values spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_rew_del: szn pr6|mcode tze return_to_reset " lda io9_con status-key-1,2 ldq s7430con [5.3-1] status-key-3 staq pr6|status12 ldx1 65,du unable to delete keys tra io_return_to_reset "[3.0-1] "[3.0-1] alt_rewrite_add **********OPERATOR(88)********** "[3.0-1] "[3.0-1] " alt_rewrite_add: inhibit on stx0 pr6|return_to_main_off inhibit off " stz pr6|mcode epp7 pr6|mcode mcode_ptr spri7 pr6|76 " lda 58,dl RTS(58) sta pr6|rts_code $control("record_status) epp0 return_from_rew_add add alt key values spri0 pr6|stack_frame.return_ptr set fields in FSB after rewrite tra call_rts_from_op " return_from_rew_add: szn pr6|mcode tze return_to_reset " lda io9_con status-key-1,2 ldq s5730con status-key-3 staq pr6|status12 ldx1 64,du unable to add key tra io_return_to_reset "[3.0-1] "[3.0-1] alt_add_write_keys **********OPERATOR(90)********** "[3.0-1] "[3.0-1] " alt_add_write_keys: inhibit on stx0 pr6|return_to_main_off inhibit off " spri7 pr6|80 set file descr ptr stz pr6|mcode epp7 pr6|mcode mcode_ptr spri7 pr6|76 " lda 56,dl RTS(56) sta pr6|rts_code add alt rec keys epp0 return_from_alt_add set fields in FSB spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_add: szn pr6|mcode tze return_to_reset " lda io9_con status-key-1,2 ldq s4730con status-key-3 staq pr6|status12 ldx1 64,du unable to add keys tra io_return_to_reset " "[3.0-1] "[3.0-1] alt_write_seek_key **********OPERATOR(91)********** "[3.0-1] "[3.0-1] " alt_write_seek_key: inhibit on stx0 pr6|return_to_main_off inhibit off " lda pr6|80 sta pr6|100 save record size spri7 pr6|80 set file descr ptr spri5 pr6|78 store buff ptr epp7 pr6|mcode mcode_ptr spri7 pr6|76 stz pr6|mcode " lda 51,dl RTS(51) sta pr6|rts_code if necessary: test key order, SAVE_CRP epp0 return_from_write_seek test alt key values for legality spri0 pr6|stack_frame.return_ptr move key in FSB one pos to right tra call_rts_from_op " return_from_write_seek: lda pr6|100 sta pr6|80 restore record size szn pr6|mcode tze return_to_reset " lda io9_con status-key-1,2 ldq s4430con status-key-3 staq pr6|status12 ldx1 21,du unable to write record tra io_return_to_reset "[3.0-1] "[3.0-1] alt_find_rec **********OPERATOR(92)********** "[3.0-1] "[3.0-1] " alt_find_rec: inhibit on stx0 pr6|return_to_main_off inhibit off " spri7 pr6|80 set file descr ptr stz pr6|icode epp7 pr6|mcode mcode_ptr spri7 pr6|76 " lda 57,dl RTS(57) sta pr6|rts_code if necessary then RESTORE_CRP epp0 return_from_alt_find spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " return_from_alt_find: " szn pr6|mcode tze return_to_reset " tra read_record_exit " " alt_rewrite **********OPERATOR(93)********** " alt_rewrite: inhibit on stx0 pr6|return_to_main_off inhibit off " spri5 pr6|78 loc of buffer stz pr6|mcode mcode ptr epp7 pr6|mcode spri7 pr6|76 " lda 61,dl RTS(61) sta pr6|rts_code epp0 return_from_rew_del spri0 pr6|stack_frame.return_ptr tra call_rts_from_op " " " read_record used by cobol_read_gen **********OPERATOR(66)********** " nonseq_read_record: inhibit on stx0 pr6|return_to_main_off inhibit off lda 1,dl sta pr6|54 tra read_common " " **********OPERATOR(65)********** " " read_record: inhibit on stx0 pr6|return_to_main_off inhibit off stz pr6|54 read_common: epp1 pr6|86,* set iocb_ptr spri5 pr6|78 store buff_ptr epp2 pr6|78 spri2 pr6|88 store pointer to buff_ptr epp2 pr6|80 spri2 pr6|90 store pointer to buff_len stz pr6|47 epp2 pr6|47 spri2 pr6|92 length of record in bytes output epp2 pr6|mcode spri2 pr6|94 store pointer to mcode " RTS(63) stz pr6|mcode [5.3-1] lda 63,dl [5.3-1] sta pr6|rts_code [5.3-1] epp0 return_read_record spri0 pr6|stack_frame.return_ptr tra call_rts_from_op [5.3-1] even return_read_record: szn pr6|mcode tze return_to_reset read_record_exit: epp4 pr6|linkage_ptr,* epp2 pr6|mcode spri2 pr6|76 " RTS(27) lda 27,dl sta pr6|rts_code epp0 return_read_record_exit spri0 pr6|stack_frame.return_ptr tra call_rts_from_op even return_read_record_exit: szn pr6|mcode tze return_to_reset ldx1 25,du tra io_return_to_reset " " " init_start check file condition**********OPERATOR(21)********** " " init_start: inhibit on stx0 pr6|return_to_main_off inhibit off " spri1 pr6|86 set fsb_ptr stz pr6|icode szn pr1|2 is file open tnz pr6|text_base_ptr,*0 YES " set status lda io30_con ldq s6031con staq pr6|status12 ldx1 24,du attempt to perform io on unopened file tra io_return_to_reset " " " iox_$control perform control order on io switch.**********OPERATOR(23)********** " " start_control: inhibit on stx0 pr6|return_to_main_off inhibit off " epp1 pr6|86,* set iocb_ptr spri6 pr6|48 store stack_offset ptr for order name spri6 pr6|50 adx5 pr6|49 add base offset to x5 stx5 pr6|49 set correct offset adx5 2,du stx5 pr6|51 spri1 pr6|48,* store fsb pointer epp2 pr6|50,* adwp2 2,du spri2 pr6|50,* store control pointer epp2 pr6|40 spri2 pr6|76 store mcode_ptr " RTS(11) lda 11,dl sta pr6|rts_code epp0 return_start_control spri0 pr6|stack_frame.return_ptr tra call_rts_from_op iox_control " return_start_control: szn pr6|mcode tze return_to_reset " set status ldx1 38,du unable to start a file with specified key tra io_return_to_reset " " close_reel **********OPERATOR(76)********** " close_reel: inhibit on stx0 pr6|return_to_main_off inhibit off lda pr1|2 get open_mode tze file_unopen file not open yet, error epp0 ptr_desc spri0 pr6|100 spri0 pr6|104 epp0 fb35_desc spri0 pr6|106 spri1 pr6|92 set parameter for iocb_ptr epp0 pr6|76 tvstat_ptr for input reel spri0 pr6|96 epp0 pr6|mcode mcode_ptr spri0 pr6|98 cmpa 21,dl input reel? tze input_reel yes cmpa 17,dl input reel? tze input_reel yes ldaq null_con staq pr6|76 null info_ptr epp0 feov_desc spri0 pr6|102 epp0 feov_con char "feov" spri0 pr6|94 eax1 pr6|90 fld 8192,dl epp2 pr1|0,* iocb_ptr epp2 pr2|54 entry iocb.control tra call_ent_var_desc_from_op input_reel: spri0 pr6|88 parameter mcode_ptr for position call spri1 pr6|82 epp0 volume_desc spri0 pr6|102 epp0 volume_con char "volume_status" spri0 pr6|94 epp0 zero_con type 0 spri0 pr6|84 epp0 one_con 1 record for each position operation spri0 pr6|86 stz pr6|78 initialize volume no. for comparison vol_call: eax1 pr6|90 fld 8192,dl 4 parameters epp1 pr6|92,* fsb_ptr epp2 pr1|0,* iocb_ptr epp2 pr2|54 iocb.control epp0 return_from_vol_call spri0 pr6|stack_frame.return_ptr tra call_ent_var_desc_from_op return_from_vol_call: szn pr6|mcode check error code tnz reel_exit vol_call_ok: epp1 pr6|76,* tvstat_ptr lda pr1|3 volume sequence no. szn pr6|78 first call? tnz vol_comp no, goto compare sta pr6|78 yes. save vol seq no. tra posi_call call position operation vol_comp: cmpa pr6|78 comparing vol seq nos tnz reel_exit not equal, done. posi_call: eax1 pr6|80 fld 8192,dl epp1 pr6|82,* fsb_ptr epp2 pr1|0,* iocb_ptr epp2 pr2|50 position entry epp0 return_from_posi_call spri0 pr6|stack_frame.return_ptr tra call_ent_var_from_op return_from_posi_call: szn pr6|mcode check mocde tze vol_call next volume_status call tra reel_exit return file_unopen: lda pr1|90 optional bit cmpa optional_int optional internal tze return_to_reset cmpa optional_ext optional external tze return_to_reset lda io30_con ldq s2036con staq pr6|status12 ldx1 17,du tra return_thru_text_base_pone reel_exit: epp1 pr6|92,* tra return_to_reset " " " " " Please insert the next operator before this line. " " segdef cobol_operators_end cobol_operators_end: oct 0 include cobol_operators_info end  cobol_rts_.pl1 10/19/90 1706.5rew 10/19/90 1655.1 540099 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8090), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8090 cobol_rts_.pl1 Disallow duplicate prime keys in Indexed Sequential files. 2) change(90-10-03,Zimmerman), approve(90-10-03,MCR8218), audit(90-10-10,Gray), install(90-10-19,MR12.4-1048): Add check for pre-MR12.3 object segs to prevent attempts to access fields that do not exist. END HISTORY COMMENTS */ /* Modified on 12/19/84 by FCH, [5.3-1], BUG573(phx16343), error checking fails for ark */ /* Modified on 07/17/82 by FCH, [5.1-1], REWRITE after ACCESS DYNAMIC can cause runtime abort, BUG532(phx13391) */ /* Modified on 09/18/81 by FCH, [5.0-1], WRITE with alt keys can abort in rts, BUG 506 */ /* Modified on 06/11/81 by FCH, [4.4-2], RTS(62) added for STOP RUN with CD INITIAL */ /* Modified on 02/19/81 by FCH, [4.4-1], REWRITE invalid detection not correct, RTS(61) added, BUG464 */ /* Modified on 12/13/79 by PRP, [4.1-1], day of year fixed for leap year */ /* Modified on 09/14/79 by FCH, [4.0-4], iox_$attach_ptr replaces iox_$attach_iocb */ /* Modified on 09/06/79 by FCH, [4.0-3], rewrite with alt rec keys */ /* Modified on 08/24/79 by PRP, [4.0-2], rts(60) added for alternate key start control */ /* Modified on 08/13/79 by FCH, [4.0-1], icode value changed in start statement */ /* Modified since Version 4.0 */ /* This is the cobol run time interface procedure. It is called by the cobol_operators_ with the parameters are set in the stack frame starting from the 68th word. From the 68th word up through the 107th word are reserved for this interfacinguse. From the 108th word up through the 137th word are reserved for the condition handling use. The 68th word up through the 73th word are used to set the parameter rts_stack_ptr. The rts_code is the 88th words of the stack frame, it is used to decide the run time procedure that cobol_rts_ is going to call. Register Usage $pr0 cobol_operators_ $pr1 fsb pointer $pr2 temporary $pr3 cobol_data_area $pr4 cobol_linkage_area $pr5 cobol_data_area(extension) $pr6 stack_prame pointer $pr7 temporary Run Time Stack Frame 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 10 9 11 10 12 11 13 12 14 13 15 14 16 15 17 16 20 S.prev_sp, S.condition_word, S.flag_word 17 21 18 22 S.next_sp, S.signaller_word 19 23 20 24 S.return_ptr 21 25 22 26 S.entry_ptr 23 27 24 30 S.operator_ptr, S.lp_ptr 25 31 26 32 S.arg_ptr 27 33 28 34 S.static_ptr 29 35 S.support_ptr 30 36 S.on_unit_relptrs, on_unit_ptr 31 37 S.operator_ret_ptr, S.translator_id, op_return_offset 32 40 S.regs, display_ptr 33 41 34 42 descriptor_ptr 35 43 36 44 linkage_ptr 37 45 38 46 text_base_ptr 39 47 text_base_off 40 50 mcode 41 51 icode 42 52 status12 43 53 status3 44 54 retrycode, cobol_open_mode 45 55 46 56 multics_open_mode 47 57 48 60 S.min_length 49 61 50 62 51 63 52 64 53 65 54 66 55 67 56 70 57 71 58 72 59 73 60 74 61 75 62 76 63 77 64 100 return_to_main_ptr 65 101 return_to_main_off 66 102 rts_code_ptr 67 103 68 104 69 105 70 106 71 107 72 110 rts_code args to cobol_rts 73 111 use_code 74 112 iocb_ptr 75 113 76 114 mcode_ptr 77 115 78 116 buff_ptr 79 117 80 120 buff_len 81 121 actual_ptr 82 122 stack_buff_ptr, cobol_open_mode 83 123 cobol_options 84 124 vfile_open_mode 85 125 key of ref 86 126 fsb_ptr iox_, arg-1 args for iox_calls 87 127 88 130 file_desc_ptr iox_, arg-2 89 131 cobol_error_code 90 132 iox_, arg-3 91 133 92 134 iox_, arg-4 93 135 94 136 95 137 96 140 97 141 98 142 99 143 100 144 x6_save 101 145 102 145 103 147 104 150 105 151 106 152 subr_return_save 107 153 subr_return_save_off 108 154 pr4_save 109 155 110 156 pr3_save 111 157 112 160 pr5_save 113 161 114 162 rts_save 115 163 116 164 ind_mask 117 165 ENTRY OPTIONS FUNCTION NAME COBOL OPERATORS (1) cobol_error_ (2) cobol_control_ (3) sort_initiate (4) sort_release (5) sort_return (6) sort_terminate (7) sort_commence (8) stop_literal (9) stop_run (10) cancel (11) iox_$control 23 (129 check_close_error 27,29,36,38 (13) check_open_error (14) iox_$find_iocb (15) iox_$attach_iocb 29,35,36 (16) check_seek_errors 41,54,67 (17) iox_$read_key 55 (18) accept (19) (20) accept_id (21) accept_id (22) accept_id (23) inspect (24) inspect (25) seek_for_delete 57,58 (26) read_key_status_code 69 (27) check_read_record 65,66 (28) check_get_line 64 (29) (30) merge_init (31) merge_comp (32) merge_return (33) (34) (35) (36) (37) (38) (39) (40) receive_comm (41) accept_comm (42) purge_comm (43) send_comm (44) enable_comm (45) disable_comm (46) alt_file_open (47) alt_read_record Status_Key_1 (Status_Key_2) org = seq 0(0)1(0)3(0,4)9 org = rel 0(0)1(0)2(2,3,4)3(0)9 org=ind 0(0,2)1(0)2(1,2,3,4)3(0)9 Status_Key_1 = 0 success 1 at end 2 invalid 3 permanent error 9 implementor defined Status_Key_2 = 0 no more information 1 sequence error 2 duplicate key 3 no record found 4 boundary violation Status_Key_3 pic 9999 wxyz w: cobol i/o statement x: vfile_command y: same as key_1 z: specific cause of error vfile_commands and error codes attach_ptr (not_detached) close (not_open) delete_record (no_record) detach_iocb (not_attached, not_closed) find_iocb () get_chars (short_record,end_of_info) get_line (short_record,end_of_info) open (not_attached,not_closed) position (no_record,end_of_info) read_key (end_of_info,no_record) read_length (end_of_info,no_record) read_record (end_of_info,no_record,long_record) record_status) (no_room_for_lock,no_record,no_key) rewrite_record (no_record) seek_head (no_record) seek_key (no_record,key_order) write_record (no_key) */ /* format: style3 */ cobol_rts_: proc (rts_ptr); dcl 1 rts_stack based (rts_stack_ptr), 2 rts_code fixed bin; dcl temp_mcode fixed bin (35); dcl rts_stack_ptr ptr; dcl rts_ptr ptr; rts_stack_ptr = rts_ptr; goto rts (rts_stack.rts_code); /* ******************************* * * * cobol_error_ * * * *******************************/ rts (1): /* This label is for cobol error */ /* The declaration for the rts stack frame */ dcl 1 error_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 use_code fixed bin, 2 filler1 char (60), 2 cobol_code fixed bin, 2 multics_code fixed bin (35), 2 filler2 fixed bin, 2 line_no1 fixed bin, 2 line_no2 fixed bin, 2 error_ptr ptr, 2 progname_ptr ptr, 2 progname_length fixed bin; dcl progname char (65) based (progname_ptr); if error_stack.use_code = 0 then call cobol_error_ (error_stack.cobol_code, error_stack.multics_code, error_stack.line_no1, error_stack.line_no2, substr (progname, 1, error_stack.progname_length), error_stack.error_ptr); else do; error_stack.use_code = 0; call cobol_error_$use (error_stack.cobol_code, error_stack.multics_code, error_stack.line_no1, error_stack.line_no2, substr (progname, 1, error_stack.progname_length), error_stack.error_ptr); end; return; /* ******************************* * * * cobol_control_ * * * *******************************/ rts (2): /* This label is for cobol control */ /* This stack frame is for cobol_contool_ rts stack frame. */ dcl 1 control_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 filler char (4), 2 pr4_save_ptr ptr; call cobol_control_$cobol_rts_control_ (control_stack.pr4_save_ptr); return; /* *******************************************************************************************/ /* BEGIN SORT PACKAGE */ /* *******************************************************************************************/ /* ******************************* * * * sort_initiate * * * *******************************/ rts (3): /* This label is for sort_initiate */ /* The declaration for the rts stack frame */ dcl 1 sort_initiate_stack based (rts_stack_ptr), 2 filler1 char (8), 2 exit_ptr ptr, 2 control_ptr ptr, 2 filler2 char (8), 2 status_code fixed bin (35); dcl 1 exits based (sort_initiate_stack.exit_ptr), 2 version fixed bin, 2 compare entry, 2 input_record entry, 2 output_record entry; exits.input_record = sort_$noexit; exits.output_record = sort_$noexit; controlp = sort_initiate_stack.control_ptr; if sort_file_size = 0.0 then sort_file_size = 1.0; if sort_dir_len = 0 then call sort_$initiate ("", null (), sort_initiate_stack.exit_ptr, "-bf", sort_file_size, sort_initiate_stack.status_code); else call sort_$initiate (substr (sort_dir, 1, sort_dir_len), null (), sort_initiate_stack.exit_ptr, "-bf", sort_file_size, sort_initiate_stack.status_code); return; /* ******************************* * * * sort_release * * * *******************************/ rts (4): /* This label is for sort_release */ /* The declaration for the rts stack frame */ dcl 1 sort_release_stack based (rts_stack_ptr), 2 filler1 char (8), 2 data_ptr ptr, 2 data_length fixed bin (21), 2 filler2 char (12), 2 status_code fixed bin (35); dcl sort_$release entry (ptr, fixed bin (21), fixed bin (35)); call sort_$release (sort_release_stack.data_ptr, sort_release_stack.data_length, sort_release_stack.status_code) ; return; /* ******************************* * * * sort_return * * * *******************************/ rts (5): /* This label is for sort_return */ /* The declaration for the rts stack frame */ dcl 1 sort_return_stack based (rts_stack_ptr), 2 filler1 char (8), 2 buff_ptr ptr, 2 record_length fixed bin (21), 2 filler2 char (12), 2 status_code fixed bin (35); call sort_$return (sort_return_stack.buff_ptr, sort_return_stack.record_length, sort_return_stack.status_code); if sort_return_stack.status_code = 0 then return; else if sort_return_stack.status_code = error_table_$end_of_info then do; sort_return_stack.record_length = 0; sort_return_stack.status_code = 0; end; return; /* ******************************* * * * sort_terminate * * * *******************************/ rts (6): /* This label is for sort_terminate */ /* The declaration for the rts stack frame */ dcl 1 sort_terminate_stack based (rts_stack_ptr), 2 filler1 char (8), 2 status_code fixed bin (35), 2 filler2 char (20), 2 prev_status_code fixed bin (35); call sort_$terminate (sort_terminate_stack.status_code); return; /* ******************************* * * * sort_commence * * * *******************************/ rts (7): /* This label is for sort_commence */ /* The declaration for the rts stack frame */ dcl 1 sort_commence_stack based (rts_stack_ptr), 2 filler1 char (32), 2 status_code fixed bin (35); call sort_$commence (sort_commence_stack.status_code); return; /* *******************************************************************************************/ /* END SORT PACKAGE */ /* *******************************************************************************************/ /* ******************************* * * * stop literal * * * *******************************/ rts (8): /* This label is for "stop literal". It is used to eleminate the link for cu_$cl.*/ call cu_$cl; return; /* ******************************* * * * stop run * * * *******************************/ rts (9): /* This label is for "stop run". It is used to eleminate the link for cobol_stoprun_. */ dcl temp_ptr ptr based; /* temporary pointer. */ stat_ptr = addrel (rts_stack_ptr, 36) -> temp_ptr;/* linkage section */ stat_ptr = addrel (stat_ptr, 8); /* static section */ controlp = stat.control_ptr; rts9: if control.main_prog_sw ^= 0 then call signal_ ("stop_run", null (), stat_ptr); call cobol_stop_run_ (stat_ptr, 0, 0, 0); call signal_ ("command_abort_", null (), null ()); return; rts (62): /*[4.4-2]*/ dcl cobol_mcs_$stop_run entry; /*[4.4-2]*/ stat_ptr = addrel (rts_stack_ptr, 36) -> temp_ptr;/* linkage section */ /*[4.4-2]*/ stat_ptr = addrel (stat_ptr, 8); /* static section */ /*[4.4-2]*/ controlp = stat.control_ptr; /*[4.4-2]*/ call cobol_mcs_$stop_run; go to rts9; /* ******************************* * * * cancel * * * *******************************/ rts (10): /* this label is for cancel code to call cobol_control_$cancel */ dcl 1 cancel_stack based (rts_stack_ptr), 2 filler char (8), 2 name_ptr ptr, 2 name_length fixed bin, 2 cancel_code fixed bin; dcl cancel_name char (65) based (cancel_stack.name_ptr); call cobol_control_$cancel (substr (cancel_name, 1, cancel_stack.name_length), 0, 0, cancel_code); return; /* *******************************************************************************************/ /* BEGIN IO PACKAGE */ /* *******************************************************************************************/ /****************************** * * * iox_$control * * * *******************************/ rts (11): /* This label is for iox_$control */ dcl 1 iox_control_stack based (error_block.offset_ptr), 2 iocb_ptr ptr, 2 control_ptr ptr; dcl 1 struc based (iox_control_stack.control_ptr), 2 relation fixed bin, 2 keylen fixed bin, 2 key char (0 refer (keylen)); dcl order_name char (9) init ("seek_head"); dcl control_iocb_ptr ptr based (iox_control_stack.iocb_ptr); call iox_$control (control_iocb_ptr, order_name, iox_control_stack.control_ptr, mcode); if mcode ^= 0 then do; if mcode = error_table_$no_record then do; error_block.status12 = "23"; error_block.status3 = "6723"; /*[4.0-1] */ icode = 4; end; else do; error_block.status12 = "30"; error_block.status3 = "6732"; end; end; return; /* The declaration for the rts stack frame */ dcl 1 io_stack_hdr based (rts_stack_ptr), 2 rts_code fixed bin, 2 use_code fixed bin, 2 iocb_ptr ptr, 2 mcode_ptr ptr, 2 buff_ptr ptr, 2 buff_len fixed bin (21), 2 actual_len fixed bin (21), 2 stack_buff_ptr ptr; dcl 1 read_key_based based (addr (io_stack_hdr.stack_buff_ptr)), 2 filler fixed bin, 2 read_key_eof fixed bin; dcl 1 error_block based (io_stack_hdr.mcode_ptr), 2 mcode fixed bin (35), 2 icode fixed bin, 2 status12 char (2) aligned, 2 status3 char (4) aligned, 2 retrycode fixed bin, 2 filler1 char (4), 2 option_flag fixed bin, 2 filler2 char (4), 2 offset_ptr ptr, 2 filler13 char (16), 2 temp_flag fixed bin; /* ******************************* * * * check close error * * * *******************************/ rts (12): /* This label is for check close error */ /* The fields referenced are in dcl error_block. */ check_close_error: error_block.status12 = "30"; if mcode = error_table_$no_operation then error_block.status3 = "2332"; else if mcode = error_table_$bad_file then error_block.status3 = "2392"; else error_block.status3 = "2390"; return; /****************************** * * * check open error * * * *******************************/ rts (13): /* This label is for check open error */ /* The fields referenced are in dcl error_block. */ check_open_error: error_block.status12 = "30"; if mcode = error_table_$no_operation then error_block.status3 = "1232"; else if mcode = error_table_$file_busy then error_block.status3 = "1291"; else if mcode = error_table_$incompatible_attach then error_block.status3 = "1294"; else if mcode = error_table_$bad_file then error_block.status3 = "1292"; else if mcode = error_table_$noentry then error_block.status3 = "1295"; else error_block.status3 = "1290"; return; /****************************** * * * iox_$find_iocb * * * *******************************/ rts (14): /* This label is for iox_$find_iocb */ dcl 1 find_iocb_stack based (error_block.offset_ptr), 2 fsb_ptr ptr, 2 switchlen fixed bin, 2 filler2 char (4), 2 switchname char (0 refer (find_iocb_stack.switchlen)); dcl find_iocb_ptr ptr based (find_iocb_stack.fsb_ptr); call iox_$find_iocb (find_iocb_stack.switchname, find_iocb_ptr, error_block.mcode); return; /******************************* * * * iox_$attach_ptr * * * *******************************/ rts (15): /* This labe is for iox_$attach_iocb */ dcl 1 attach_iocb_stack based (error_block.offset_ptr), 2 fsb_ptr ptr, 2 atdlen fixed bin, 2 filler2 char (4), 2 atd char (0 refer (attach_iocb_stack.atdlen)); dcl attach_iocb_ptr ptr based (attach_iocb_stack.fsb_ptr); /*[4.0-4]*/ call iox_$attach_ptr (attach_iocb_ptr, attach_iocb_stack.atd, null (), error_block.mcode); return; /****************************** * * * check seek errors * * * *******************************/ rts (16): /* This label is for check seek key errors */ check_seek_error: if temp_flag = 1 then do; if mcode = error_table_$key_order then do; icode = 1; error_block.status12 = "21"; error_block.status3 = "3621"; end; else if mcode = error_table_$no_record then do; icode = 1; error_block.status12 = "23"; error_block.status3 = "3623"; end; else do; error_block.status12 = "30"; if mcode = error_table_$no_operation then error_block.status3 = "3632"; else error_block.status3 = "3630"; end; end; else do; if mcode = error_table_$no_record then do; error_block.status12 = "00"; error_block.status3 = "0000"; mcode = 0; end; else if mcode = error_table_$key_order then do; error_block.status12 = "21"; error_block.status3 = "4621"; end; else do; error_block.status12 = "21"; error_block.status3 = "4622"; end; end; return; /******************************* * * * iox_$read_key * * * *******************************/ rts (17): /* This label is for iox_$read_key errors */ read_key_error: /* don't report EOF now, wait for seek */ if mcode = error_table_$end_of_info then do; error_block.status12 = "00"; error_block.status3 = "0000"; read_key_based.read_key_eof = 1; mcode = 0; end; else if mcode = error_table_$no_record then do; error_block.status12 = "10"; error_block.status3 = "3830"; end; return; /* ******************************* * * * accept * * * *******************************/ rts (18): /* This label is interfacing with accept_gen for accpting user's word. */ call iox_$get_line (iox_$user_input, io_stack_hdr.buff_ptr, io_stack_hdr.buff_len, io_stack_hdr.actual_len, error_block.mcode); if error_block.mcode = error_table_$long_record then do while (error_block.mcode = error_table_$long_record); call iox_$get_line (iox_$user_input, io_stack_hdr.stack_buff_ptr, 64, io_stack_hdr.actual_len, error_block.mcode); io_stack_hdr.actual_len = 0; end; return; rts (20): rts (21): rts (22): /* These labels are for accept from day (time,day of week, and date). */ dcl 1 time_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 use_code fixed bin, 2 month fixed bin, 2 filler1 char (4), 2 dom fixed bin, /* day of the month */ 2 filler2 char (4), 2 year fixed bin, 2 filler3 char (4), 2 tod fixed bin (71), /*time of the day */ 2 dow fixed bin, /*day of the week */ 2 zone char (3) aligned, /* time zone */ 2 day_return fixed bin, /* day in the form yy||doy */ 2 filler4 char (4), 2 doy fixed bin, /* day of the year */ 2 filler5 char (4), 2 date char (6); /* day in the form yy||mm||dd */ dcl date_time fixed bin (71), d_array (12) fixed bin static init (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334), day_temp char (8); date_time = clock_ (); if time_stack.rts_code = 22 then do; call date_time_ (date_time, day_temp); date = substr (day_temp, 7, 2) || substr (day_temp, 1, 2) || substr (day_temp, 4, 2); return; end; call decode_clock_value_ (date_time, month, dom, year, tod, dow, zone); if time_stack.rts_code ^= 20 then return; doy = d_array (month) + dom; if mod (year, 4) = 0 & month > 2 /* [4.1-1] */ then doy = doy + 1; else /*do nothing */ ; return; /* ******************************* * * * inspect * * * *******************************/ rts (23): rts (24): /* These labels are for inspect to call cobol_su_$tally and cobol_su_$replace. */ dcl 1 inspect_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 filler char (4), 2 work_ptr ptr, 2 output_length fixed bin; if inspect_stack.rts_code = 24 then call cobol_su_$replace (inspect_stack.work_ptr); else call cobol_su_$tally (inspect_stack.work_ptr, inspect_stack.output_length); return; /* ***************************************** * * * seek for delete * * * *******************************/ rts (25): /* This label is for delete seek and delete record. */ if mcode = error_table_$no_record then do; error_block.status12 = "00"; error_block.status3 = "0000"; mcode = 0; end; return; /******************************* * * * check_read_key * * * *******************************/ rts (26): /* This label is used to set up status code for read key */ /* don't report EOF now, wait for seek */ if mcode = error_table_$end_of_info then do; error_block.status12 = "10"; error_block.status3 = "3810"; icode = 1; end; else if mcode = error_table_$no_record then do; icode = 1; error_block.status12 = "10"; error_block.status3 = "3830"; end; else if mcode = error_table_$no_operation then do; error_block.status12 = "30"; error_block.status3 = "3832"; end; else do; error_block.status12 = "30"; error_block.status3 = "3830"; end; return; /******************************* * * * check_read_record * * * *******************************/ rts (27): /* This label is used to set up status code for read record */ if mcode = error_table_$short_record then do; mcode = 0; error_block.status12 = "00"; error_block.status3 = "3001"; end; else if mcode = error_table_$no_record then do; if temp_flag = 1 then do; error_block.status12 = "23"; error_block.status3 = "3423"; end; else do; error_block.status12 = "10"; error_block.status3 = "3430"; end; icode = 1; end; else if mcode = error_table_$end_of_info then do; icode = 1; if temp_flag = 0 then do; error_block.status12 = "10"; error_block.status3 = "3410"; end; else do; error_block.status12 = "30"; error_block.status3 = "3430"; end; end; else do; error_block.status12 = "30"; if mcode = error_table_$no_operation then error_block.status3 = "3432"; else do; error_block.status12 = "10"; /* force END OF FILE condition */ error_block.status3 = "3410"; end; end; return; /******************************* * * * check_get_line * * * *******************************/ rts (28): /* This label is used to set up status codes for get_line. */ if mcode = error_table_$end_of_info then do; icode = 1; error_block.status12 = "10"; error_block.status3 = "3510"; end; else if mcode = error_table_$long_record then do; error_block.status12 = "30"; error_block.status3 = "3535"; end; else do; error_block.status12 = "30"; error_block.status3 = "3535"; end; return; /* *******************************************************************************************/ /* END IO PACKAGE */ /* *******************************************************************************************/ /* *******************************************************************************************/ /* BEGIN MERGE PACKAGE */ /* *******************************************************************************************/ /* The declaration for the communication stack frame which is shared by all merge rts package. */ dcl 1 merge_comm_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 filler char (28), 2 merge_stack_off_rts fixed bin, 2 file_n_rts fixed bin, 2 merge_record_ptr_rts ptr, 2 tree_ptr_rts ptr, 2 comp_ptr_rts ptr, 2 merge_controlp ptr; /* static internal data for merge communication stack frame in case the merge_comm_stack is destoryed by other rts call. */ dcl 1 merge_comm_static static, 2 merge_stack_off fixed bin, /* start offset for record ptr. */ 2 file_n fixed bin, /* no of using file. */ 2 merge_record_ptr ptr, /* base of record (pointers) */ 2 tree_ptr ptr, /* base of tree (fixed bin) */ 2 comp_ptr ptr, /* base of compare entry. */ 2 merge_seg_ptr ptr; /* pointer for cobol_temp_merge_file_. */ /* compare entry */ dcl 1 cmp_entry based (merge_comm_static.comp_ptr), 2 merge_compare entry (ptr, ptr, fixed bin); /* pointers to the cra of each using file. */ dcl 1 merge_record based (merge_comm_static.merge_record_ptr), 2 record (merge_comm_static.file_n) ptr; /* temporary locations for compare usage. */ dcl 1 merge_tree based (merge_comm_static.tree_ptr), 2 tree (2 * merge_comm_static.file_n - 1) fixed bin, 2 compare_code fixed bin; /* Automatic data for merge package. */ dcl (i, j, k, w) fixed bin; /* ******************************* * * * merge_init * * * *******************************/ rts (30): /* Initialize the stack frame for merge and trees. */ merge_comm_static.file_n = merge_comm_stack.file_n_rts; merge_comm_static.merge_record_ptr = merge_comm_stack.merge_record_ptr_rts; merge_comm_static.tree_ptr = merge_comm_stack.tree_ptr_rts; merge_comm_static.comp_ptr = merge_comm_stack.comp_ptr_rts; controlp = merge_controlp; call hcs_$terminate_name ("cobol_temp_merge_file_", temp_mcode); if sort_dir_len = 0 then do; sort_dir = get_pdir_ (); sort_dir_len = index (sort_dir, " ") - 1; end; call hcs_$make_seg (substr (sort_dir, 1, sort_dir_len), "cobol_temp_merge_file_", "cobol_temp_merge_file_", 01011b, merge_seg_ptr, temp_mcode); call hcs_$truncate_seg (merge_seg_ptr, 0, temp_mcode); do i = 1 to merge_comm_static.file_n; merge_tree.tree (i) = i; end; return; /* ******************************* * * * merge_comp * * * *******************************/ rts (31): /* Set up to call merge compare. */ if merge_comm_static.file_n = 1 then return; do i = 1 by 2 to (2 * merge_comm_static.file_n - 3); call merge_call_compare (i, i + 1); end; return; /* ******************************* * * * merge_return * * * *******************************/ rts (32): /* handle return statement for merge. */ k = 2 * merge_comm_static.file_n - 1; if k = 1 then return; i = tree (k); do while (i < k); if mod (i, 2) = 0 then j = i - 1; else j = i + 1; call merge_call_compare (i, j); i = w; end; return; /* *******************************************************************************************/ /* INTERNAL SUBROUTINE FOR MERGE COMPARE SET UP */ /* *******************************************************************************************/ merge_call_compare: proc (i, j); /* This subroutine is used to set up tree on the stack frame through the compare entry on the cobol object code. */ dcl (i, j) fixed bin; w = merge_comm_static.file_n + (i + 1) / 2; if merge_tree.tree (i) = 0 then merge_tree.tree (w) = merge_tree.tree (j); /* eof of file i */ else if merge_tree.tree (j) = 0 then merge_tree.tree (w) = merge_tree.tree (i); /* eof of file j */ else do; call merge_compare (merge_record.record (merge_tree.tree (i)), merge_record.record (merge_tree.tree (j)), merge_tree.compare_code); if merge_tree.compare_code = -1 then merge_tree.tree (w) = merge_tree.tree (i); else if merge_tree.compare_code = 1 then merge_tree.tree (w) = merge_tree.tree (j); else if merge_tree.tree (i) < merge_tree.tree (j) then merge_tree.tree (w) = merge_tree.tree (i); else merge_tree.tree (w) = merge_tree.tree (j); end; return; end merge_call_compare; /* *******************************************************************************************/ /* END MERGE PACKAGE */ /* *******************************************************************************************/ /* *******************************************************************************************/ /* BEGIN COMMUNICATION PACKAGE */ /* *******************************************************************************************/ /* ******************************* * * * receive_comm * * * *******************************/ rts (40): dcl 1 receive_comm_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 filler fixed bin, 2 mcs_icdp ptr, 2 mesp ptr, 2 type fixed bin, 2 max_meslen fixed bin, 2 filler1 fixed bin, 2 no_data fixed bin, 2 filler2 char (8), 2 code fixed bin (35); if receive_comm_stack.type >= 2 then do; receive_comm_stack.type = receive_comm_stack.type - 2; call cobol_mcs_$receive (receive_comm_stack.mcs_icdp, receive_comm_stack.type, receive_comm_stack.mesp, receive_comm_stack.max_meslen, receive_comm_stack.code); if receive_comm_stack.code = cmcs_error_table_$no_message then do; receive_comm_stack.code = 0; receive_comm_stack.no_data = 1; end; else receive_comm_stack.no_data = 0; end; else do; call cobol_mcs_$receive_wait (receive_comm_stack.mcs_icdp, receive_comm_stack.type, receive_comm_stack.mesp, receive_comm_stack.max_meslen, receive_comm_stack.code); end; return; /* ******************************* * * * accept_comm * * * *******************************/ rts (41): dcl 1 accept_comm_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 filler fixed bin, 2 mcs_icdp ptr, 2 filler1 char (32), 2 code fixed bin (35); call cobol_mcs_$accept (accept_comm_stack.mcs_icdp, accept_comm_stack.code); return; /* ******************************* * * * purge_comm * * * *******************************/ rts (42): dcl 1 purge_comm_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 filler fixed bin, 2 mcs_icdp ptr, 2 filler1 char (32), 2 code fixed bin (35); call cobol_mcs_$purge (purge_comm_stack.mcs_icdp, purge_comm_stack.code); return; /* ******************************* * * * send_comm * * * *******************************/ rts (43): dcl 1 send_comm_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 filler fixed bin, 2 mcs_ocdp ptr, 2 mesp ptr, 2 max_meslen char (4), 2 end_indicator char (1), 2 filler2 char (3), 2 line_control bit (36), 2 filler1 char (12), 2 code fixed bin (35); call cobol_mcs_$send (send_comm_stack.mcs_ocdp, send_comm_stack.mesp, send_comm_stack.max_meslen, send_comm_stack.end_indicator, send_comm_stack.line_control, send_comm_stack.code); return; /* ******************************* * * * enable_comm * * * *******************************/ rts (44): dcl 1 enable_comm_stack based (rts_stack_ptr), 2 rts_code fixed bin, 2 filler fixed bin, 2 mcs_icdp ptr, 2 password_ptr ptr, 2 password_length fixed bin, 2 in_or_out fixed bin, 2 terminal_flag fixed bin, 2 filler1 char (12), 2 code fixed bin (35); dcl password char (30) based (enable_comm_stack.password_ptr); if enable_comm_stack.in_or_out = 0 then do; if enable_comm_stack.terminal_flag = 1 then call cobol_mcs_$enable_input_terminal (enable_comm_stack.mcs_icdp, substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); else call cobol_mcs_$enable_input_queue (enable_comm_stack.mcs_icdp, substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); end; else call cobol_mcs_$enable_output (enable_comm_stack.mcs_icdp, substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); return; rts (45): /* Disable use the same stack as enable. */ if enable_comm_stack.in_or_out = 0 then do; if enable_comm_stack.terminal_flag = 1 then call cobol_mcs_$disable_input_terminal (enable_comm_stack.mcs_icdp, substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); else call cobol_mcs_$disable_input_queue (enable_comm_stack.mcs_icdp, substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); end; else call cobol_mcs_$disable_output (enable_comm_stack.mcs_icdp, substr (password, 1, enable_comm_stack.password_length), enable_comm_stack.code); return; /* */ /* *******************************************************************************************/ /* BEGIN ALTERNATE RECORD KEY PACKAGE */ /* *******************************************************************************************/ dcl 1 alt_stack_hdr based (rts_stack_ptr), 2 rts_code fixed bin (35), 2 use_code fixed bin (35), 2 iocb_ptr ptr, 2 mcode_ptr ptr, 2 file_rec_buf_ptr ptr, 2 file_desc_ptr ptr, 2 cobol_open_mode fixed bin (35), 2 cobol_options fixed bin (35), 2 vfile_open_mode fixed bin (35), 2 key_of_ref fixed bin (35), 2 fsb_ptr ptr, /*[5.3-1]*/ 2 arg2_ptr ptr, /*[5.3-1]*/ 2 arg3_ptr ptr, /*[5.3-1]*/ 2 arg4_ptr ptr, /*[5.3-1]*/ 2 arg5_ptr ptr; dcl 1 seek_info, 2 relation_type fixed bin, 2 n fixed bin, 2 search_key char (256); declare mode fixed bin; /* where: relation_type 0 = search_key 1 >= search_key 2 > search_key n is the length of the search_key search_key is the character string used to match indeies */ /* *******************************************************************************************/ /* AUTOMATIC VARIABLES FOR ALTERNATE RECORD KEYS */ /* *******************************************************************************************/ declare file_record_buffer char (1000000) based (buff_ptr); declare rs_record_buffer char (1000000) based (rs_info.record_ptr); dcl dummy_buffer char (1); dcl char1 char (1); dcl rec_len fixed bin (21); dcl save_sw bit (1); declare key_num fixed bin (35); declare (buff_ptr, alt_key_desc_ptr) ptr; declare KEY_OF_REF fixed bin static internal; declare (CODE, KEY_NUM) fixed bin (35); declare REC_LEN fixed bin (21); declare READ_KEY char (256) varying; declare 1 status_info, 2 info aligned like rs_info; declare 1 GK_INFO, 2 HDR like gk_header, 2 KEY char (256); declare 1 AK_INFO, 2 HDR like ak_header, 2 KEY char (256); declare MCODE fixed bin (35) based (alt_stack_hdr.mcode_ptr); /*[5.3-1]*/ dcl BUFF_LEN fixed bin (21) based; /*[5.3-1]*/ dcl REC_LGT fixed bin (21) based; /*[5.3-1]*/ dcl BUFF_PTR ptr; /*[4.4-1]*/ declare key_status (512) bit (1) static internal; /* ******************************* * * * open * * * *******************************/ rts (46): /* This label is for the OPEN statement with alternate record keys */ fsb_ptr = alt_stack_hdr.fsb_ptr; fsb.file_desc_ptr = alt_stack_hdr.file_desc_ptr; file_desc_1_ptr = fsb.file_desc_ptr; fsb.vfile_open_mode = alt_stack_hdr.vfile_open_mode; fsb.cobol_open_mode = alt_stack_hdr.cobol_open_mode; fsb.last_cobol_op = 1; /* open */ alt_stack_hdr.fsb_ptr -> fsb.key_of_ref = 511; /* prime key */ fsb.crp.prime_key = ""; /*[5.3-1]*/ if fsb.fsb_skel.mod1 then fsb.last_key_read = ""; if fsb.cobol_open_mode = 29 | /* input(seq) */ fsb.cobol_open_mode = 30 | /* input(ran) */ fsb.cobol_open_mode = 31 | /* input(dyn) */ fsb.cobol_open_mode = 45 | /* i-o(seq) */ fsb.cobol_open_mode = 46 | /* i-o(ran */ fsb.cobol_open_mode = 47 /* i-o(dyn) */ then do; /* position the file */ seek_info.relation_type = 0; seek_info.n = 1; /*[4.4-1]*/ unspec (char1) = "111111111"b; /*[4.4-1]*/ seek_info.search_key = char1; call iox_$control (fsb.iocb_ptr, "seek_head", addr (seek_info), MCODE); end; return; /* ******************************* * * * close * * * *******************************/ rts (47): /* This label is for the CLOSE statement with alternate record keys */ /*[4.4-1]*/ call set_up; fsb.last_cobol_op = 2; /* close */ /*[5.3-1]*/ if fsb.fsb_skel.mod1 then fsb.last_key_read = ""; return; /* ******************************* * * * start * * * *******************************/ rts (48): /* OP79(start) */ /*[4.4-1]*/ call set_up; fsb.last_cobol_op = 3; /* start */ fsb.key_of_ref = KEY_OF_REF; return; /* ******************************* * * * read next * * * *******************************/ rts (49): /* OP80(read next) */ /*[4.4-1]*/ call set_up; fsb.last_cobol_op = 4; /* read next */ return; /* ******************************* * * * read key * * * *******************************/ rts (50): /* OP(1(read key) */ /*[4.4-1]*/ call set_up; fsb.last_cobol_op = 5; /* read key */ if fsb.cobol_open_mode = 31 /* ind-dyn(i) */ | fsb.cobol_open_mode = 63 /* ind-dyn(o) */ | fsb.cobol_open_mode = 47 /* ind-dyn(io) */ then fsb.key_of_ref = KEY_OF_REF; return; /* ******************************* * * * write * * * *******************************/ rts (51): /* OP91(write) */ /*[4.4-1]*/ call set_up; unspec (char1) = "111111111"b; buff_ptr = alt_stack_hdr.file_rec_buf_ptr; rs_info_ptr = addr (status_info); alt_key_desc_ptr = addr (file_desc_1.alt_key (1)); if fsb.cobol_open_mode = 61 /* output seq */ then if char1 || substr (fsb.key, 1, fsb.keylen_sw) /* keys not sequential */ <= fsb.crp.prime_key then do; MCODE = error_table_$key_order; return; end; save_sw = "0"b; call save_NRP; if fsb.vfile_open_mode ^= 9 /* keyed sequential output */ then /*[4.4-1]*/ do; key_len_ptr = addr (vfile_key.size); key_ptr = addr (vfile_key.key); do key_num = 1 to file_desc_1.alt_key_count; /*[5.0-1]*/ call set_off_sz; /*[4.4-1]*/ call form_alt_key (buff_ptr); /*[4.4-1]*/ call iox_$seek_key (fsb.iocb_ptr, substr (vfile_key.key, 1, vfile_key.size), rec_len, MCODE); if MCODE = 0 /* duplicate exists */ then if file_desc_1.alt_key (key_num).size >= 0 then do; /* duplicate exists and not legal */ if save_sw then call restore_NRP; MCODE = error_table_$key_duplication; return; end; end; /*[4.4-1]*/ end; fsb.key = char1 || substr (fsb.key, 1, fsb.keylen_sw); fsb.keylen_sw = fsb.keylen_sw + 1; MCODE = 0; return; rts (52): /* OP87(delete) */ /*[4.4-1]*/ call set_up; /*[4.4-1]*/ call rec_status; /*[4.4-1]*/ if MCODE ^= 0 then return; /*[5.3-1]*/ if fsb.cobol_open_mode = 45 /*[5.3-1]*/ then if fsb.last_cobol_op ^= 4 /* read */ /*[5.3-1]*/ then do; error_block.status12 = "30"; /*[5.3-1]*/ error_block.status3 = "7033"; /*[5.3-1]*/ MCODE = error_table_$no_record; /*[5.3-1]*/ return; /*[5.3-1]*/ end; /*[4.4-1]*/ call init_ak_info ("delete_key"); /*[4.4-1]*/ do key_num = 1 by 1 to file_desc_1.alt_key_count; /*[4.4-1]*/ call set_off_sz; /*[4.4-1]*/ call process_key (rs_info.record_ptr); /*[4.4-1]*/ end; MCODE = 0; return; /* ******************************* * * * rewrite * * * *******************************/ rts (61): /* OP93(rewrite) */ /*[4.4-1]*/ call set_up; /*[4.4-1]*/ call rec_status; /*[4.4-1]*/ if MCODE ^= 0 then return; /*[4.4-1]*/ buff_ptr = alt_stack_hdr.file_rec_buf_ptr; /*[4.4-1]*/ alt_key_desc_ptr = addr (file_desc_1.alt_key (1)); /*[4.4-1]*/ call init_gk_info; gk_info.header.reset_pos = "1"b; string (key_status) = "0"b; /*[4.4-1]*/ do key_num = 1 by 1 to file_desc_1.alt_key_count; /*[4.4-1]*/ call set_off_sz; call keys_unequal; /*[4.4-1]*/ if sz >= 0 /*[4.4-1]*/ then if key_comp /*[4.4-1]*/ then do; /*[4.4-1]*/ call process_key (buff_ptr); /*[4.4-1]*/ if MCODE = 0 /*[4.4-1]*/ then do; MCODE = error_table_$key_duplication; /*[4.4-1]*/ return; /*[4.4-1]*/ end; /*[4.4-1]*/ end; /*[4.4-1]*/ end; /*[4.4-1]*/ call init_ak_info ("delete_key"); /*[4.4-1]*/ do key_num = 1 by 1 to file_desc_1.alt_key_count; /*[4.4-1]*/ call set_off_sz; /*[4.4-1]*/ if key_status (key_num) then call process_key (rs_info.record_ptr); /*[4.4-1]*/ end; /*[4.4-1]*/ return; /*[4.4-1]*/ declare (sz_abs, sz, off) fixed bin; /*[4.4-1]*/ declare (key_len_ptr, key_ptr, info_ptr) ptr; /*[4.4-1]*/ declare key_op char (10); /*[4.4-1]*/ declare 1 vfile_key, /*[4.4-1]*/ 2 size fixed bin, /*[4.4-1]*/ 2 key char (256); set_off_sz: proc; /*[4.4-1]*/ off = file_desc_1.alt_key.offset (key_num) + 1; /*[4.4-1]*/ sz = file_desc_1.alt_key.size (key_num); /*[4.4-1]*/ sz_abs = abs (sz); end; /*[4.4-1]*/ declare key_comp bit (1); keys_unequal: proc; /*[4.4-1]*/ if substr (rs_record_buffer, off, sz_abs) ^= substr (file_record_buffer, off, sz_abs) /*[4.4-1]*/ then do; key_comp = "1"b; key_status (key_num) = "1"b; end; /*[4.4-1]*/ else key_comp = "0"b; end; process_key: proc (loc); /* add_key, delete_key, get_key */ /*[4.4-1]*/ declare loc ptr; /*[4.4-1]*/ call form_alt_key (loc); /*[4.4-1]*/ call iox_$control (fsb.iocb_ptr, key_op, info_ptr, MCODE); end; form_alt_key: proc (rec_ptr); /*[4.4-1]*/ declare rec_ptr ptr; /*[4.4-1]*/ declare alt_key_num char (1); /*[4.4-1]*/ declare key_len fixed bin based (key_len_ptr);/*[4.4-1]*/ declare key char (256) based (key_ptr); /*[4.4-1]*/ declare record char (1000000) based (rec_ptr); /*[4.4-1]*/ key_len = sz_abs + 1; /*[4.4-1]*/ unspec (alt_key_num) = substr (unspec (key_num), 28, 9); /*[4.4-1]*/ substr (key, 1, key_len) = alt_key_num || substr (record, off, key_len); end; set_up: proc; /*[4.4-1]*/ fsb_ptr = alt_stack_hdr.fsb_ptr; /*[4.4-1]*/ if fsb.fsb_skel.mod1 then file_desc_1_ptr = fsb.file_desc_ptr; else if unspec (fsb.file_desc_ptr) = (2) "040040040040"b3 then /* pre [5.3-1] initialization */ file_desc_1_ptr = null (); else file_desc_1_ptr = fsb.file_desc_ptr; end; rec_status: proc; /*[4.4-1]*/ call init_rs_info; /*[4.4-1]*/ call iox_$control (fsb.iocb_ptr, "record_status", rs_info_ptr, MCODE); end; /* ******************************* * * * delete * * * *******************************/ rts (53): /* OP86(delete) */ /*[4.4-1]*/ call set_up; fsb.last_cobol_op = 7; return; /* ******************************* * * * make key read * * * *******************************/ rts (54): /* OP82(start) */ mode = 0; rts54: /*[4.4-1]*/ call set_up; unspec (char1) = substr (unspec (alt_stack_hdr.key_of_ref), 28, 9); call make_key (char1, mode); KEY_OF_REF = alt_stack_hdr.key_of_ref; return; /* ******************************* * * * make key write * * * *******************************/ rts (55): /* OP85(delete,rewrite) */ /*[4.4-1]*/ call set_up; unspec (char1) = "111111111"b; call save_NRP; /*[4.0-3]*/ call make_key (char1, 1); return; /* ******************************* * * * add keys * * * *******************************/ rts (56): /* OP90(write) */ /*[4.4-1]*/ call set_up; buff_ptr = alt_stack_hdr.file_rec_buf_ptr; if fsb.cobol_open_mode = 61 then fsb.crp.prime_key = substr (fsb.key, 1, fsb.keylen_sw); /*[4.4-1]*/ call init_ak_info ("add_key"); /*[4.4-1]*/ do key_num = 1 by 1 to file_desc_1.alt_key_count; /*[4.4-1]*/ call set_off_sz; /*[4.4-1]*/ call process_key (buff_ptr); /*[4.4-1]*/ end; fsb.last_cobol_op = 8; /* write */ return; /* ******************************* * * * read restore * * * *******************************/ rts (57): /* OP92(read) */ /*[4.4-1]*/ call set_up; rs_info_ptr = addr (status_info); if fsb.last_cobol_op = 6 | /* rewrite */ fsb.last_cobol_op = 7 | /* delete */ fsb.last_cobol_op = 8 /* write */ then call restore_NRP; /*[5.1-1]*/ if MCODE ^= 0 then return; call iox_$read_key (fsb.iocb_ptr, READ_KEY, REC_LEN, CODE); /*[5.1-1]*/ if CODE ^= 0 /*[5.1-1]*/ then MCODE = CODE; /*[5.1-1]*/ else call eof_test (addr (READ_KEY)); /*[5.1-1]*/ return; /* /* ******************************* * * * rewrite add keys * * * *******************************/ rts (58): /* OP88(rewrite) */ /*[4.4-1]*/ call set_up; buff_ptr = alt_stack_hdr.file_rec_buf_ptr; /*[4.4-1]*/ call rec_status; if MCODE ^= 0 then return; /*[4.4-1]*/ call init_ak_info ("add_key"); /*[4.4-1]*/ do key_num = 1 by 1 to file_desc_1.alt_key_count; /*[4.4-1]*/ call set_off_sz; /*[4.4-1]*/ if key_status (key_num) then call process_key (buff_ptr); /*[4.4-1]*/ end; fsb.last_cobol_op = 6; /* rewrite */ return; rts (59): /* OP84(read) */ mode = 1; go to rts54; /*[4.0-2]*/ rts (60): dcl rlen fixed bin (21, 0); dcl new_key char (256) varying; call iox_$control (control_iocb_ptr, order_name, iox_control_stack.control_ptr, mcode); if mcode = 0 then call iox_$read_key (control_iocb_ptr, new_key, rlen, mcode); if mcode ^= 0 then do; if mcode = error_table_$no_record then do; error_block.status12 = "23"; error_block.status3 = "6723"; /*[4.0-1] */ icode = 4; end; else do; error_block.status12 = "30"; error_block.status3 = "6732"; end; return; end; if substr (struc.key, 1, 1) ^= substr (new_key, 1, 1) then do; mcode = error_table_$no_record; error_block.status12 = "23"; error_block.status3 = "6723"; end; return; rts (63): /* OP65(read) */ /*[5.3-1]*/ call set_up; /*[5.3-1]*/ BUFF_PTR = alt_stack_hdr.arg2_ptr -> temp_ptr; /*[5.3-1]*/ call iox_$read_record /*[5.3-1]*/ (alt_stack_hdr.fsb_ptr -> temp_ptr, /* iocb ptr */ /*[5.3-1]*/ BUFF_PTR, /* buffer ptr */ /*[5.3-1]*/ alt_stack_hdr.arg3_ptr -> BUFF_LEN, /* buffer length */ /*[5.3-1]*/ alt_stack_hdr.arg4_ptr -> REC_LGT, /* record length */ /*[5.3-1]*/ alt_stack_hdr.arg5_ptr -> MCODE /* error code */ /*[5.3-1]*/); /*[5.3-1]*/ if ^fsb.fsb_skel.mod1 | alt_stack_hdr.arg5_ptr -> MCODE ^= 0 then return; /*[5.3-1]*/ if fsb.cobol_open_mode = 45 /*[5.3-1]*/ then fsb.last_key_read /*[5.3-1]*/ = substr (BUFF_PTR -> file_record_buffer, /*[5.3-1]*/ file_desc_1.prime_key.offset + 1, /*[5.3-1]*/ file_desc_1.prime_key.size /*[5.3-1]*/); /*[5.3-1]*/ return; rts (64): /* OP59(rewrite) */ /*[5.3-1]*/ call set_up; /*[5.3-1]*/ if fsb.cobol_open_mode = 45 /* i/o,ind,seq */ /*[5.3-1]*/ then do; if fsb.last_cobol_op ^= 4 /* must be read */ /*[5.3-1]*/ then do; error_block.status12 = "30"; /*[5.3-1]*/ error_block.status3 = "5033"; /*[5.3-1]*/ return; /*[5.3-1]*/ end; /*[5.3-1]*/ BUFF_PTR = alt_stack_hdr.arg2_ptr -> temp_ptr; /*[5.3-1]*/ if fsb.fsb_skel.mod1 then /*[5.3-1]*/ if /*[5.3-1]*/ fsb.last_key_read /*[5.3-1]*/ ^= substr /*[5.3-1]*/ (BUFF_PTR -> file_record_buffer, /*[5.3-1]*/ file_desc_1.prime_key.offset + 1, /*[5.3-1]*/ file_desc_1.prime_key.size /*[5.3-1]*/) /*[5.3-1]*/ then do; error_block.status12 = "30"; /*[5.3-1]*/ error_block.status3 = "5024"; /*[5.3-1]*/ alt_stack_hdr.arg5_ptr -> MCODE = error_table_$no_record; /*[5.3-1]*/ return; /*[5.3-1]*/ end; /*[5.3-1]*/ end; /*[5.3-1]*/ call iox_$rewrite_record /*[5.3-1]*/ (alt_stack_hdr.fsb_ptr -> temp_ptr, /* iocb ptr */ /*[5.3-1]*/ BUFF_PTR, /* buffer ptr */ /*[5.3-1]*/ alt_stack_hdr.arg3_ptr -> REC_LGT, /* record length */ /*[5.3-1]*/ alt_stack_hdr.arg4_ptr -> MCODE /* error code */ /*[5.3-1]*/); /*[5.3-1]*/ return; /* *******************************************************************************************/ /* ALTERNATE RECORD KEY PACKAGE INTERNAL SUBROUTINES */ /* *******************************************************************************************/ /*[5.1-1]*/ dcl res bit (1); make_key: proc (char1, mode); dcl p ptr, mode fixed bin, char1 char (1); dcl 1 SEEK_KEY based (p), 2 rel fixed bin, 2 n fixed bin, 2 seek_key char (256); declare 1 SK based (p), 2 n fixed bin, 2 seek_key char (256); p = alt_stack_hdr.iocb_ptr; if mode = 0 then do; substr (SEEK_KEY.seek_key, 1, SEEK_KEY.n + 1) = char1 || substr (SEEK_KEY.seek_key, 1, SEEK_KEY.n); SEEK_KEY.n = SEEK_KEY.n + 1; end; else do; substr (SK.seek_key, 1, SK.n + 1) = char1 || substr (SK.seek_key, 1, SK.n); SK.n = SK.n + 1; end; end make_key; /*[4.4-1]*/ declare read_key_key char (256) varying; save_NRP: proc; if (fsb.cobol_open_mode = 45 | /* i-o(seq) */ fsb.cobol_open_mode = 46 | /* i-o(ran) */ fsb.cobol_open_mode = 47 /* i-o(dyn ) */) & /*[5.1-1]*/ (fsb.last_cobol_op = 1 | /* open */ fsb.last_cobol_op = 3 | /* start */ fsb.last_cobol_op = 4 | /* read next */ fsb.last_cobol_op = 5 /* read key */ /*[5.1-1]*/) then do; /* save the keys for the next record */ call iox_$read_key (fsb.iocb_ptr, read_key_key, rec_len, MCODE); save_sw = "1"b; if MCODE = error_table_$end_of_info then fsb.crp.prime_key = ""; else if MCODE = error_table_$no_record then fsb.crp.prime_key = ""; else do; /*[5.1-1]*/ call eof_test (addr (read_key_key)); /*[5.1-1]*/ if MCODE ^= 0 /*[5.1-1]*/ then do; fsb.crp.prime_key = ""; /*[5.1-1]*/ return; /*[5.1-1]*/ end; /*[4.4-1]*/ call rec_status; /*[4.4-1]*/ if MCODE ^= 0 then return; fsb.crp.prime_key = substr (rs_record_buffer, (file_desc_1.prime_key.offset + 1), file_desc_1.prime_key.size); /*[4.4-1]*/ key_num = fsb.key_of_ref; call set_off_sz; /*[4.4-1]*/ if key_num ^= 511 then do; fsb.crp.alt_key = substr (rs_record_buffer, /*[4.4-1]*/ off, /*[4.4-1]*/ sz_abs); end; fsb.crp.descriptor = rs_info.descriptor; end; end; end save_NRP; restore_NRP: proc; declare key_len fixed bin, key_ptr ptr; /*[4.0-3]*/ declare key_string char (512) varying based (key_ptr); if fsb.crp.prime_key = "" then do; MCODE = error_table_$end_of_info; return; end; if fsb.key_of_ref = 511 then do; key_len = length (fsb.prime_key) + 1; key_ptr = addr (fsb.prime_key); end; else do; key_len = length (fsb.alt_key) + 1; key_ptr = addr (fsb.alt_key); end; unspec (char1) = substr (unspec (fsb.key_of_ref), 28, 9); /*[5.1-1]*/ if fsb.key_of_ref = 511 /* prime key */ /*[5.1-1]*/ | /*[5.1-1]*/ file_desc_1.alt_key.size (fsb.key_of_ref) >= 0 /* dupl illeg */ /*[5.1-1]*/ then res = "1"b; /*[5.1-1]*/ else res = "0"b; /*[5.1-1]*/ if res /*[5.1-1]*/ then do; call init_gk_info; gk_info.header.descrip = fsb.crp.descriptor; gk_info.header.key_len = key_len + 1; gk_info.key = char1 || substr (key_string, 1, key_len); gk_info.flags.position_specification.head_size = gk_info.header.key_len; call iox_$control (fsb.iocb_ptr, "get_key", gk_info_ptr, MCODE); if MCODE = 0 then return; end; seek_info.relation_type = 1; /* >= */ seek_info.n = key_len + 1; seek_info.search_key = char1 || substr (key_string, 1, key_len); /*[5.1-1]*/ call iox_sh; if MCODE ^= 0 then do; MCODE = error_table_$end_of_info; return; end; if res then return; /*[4.4-1]*/ call rec_status; /*[5.1-1]*/ if MCODE ^= 0 then return; /*[5.1-1]*/ call key_compare; /*[5.1-1]*/ if res then return; i = 1; do while ("1"b); /*[5.1-1]*/ call iox_rr; if MCODE = error_table_$long_record then MCODE = 0; else if MCODE ^= 0 then return; /*[4.4-1]*/ call rec_status; if MCODE ^= 0 then return; /*[5.1-1]*/ call key_compare; /*[5.1-1]*/ if res then do; /*[5.1-1]*/ call iox_sh; if MCODE ^= 0 then return; do j = 1 to i - 1 by 1; /*[5.1-1]*/ call iox_rr; if MCODE = error_table_$long_record then MCODE = 0; else if MCODE ^= 0 then return; end; return; end; i = i + 1; end; end restore_NRP; init_rs_info: proc; /* record_status */ /*[4.4-1]*/ rs_info_ptr = addr (status_info); rs_info.version = rs_info_version_2; rs_info.lock_sw = "0"b; rs_info.unlock_sw = "0"b; rs_info.create_sw = "0"b; rs_info.locate_sw = "0"b; rs_info.inc_ref_count = "0"b; rs_info.dec_ref_count = "0"b; rs_info.locate_pos_sw = "0"b; rs_info.mbz1 = "0"b; rs_info.mbz2 = 0; rs_info.descriptor = 0; end init_rs_info; init_gk_info: proc; /*[4.4-1]*/ gk_info_ptr = addr (GK_INFO); /*[4.4-1]*/ key_len_ptr = addr (gk_info.header.key_len); /*[4.4-1]*/ key_ptr = addr (gk_info.key); /*[4.4-1]*/ key_op = "get_key"; /*[4.4-1]*/ info_ptr = gk_info_ptr; gk_info.header.flags.input_key = "1"b; gk_info.header.flags.input_desc = "1"b; gk_info.header.version = gk_info_version_0; gk_info.header.flags.position_specification.rel_type = 0; /* = */ gk_info.header.flags.reset_pos = "0"b; gk_info.header.pad = "0"b; end; init_ak_info: proc (op); /* add_key, delete_key */ /*[4.4-1]*/ declare op char (*); /*[4.4-1]*/ ak_info_ptr = addr (AK_INFO); /*[4.4-1]*/ key_len_ptr = addr (ak_info.header.key_len); /*[4.4-1]*/ key_ptr = addr (ak_info.key); /*[4.4-1]*/ key_op = op; /*[4.4-1]*/ info_ptr = ak_info_ptr; /*[4.4-1]*/ ak_info.header.input_key = "1"b; /*[4.4-1]*/ ak_info.header.descrip = 0b; /*[4.4-1]*/ ak_info.header.mbz = "0"b; end; key_compare: proc; /*[5.1-1]*/ if substr /*[5.1-1]*/ (rs_record_buffer, /*[5.1-1]*/ file_desc_1.alt_key.offset (fsb.key_of_ref) + 1, /*[5.1-1]*/ abs (file_desc_1.alt_key.size (fsb.key_of_ref)) /*[5.1-1]*/) /*[5.1-1]*/ ^= fsb.crp.alt_key /*[5.1-1]*/ | /*[5.1-1]*/ substr /*[5.1-1]*/ (rs_record_buffer, /*[5.1-1]*/ file_desc_1.prime_key.offset + 1, /*[5.1-1]*/ file_desc_1.prime_key.size /*[5.1-1]*/) /*[5.1-1]*/ = fsb.crp.prime_key /*[5.1-1]*/ then res = "1"b; /*[5.1-1]*/ else res = "0"b; end; iox_sh: proc; /*[5.1-1]*/ call iox_$control (fsb.iocb_ptr, "seek_head", addr (seek_info), MCODE); end; iox_rr: proc; /*[5.1-1]*/ call iox_$read_record (fsb.iocb_ptr, addr (dummy_buffer), 1, rec_len, MCODE); end; eof_test: proc (key_loc); /*[5.1-1]*/ dcl key_loc ptr; /*[5.1-1]*/ dcl key_str char (256) varying based (key_loc); /*[5.1-1]*/ KEY_NUM = 0; /*[5.1-1]*/ substr (unspec (KEY_NUM), 28, 9) = unspec (substr (key_str, 1, 1)); /*[5.1-1]*/ if KEY_NUM ^= fsb.key_of_ref then MCODE = error_table_$end_of_info; else MCODE = 0; end; /* Please insert the next run time package before this line. */ /* EXTERNAL_NAMES */ dcl iox_$user_input ptr ext; dcl cobol_error_ entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (*), ptr); dcl cobol_error_$use entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (*), ptr); dcl cobol_control_$cobol_rts_control_ entry (ptr); dcl sort_$initiate entry (char (*), ptr, ptr, char (*), float bin (27), fixed bin (35)); dcl sort_$noexit entry ext; dcl error_table_$end_of_info fixed bin (35) ext; dcl error_table_$key_duplication fixed bin (35) ext; dcl error_table_$long_record fixed bin (35) ext; dcl error_table_$short_record fixed bin (35) ext; dcl error_table_$no_record fixed bin (35) external; dcl error_table_$key_order fixed bin (35) external; dcl error_table_$incompatible_attach fixed bin (35) external; dcl error_table_$noentry fixed bin (35) external; dcl error_table_$file_busy fixed bin (35) external; dcl error_table_$no_operation fixed bin (35) external; dcl error_table_$bad_file fixed bin (35) external; dcl sort_$return entry (ptr, fixed bin (21), fixed bin (35)); dcl sort_$terminate entry (fixed bin (35)); dcl sort_$commence entry (fixed bin (35)); dcl cu_$cl entry; dcl cobol_stop_run_ entry (ptr, fixed bin, fixed bin, fixed bin), signal_ entry (char (*), ptr, ptr); declare iox_$attach_ptr entry (ptr, char (*), ptr, fixed bin (35)); declare iox_$control entry (ptr, char (*), ptr, fixed bin (35)); declare iox_$find_iocb entry (char (*), ptr, fixed bin (35)); declare iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); declare iox_$read_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)); declare iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); declare iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); declare iox_$seek_key entry (ptr, char (256) varying, fixed bin (21), fixed bin (35)); dcl cobol_control_$cancel entry (char (*), fixed bin, fixed bin, fixed bin); dcl clock_ entry returns (fixed bin (71)), date_time_ entry (fixed bin (71), char (*)), decode_clock_value_ entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3) aligned); dcl cobol_su_$tally entry (ptr, fixed bin), cobol_su_$replace entry (ptr); dcl hcs_$terminate_name entry (char (*), fixed bin (35)); dcl get_pdir_ entry returns (char (168)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35)); dcl cobol_mcs_$receive entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35)), cobol_mcs_$receive_wait entry (ptr, fixed bin, ptr, fixed bin, fixed bin (35)); dcl cmcs_error_table_$no_message fixed bin (35) ext; dcl cobol_mcs_$accept entry (ptr, fixed bin (35)); dcl cobol_mcs_$purge entry (ptr, fixed bin (35)); dcl cobol_mcs_$send entry (ptr, ptr, char (4), char (1), bit (36), fixed bin (35)); dcl cobol_mcs_$enable_input_terminal entry (ptr, char (*), fixed bin (35)), cobol_mcs_$enable_input_queue entry (ptr, char (*), fixed bin (35)), cobol_mcs_$enable_output entry (ptr, char (*), fixed bin (35)); dcl cobol_mcs_$disable_input_terminal entry (ptr, char (*), fixed bin (35)), cobol_mcs_$disable_input_queue entry (ptr, char (*), fixed bin (35)), cobol_mcs_$disable_output entry (ptr, char (*), fixed bin (35)); /* BUILTIN FUNCTIONS */ dcl (substr, mod, abs, addr, addrel, length, string, unspec, null, index) builtin; %include cobol_stack_frame; %include cobol_control; %include cobol_fixed_static; %include cobol_fsb_type_1; %include cobol_fsbskel; %include cobol_file_desc_1; %include rs_info; %include ak_info; end cobol_rts_;  cobol_rts_handler_.pl1 05/24/89 1048.6rew 05/24/89 0836.8 66132 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_rts_handler_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 8/18/76 by Bob Chang to change ext data name cobol_sort_ into cobol_SM_. */ /* Modified on 6/30/76 by Bob Chang to implement cleanup condition for sort. */ /*{*/ /* format: style3 */ cobol_rts_handler_: proc (mcp, cond_name, wc_cobol_ptr, info_ptr, continue_sw); dcl sort_$terminate entry (fixed bin (35)), mcode fixed bin (35); /* This procedure is the fixedoverflow handler for object programs compiled by the Multics Cobol compiler. This procedure looks at a flag in the static data portion of the linkage section of the Cobol program in which the fixedoverflow was detected, to determine how to respond to the fixedoverflow. 1. If the flag is zero, then this handler sets its parameter "continue_sw" ON, and returns. Setting this parameter ON results in the signalling of the next most recently established handler for fixedoverflow, after this procedure exits. ( The effect of this type of return is that the execution of this procedure has no effect.) 2. If the flag is non-zero, then the machine state saved at the time the fixedoverflow was detected are modified slightly, (see details below) and this procedure returns with parameter "continue_sw" set to "0"b. The effect of this type of return is that control returns to the Cobol program in which the fixedoverflow condition was detected. */ /* DECLARATION OF THE PARAMETERS */ /* dcl mcp ptr; */ /* THIS PARAMETER IS DECLARED BELOW IN AN INCLUDE FILE */ dcl cond_name char (32); dcl cobol_SM_$ec fixed bin (35) ext, cobol_SM_$stat_ptr ptr ext, cobol_SM_$error_ptr ptr ext, cobol_SM_$RETbl fixed bin (35) ext; dcl wc_cobol_ptr ptr; dcl info_ptr ptr; dcl continue_sw bit (1); dcl cobol_error_ entry (fixed bin, fixed bin (35), fixed bin, fixed bin, char (65) varying, ptr) ext; /* DESCRIPTION OF THE PARAMETERS */ /* NOTE: The following information was obtained from the MPM, section 6.2. */ /* PARAMETER DESCRIPTION mcp Pointer to information describing the state of the processor at the time the fixedoverflow was detected. (input) cond_name Not used by this procedure. wc_cobol_ptr Not used by this procedure. info_ptr Not used by this procedure. continue_sw A binary switch indicating the action to be taken when the handler returns to the condition mechanism. Normally, when a handler returns, control returns to the point at whcih the condiion was raised, and that operation is re-tried. This is the case when "continue_sw" is set to "0"b. However, if we do want to return to the Cobol program in which fixedoverflow was detected, we want to return to some point OTHER THAN THE POINT WHERE THE FIXED OVERFLOW WAS DETECTED. This is done by modifying two entries in the saved machine conditions, setting "continue_sw" to "0"b, and then returning. The two entries in the saved machine conditions that must be modified are: 1. The value of the IC at which the fixedoverflow was detected. This value is incremented (or decremented) so that when this procedure returns, return is to the desired point, rather than the point at which the fixedoverflow was detected. 2. The multi-instruction format INDICATOR bit in the saved machine conditions is set to "0"b. If control is not to return to the Cobol program, then the continue_sw" is set to "1"b, and this procedure returns. Under these conditions, the condition mechanism behaves as though this handler, cobol_rts_handler_, had not been established and invokes the next most recently established handler for the fixedoverflow conditon. */ /*}*/ dcl vprog_id char (65) varying; /**************************************************/ /* START OF EXECUTION */ /* EXTERNAL PROCEDURE */ /* cobol_rts_handler_ */ /**************************************************/ /* THE CODE FOR HANDLING fixedoverflow IS NOW OBSOLETE */ /* if cond_name = "fixedoverflow" then do; /* /* Base the stack frame template on the stack frame of the procedure in which the fixedoverflow was /* detected. */ /* stack_frame_ptr = mc.prs(6); /* /* Get the pointer to the linkage section of the procedure in which the fixedoverflow was detected. */ /* stat_ptr = addrel(stack_frame.link_ptr,8); /* if stat.fo_flag = 0 /* then continue_sw = "1"b; /* Return to the most recently previously established /* fixedoverflow handler */ /* else do; /* Increment the IC value saved in the machine conditions, and return /* to the Cobol object program in which the overflow was detected. */ /* continue_sw = "0"b; /* /* Increment the IC by the value contained in the Cobol program's static data area. */ /* scup = addr(mc.scu(0)); /* scu.ilc = fixed (unspec(scu.ilc) + stat.fo_disp,18); /* /* Turn off the multi-instruction format INDICATOR register bit in the /* saved machine conditions for the objcet program in which fixedoverflow was detected. */ /* scu.ir.mif = "0"b; /* end; /* Increment the IC value saved in the machine conditions, and return /* to the Cobol object program in whcih the overflow was detected. */ /* end; /* else */ if substr (cond_name, 1, 10) ^= "SORTM_STOP" then do; call sort_$terminate (mcode); return; end; else do; /* temporary. */ cobol_SM_$RETbl = 0; /* tell the SORT package rap up sorting*/ if cobol_SM_$ec = 8 | cobol_SM_$ec = 9 | cobol_SM_$ec = 11 then return; else do; stat_ptr = cobol_SM_$stat_ptr;/* set by appropriate cobol SORT statement. */ vprog_id = prog_id; call cobol_error_ (50, 0, line_no (1), 0, vprog_id, cobol_SM_$error_ptr); return; end; end; return; /* shouldn't have gotten here anyhow */ /**************************************************/ /* INCLUDE FILES USED IN THIS PROCEDURE */ /**************************************************/ /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ /* %include mc; OBSOLETE */ dcl mcp ptr; %include cobol_fixed_static; /* %include cobol_stack_frame; OBSOLETE */ /**************************************************/ /* END OF EXTERNAL PROCEDURE */ /* cobol_rts_handler_ */ /**************************************************/ end cobol_rts_handler_;  cobol_set_pdir.pl1 05/24/89 1048.6rew 05/24/89 0836.8 8946 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_set_pdir.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* format: style3 */ cobol_set_pdir: proc (N); dcl M char (168); dcl get_pdir_ entry returns (char (168)); dcl N char (256) var; M = get_pdir_ (); N = substr (M, 1, (index (M, " ") - 1)); return; end;  cobol_source_formatter_.pl1 05/24/89 1048.6rew 05/24/89 0837.3 131355 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_source_formatter_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 07/20/81 by FCH, reformatted to improve readability, phx10605(BUG495) */ /* Modified on 03/06/81 by FCH, [4.4-2], last line not processed unless it ends in c.r. char, BUG469(TR9264) */ /* Modified on 09/22/80 by FCH, [4.4-1], tabs not handled properly (BUG444) */ /* Modified since Version 4.4 */ /* format: style3 */ cobol_source_formatter_: proc (inp, outp, bc, ctype, mtype); dcl inp ptr; dcl outp ptr; dcl bc fixed bin (24); dcl ctype fixed bin; /* -1=lower_case; +1=upper_case */ dcl mtype fixed bin; /* 0=ignore leading blanks; 1=take leading blanks into account within areas */ dcl shift bit (1); dcl (identsw, datasw, procsw) bit (1); dcl contsw bit (1); dcl periodsw bit (1); dcl last_periodsw bit (1); dcl char_count fixed bin (35); dcl code fixed bin (35); dcl source_length fixed bin; dcl inoff fixed bin; dcl outoff fixed bin; dcl cct fixed bin; dcl nl char (1) static options (constant) init (" "); dcl tab char (1) static options (constant) init (" "); dcl blank char (1) static options (constant) init (" "); dcl spaces char (256) static options (constant) init (""); dcl period char (1) static options (constant) init ("."); dcl quote char (1) static options (constant) init (""""); dcl chars char (256) based; dcl char_array (300) char (1) based; dcl (ini, outi, nli, tabj, quotei, quotej) fixed bin; dcl (blanki, periodi) fixed bin; dcl (i, j, len, n) fixed bin; dcl first_quote fixed bin; dcl tline char (300); dcl line char (300) varying; dcl spec_name (20) char (16) varying static init ("01", "77", "1", "fd", "sd", "cd", "rd", "program-id", "author", "installation", "date-written", "date-compiled", "security", "source-computer", "object-computer", "special-names", "file-control", "i-o-control", "declaratives", "end"); dcl (addr, index, substr, length, divide) builtin; /*************************************/ start: shift = "1"b; go to join; /*************************************/ no_shift: entry (inp, outp, bc, ctype); shift = "0"b; /*************************************/ join: char_count = 0; identsw, datasw, procsw = "0"b; contsw = "0"b; last_periodsw = "1"b; nli = index (inp -> chars, nl); /*[4.4-2]*/ cct = divide (bc, 9, 31, 0); do while ("1"b); /*[4.4-2]*/ if nli <= 0 then nli = cct + 1; if substr (inp -> chars, 1, 1) = "*" | substr (inp -> chars, 1, 1) = "/" | substr (inp -> chars, 1, 7) = " *" | substr (inp -> chars, 1, 7) = " /" then do; if substr (inp -> chars, 1, 1) = blank then inoff = 7; else inoff = 1; tline = substr (inp -> chars, 1, nli); substr (outp -> chars, 1, 6) = ""; outoff = 7; do i = nli - 1 to inoff by -1 while (substr (tline, i, 1) = blank); end; outi = i + 1; substr (tline, outi, 1) = nl; go to skip_shift; end; convert_tabs_and_case: tline = ""; /* convert tabs and case if necessary */ ini, outi = 1; do while (ini < nli); quotej = index (substr (inp -> chars, ini, nli - ini), quote); if quotej = 0 then quotej = nli - ini + 1; quotei = ini + quotej - 1; first_quote = quotej; do while (ini < quotei); tabj = index (substr (inp -> chars, ini, quotei - ini), tab); if tabj = 0 then do; tabj = quotei - ini + 1; n = 0; end; else do; n = 10 - mod (outi + tabj - 1, 10); if n = 0 then n = 10; end; if ctype = 0 then substr (tline, outi, tabj - 1) = substr (inp -> chars, ini, tabj - 1); else do; if ctype > 0 then line = upper_case (substr (inp -> chars, ini, tabj - 1)); else line = lower_case (substr (inp -> chars, ini, tabj - 1)); substr (tline, outi, tabj - 1) = line; end; ini = ini + tabj; outi = outi + tabj + n - 1; end; if quotei < nli then do; quotej = index (substr (inp -> chars, quotei + 1, nli - quotei), quote); if quotej = 0 then do; /* a continued nonnumeric literal */ quotej = nli - ini + 1; contsw = "1"b; end; else quotej = quotej + 1; /* include both quotes */ substr (tline, outi, quotej) = substr (inp -> chars, quotei, quotej); ini = quotei + quotej; outi = outi + quotej; end; end; check_empty_line: if outi = 1 | tline = "" then do; /* an empty line */ outi = 1; outoff = 1; inoff = 1; substr (tline, 1, 1) = nl; go to skip_shift; end; if ^shift then do; substr (tline, outi, 1) = nl; outoff = 1; inoff = 1; go to skip_shift; end; strip_trailing_blanks: substr (outp -> chars, 1, 256) = ""; /* strip trailing blanks and convert to lower case */ periodsw = last_periodsw; if ^contsw then do; do i = outi - 1 to 1 by -1 while (substr (tline, i, 1) = blank); end; if substr (tline, i, 1) = period then last_periodsw = "1"b; else last_periodsw = "0"b; outi = i + 1; end; else do; contsw = "0"b; last_periodsw = "0"b; end; substr (tline, outi, 1) = nl; line = lower_case (substr (tline, 1, outi)); explicit_check: if substr (line, 1, 2) = "a*" then do; /* check for explicit area specification */ substr (line, 1, 2) = ""; call division_check; outoff = 8; do inoff = 3 to outi while (substr (line, inoff, 1) = blank); end; if substr (line, inoff, 2) = "1 " | substr (line, inoff, 2) = "1" || nl then do; if inoff = 3 | inoff > 6 | mtype = 0 then outoff = 9; else inoff = 3; end; else if inoff < 7 then inoff = 3; /* maintain A area indentation */ end; else if substr (line, 1, 1) = "-" | substr (line, 1, 7) = " -" then do; if substr (line, 1, 1) = "-" then inoff = 2; else inoff = 8; do inoff = inoff to outi while (substr (line, inoff, 1) = blank); end; substr (outp -> chars, 7, 1) = "-"; outoff = 12; end; else if substr (line, 1, 2) = "d*" then do; substr (outp -> chars, 7, 1) = "d"; inoff = 3; substr (line, 1, 2) = ""; go to implicit_check; end; else if substr (line, 1, 3) = "da*" then do; substr (outp -> chars, 7, 1) = "d"; outoff = 8; do inoff = 4 to outi while (substr (line, inoff, 1) = blank); end; if substr (line, inoff, 2) = "1 " | substr (line, inoff, 2) = "1" || nl then do; if inoff = 4 | inoff > 7 | mtype = 0 then outoff = 9; else inoff = 4; end; else if inoff < 8 then inoff = 4; end; else do; /* no explicit specification - must figure it out */ inoff = 1; implicit_check: outoff = 0; /* until we know */ if ^identsw then do; /* check for section names and section headers */ section_check: n = index (line, " section"); if n > 0 & n < first_quote then if substr (line, n + 8, 1) = period | substr (line, n + 8, 1) = blank | substr (line, n + 8, 1) = nl then outoff = 8; end; if outoff = 0 then call division_check; /* check for division headers */ if outoff = 0 & procsw then do; /* check for user-defined paragraph names */ paragraph_check: /*[4.4-1]*/ do i = inoff to outi while (substr (line, i, 1) = blank); end; /* position to first non-blank */ blanki = index (substr (line, i, nli - i), blank); /*[4.4-1]*/ if blanki = 0 then blanki = outi; else blanki = blanki + i - 1; /* set relative to beginning of line */ periodi = index (line, period); if periodi > 1 then if substr (line, periodi + 1, 1) = nl | substr (line, periodi + 1, 1) = blank then do; if periodi > blanki then do; /* ignore blanks immediately preceding period */ do j = periodi - 1 to blanki by -1 while (substr (line, j, 1) = blank); end; periodi = j + 1; end; else j = periodi - 1; j = j - i + 1; if periodi <= blanki & periodsw then if (substr (line, i, j) ^= "exit") & (substr (line, i, j) ^= "suppress") then outoff = 8; /* paragraph name */ end; end; else if outoff = 0 & ^procsw & periodsw then do; /* check for level indicators */ level_number_check: if mtype = 0 then do i = inoff to nli while (substr (line, i, 1) = blank); end; else i = inoff; /* don't adjust B area level numbers already indented */ blanki = index (substr (line, i, nli - i), blank); if blanki = 2 then do; if substr (line, i, 1) >= "2" & substr (line, i, 1) <= "9" then outoff = 8 + fixed (substr (line, i, 1)); end; else if blanki = 3 & substr (line, i + 1, 1) ^= "d" then do; /* FD, CD, RD, or SD */ if substr (line, i, 1) >= "0" & substr (line, i, 1) <= "8" then if substr (line, i + 1, 1) >= "0" & substr (line, i + 1, 1) <= "9" then outoff = 7 + fixed (substr (line, i, 2)); if outoff = 8 | outoff = 84 then outoff = 0; /* catch 01 and 77 as reserved words */ else if outoff = 7 | outoff > 56 then outoff = 12; /* illegal and 66 and 88 */ end; end; reserved_word_check: if procsw then i = 20; /* include "end cobol" only */ else if periodsw then i = 1; /* include level numbers */ else i = 4; do i = i to 20 while (outoff = 0); /* check for other Area A reserved words */ n = index (line, spec_name (i)); if n > 0 then if n = 1 | substr (line, 1, n - 1) = substr (spaces, 1, n - 1) then if substr (line, n + length (spec_name (i)), 1) = blank | (substr (line, n + length (spec_name (i)), 1) = period & i > 3) | substr (line, n + length (spec_name (i)), 1) = nl then do; if i = 3 then do; /* "1" */ outoff = 9; do i = inoff to outi while (substr (line, i, 1) = blank); end; if i < inoff + 4 & i ^= inoff then inoff = inoff + 1; else inoff = i; end; else if i = 20 /*"end" */ then if procsw then outoff = 8; /* end cobol */ else outoff = 12; /* end key */ else outoff = 8; end; end; if outoff = 0 /* nothing special - shift to Area B */ then if procsw & ^periodsw & mtype = 0 then outoff = 16; else outoff = 12; else if outoff = 8 then do; /* get rid of leading blanks */ do i = inoff to outi while (substr (line, i, 1) = blank); end; if i ^< inoff + 4 then inoff = i; end; end; /* eliminate existing margins unless -lm specified */ if mtype = 0 then do inoff = inoff to outi while (substr (line, inoff, 1) = blank); end; skip_shift: /* output this line and look at next */ source_length = outi - inoff + 1; substr (outp -> chars, outoff, source_length) = substr (tline, inoff, source_length); inp = addr (inp -> char_array (nli + 1)); char_count = char_count + source_length + outoff - 1; outp = addr (outp -> char_array (source_length + outoff)); /*[4.4-2]*/ cct = cct - nli; /*[4.4-2]*/ if cct <= 0 /*[4.4-2]*/ then do; bc = 9 * char_count; /*[4.4-2]*/ return; /*[4.4-2]*/ end; nli = index (inp -> chars, nl); end; /*************************************/ division_check: proc; start_division_check: n = index (line, " division"); if n > 0 & n < first_quote then if substr (line, n + 9, 1) = period | substr (line, n + 9, 1) = blank | substr (line, n + 9, 1) = nl then do; if identsw then do; n = index (line, "environment "); if n = 0 then n = index (line, "data "); if n = 0 then n = index (line, "procedure "); if n > 0 then if n = 1 | substr (line, 1, n - 1) = substr (spaces, 1, n - 1) then do; identsw = "0"b; outoff = 8; end; end; else do; outoff = 8; if index (line, "identification") > 0 then identsw = "1"b; end; if index (line, "procedure") > 0 then do; procsw = "1"b; identsw, datasw = "0"b; /* just for consistency in weird cases */ end; else if index (line, "data") > 0 then do; datasw = "1"b; identsw, procsw = "0"b; end; end; end division_check; /*************************************/ lower_case: proc (str) returns (char (300) varying); dcl str char (*); dcl lc_alphabet char (128) static options (constant) init ("  !""#$%&'()*+,-./0123456789:;<=>?@abcdefghijklmnopqrstuvwxyz[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"); dcl translate builtin; return (translate (str, lc_alphabet)); end lower_case; upper_case: proc (str) returns (char (300) varying); dcl str char (*); dcl lc_alphabet char (128) static options (constant) init ("  !""#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~"); dcl translate builtin; return (translate (str, lc_alphabet)); end upper_case; end cobol_source_formatter_;  cobol_su_.pl1 05/24/89 1048.6rew 05/24/89 0836.8 58473 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_su_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 03/31/77 by Bob Chang to fix the bug for tally count. */ /* Modified 03/27/76 by ORN to avoid initializing the tally parameter (tout) to zero. */ /* Modified since Version 2.0 */ /* format: style3 */ cobol_su_: proc; dcl i fixed bin; dcl k fixed bin; dcl newk fixed bin; dcl str char (100000) based; /*************************************/ tally: entry (tptr); dcl tptr ptr; dcl tout_ptr ptr; dcl tout (512) fixed bin based (tout_ptr); dcl 1 t based (tptr), 2 ssp ptr, 2 slen fixed bin, 2 n fixed bin, 2 tally (0 refer (t.n)), 3 ccode fixed bin, /* 0=CHARACTERS, 1=LEADING, 2=ALL */ 3 lcode fixed bin, /* 0=unspecified(enabled), 1=BEFORE, 2=AFTER, 3=disabled */ 3 lpos fixed bin, /* char pos to enable after's or disable before's */ 3 llen fixed bin, /* length of BEFORE/AFTER string */ 3 lsp ptr, /* ptr to BEFORE/AFTER string (if lcode ^= 0) */ 3 csp ptr, /* ptr to LEADING/ALL string (if ccode > 0) */ 3 clen fixed bin, /* length of LEADING/ALL string */ 3 tally_ind fixed bin; /* tally count */ start_tally: tout_ptr = addrel (tptr, t.n * 10 + 4); do i = 1 to t.n; if t.lcode (i) ^= 0 then do; k = index (substr (t.ssp -> str, 1, t.slen), substr (t.lsp (i) -> str, 1, t.llen (i))); if k = 0 then t.lpos (i) = t.slen + 1; else do; if t.lcode (i) = 2 then t.lpos (i) = k + t.llen (i); /* AFTER */ else do; /* BEFORE */ if t.ccode (i) ^= 0 then k = k - t.clen (i) + 1; t.lpos (i) = k; end; end; end; end; do k = 1 to t.slen; newk = k; do i = 1 to t.n; if t.lcode (i) = 2 then if k >= t.lpos (i) then t.lcode (i) = 0; /* enable AFTER tally */ else ; else if t.lcode (i) = 1 then if k >= t.lpos (i) then t.lcode (i) = 3; /* disable BEFORE tally */ if t.lcode (i) < 2 then do; /* if this tally is enabled */ if t.ccode (i) = 0 then do; /* CHARACTERS */ tout (t.tally_ind (i)) = tout (t.tally_ind (i)) + 1; do i = i + 1 to t.n;/* scrap any eligible LEADING's and discontinue search */ if t.lcode (i) < 2 then if t.ccode (i) = 1 then t.lcode (i) = 3; end; end; else do; if k + t.clen (i) - 1 ^> t.slen then do; /* enough string left to compare */ if substr (t.ssp -> str, k, t.clen (i)) = substr (t.csp (i) -> str, 1, t.clen (i)) then do; tout (t.tally_ind (i)) = tout (t.tally_ind (i)) + 1; newk = k + t.clen (i) - 1; do i = i + 1 to t.n; if t.lcode (i) < 2 then if t.ccode (i) = 1 then t.lcode (i) = 3; end; end; else if t.ccode (i) = 1 then t.lcode (i) = 3; /* disable LEADING */ end; else if t.ccode (i) = 1 then t.lcode (i) = 3; end; end; end; k = newk; end; return; /*************************************/ replace: entry (rptr); dcl rptr ptr; dcl 1 r based (rptr), 2 ssp ptr, 2 slen fixed bin, 2 n fixed bin, 2 repl (0 refer (r.n)), 3 ccode fixed bin, /* 3=FIRST */ 3 lcode fixed bin, 3 lpos fixed bin, 3 llen fixed bin, 3 lsp ptr, 3 csp ptr, 3 clen fixed bin, 3 bsp ptr; /* ptr to BY string (length must = clen) */ start_replace: do i = 1 to r.n; if r.lcode (i) ^= 0 then do; k = index (substr (r.ssp -> str, 1, r.slen), substr (r.lsp (i) -> str, 1, r.llen (i))); if k = 0 then r.lpos (i) = r.slen + 1; else do; if r.lcode (i) = 2 then r.lpos (i) = k + r.llen (i); /* AFTER */ else do; /* BEFORE */ if r.ccode (i) ^= 0 then k = k - r.clen (i) + 1; r.lpos (i) = k; end; end; end; end; do k = 1 to r.slen; newk = k; do i = 1 to r.n; if r.lcode (i) = 2 then if k >= r.lpos (i) then r.lcode (i) = 0; /* enable AFTER tally */ else ; else if r.lcode (i) = 1 then if k >= r.lpos (i) then r.lcode (i) = 3; /* disable BEFORE tally */ if r.lcode (i) < 2 then do; /* if this tally enabled */ if r.ccode (i) = 0 then do; /* CHARACTERS */ substr (r.ssp -> str, k, 1) = substr (r.bsp (i) -> str, 1, 1); do i = i + 1 to r.n;/* scrap any eligible LEADING's and discontinue search */ if r.lcode (i) < 2 then if r.ccode (i) = 1 then r.lcode = 3; end; end; else do; if k + r.clen (i) - 1 ^> r.slen then do; /* enought string left? */ if substr (r.ssp -> str, k, r.clen (i)) = substr (r.csp (i) -> str, 1, r.clen (i)) then do; substr (r.ssp -> str, k, r.clen (i)) = substr (r.bsp (i) -> str, 1, r.clen (i)); if r.ccode (i) = 3 then r.lcode (i) = 3; /* FIRST - disable it now */ newk = k + r.clen (i) - 1; do i = i + 1 to r.n; if r.lcode (i) < 2 then if r.ccode (i) = 1 then r.lcode (i) = 3; end; end; else if r.ccode (i) = 1 then r.lcode (i) = 3; /* disable LEADING */ end; else if r.ccode (i) = 1 then r.lcode (i) = 3; end; end; end; k = newk; end; return; /***** Declaration for builtin function *****/ dcl (substr, mod, binary, fixed, addr, addrel, rel, length, string, unspec, null, index) builtin; /***** End of declaration for builtin function *****/ end cobol_su_;  display_cobol_run_unit.pl1 05/24/89 1048.6rew 05/24/89 0837.3 76761 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 display_cobol_run_unit.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/24/79 by PRP [4.1-1] added bad_arg error check */ /* Modified on 10/08/77 by GM to fix spacing when dcr -lg was issued */ /* Modified on 10/25/76 by ORN to eliminate cobol_iocb include file and comply with error message standards */ /* Modified on 07/17/76 by ORN to support display of external switchs */ /* Recompiled on 7/14/76 by George Mercuri to utilize the new include files. */ /* format: style3 */ display_cobol_run_unit: dcr: proc; dcl (i, j, k, n, nargs, arglen, len, code) fixed bin; dcl (count, icount) fixed bin; dcl (mode, org, acc) fixed bin; dcl (asw, lsw, fsw) bit (1); dcl mode_con (0:3) char (6) static init ("extend", "input", "i-o", "output"); dcl org_con (0:3) char (10) static init ("stream", "sequential", "relative", "indexed"); dcl acc_con (3) char (10) static init ("sequential", "random", "dynamic"); dcl (acon, dcon) char (6); dcl eicon char (8); dcl fname char (32); dcl programs char (8); dcl times char (5); dcl argptr ptr; dcl arg char (16) based (argptr); dcl get_pdir_ entry returns (char (168) aligned); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin); dcl com_err_ entry options (variable); dcl ioa_ entry options (variable); dcl ioa_$nnl entry options (variable); dcl hcs_$fs_get_seg_ptr entry (char (*), ptr, fixed bin); dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$bad_arg fixed bin (35) ext static; dcl cobol_control_$get_pointer entry returns (pointer); /* *********************************** */ start: asw, lsw, fsw = "0"b; call cu_$arg_count (nargs); if nargs > 0 then do i = 1 to nargs; call cu_$arg_ptr (i, argptr, arglen, code); if code ^= 0 then go to multics_error; /*[4.1-1]*/ if substr (arg, 1, 1) ^= "-" then go to bad_arg_error; if (arglen = 3 & substr (arg, 1, 3) = "-lg") | (arglen = 5 & substr (arg, 1, 5) = "-long") then lsw = "1"b; else if (arglen = 2 & substr (arg, 1, 2) = "-a") | (arglen = 4 & substr (arg, 1, 4) = "-all") then asw = "1"b; else if arglen = 6 & substr (arg, 1, 6) = "-files" then fsw = "1"b; else go to invalid_arg_error; end; controlp = cobol_control_$get_pointer (); if controlp = null () then go to no_run_error; if control.no_of_segs < 1 then if control.mpname = "" then go to no_run_error; count, icount = 0; do i = 1 to control.no_of_segs; stat_ptr = control.statptr (i); if stat_ptr = null () then icount = icount + 1; else if stat.call_cnt = -1 then icount = icount + 1; else count = count + 1; end; if count = 1 then programs = "program"; else programs = "programs"; call ioa_ ("^/Run-unit ^a contains ^d cobol ^a", control.name, count, programs); if control.mpname ^= "" then call ioa_ ("Main program: ^a", control.mpname); if asw then do; if icount = 1 then programs = "program"; else programs = "programs"; call ioa_ ("Control segment at ^p^/^d inactive ^a^/", controlp, icount, programs); end; else do; call ioa_ (""); if count = 0 then return; end; do i = 1 to control.no_of_segs; stat_ptr = control.statptr (i); if asw then call ioa_$nnl ("^2d ", i); if stat_ptr = null () then do; if asw then do; call ioa_ ("***Permanently inactive"); if lsw then call ioa_ (""); end; end; else if stat.call_cnt = -1 then do; if asw then do; if lsw then call ioa_ ("Name: ^a (inactive)^/ at ^p^/ data at ^p for ^d words", substr (stat.prog_id, 1, stat.prog_id_len), stat.entry_pt_ptr, stat.data_ptr, stat.data_len); else call ioa_ ("^a (inactive)", substr (stat.prog_id, 1, stat.prog_id_len)); end; end; else do; if lsw then do; if stat.call_cnt = 1 then times = "time"; else times = "times"; call ioa_ ( "Name: ^a^/ at ^p^/ invoked ^d ^a^/ data at ^p for ^d words^/ file_info at ^p", substr (stat.prog_id, 1, stat.prog_id_len), stat.entry_pt_ptr, stat.call_cnt, times, stat.data_ptr, stat.data_len, stat.file_info_ptr); end; else call ioa_ ("^a (^d)", substr (stat.prog_id, 1, stat.prog_id_len), stat.call_cnt); end; if fsw then do; if stat_ptr = null () then if asw then call ioa_ (" No active files"); else ; else if stat.call_cnt = -1 then if asw then call ioa_ (" No active files"); else ; else if stat.file_info_ptr = null () then call ioa_ (" No active files"); else do; file_info_ptr = stat.file_info_ptr; k = 0; j = divide (file_info.n, 2, 17, 0); do n = 1 to j; fsb_ptr = file_info.pt (n); if fsb_ptr ^= null () then if fsb.iocb_ptr ^= null () then k = k + 1; end; if k = 1 then acon = "file"; else acon = "files"; if j = 1 then dcon = "file"; else dcon = "files"; call ioa_ (" ^d ^a active, ^d ^a declared", k, acon, j, dcon); do n = 1 to j; fsb_ptr = file_info.pt (n); if fsb_ptr ^= null () then if fsb.iocb_ptr ^= null () then do; if fsb.internal then do; eicon = "Internal"; len = index (fsb.iocb_ptr -> iocb.name, " ") - 17; if len < 0 then len = 16; fname = substr (fsb.iocb_ptr -> iocb.name, 1, len); end; else do; eicon = "External"; fname = fsb.iocb_ptr -> iocb.name; end; if fsb.open_mode = 0 then call ioa_ (" ^a file ^a at ^p^/ closed by ^a", eicon, fname, fsb_ptr, fsb.open_close_name); else do; mode = fixed (substr (unspec (fsb.open_mode), 31, 2), 2); org = fixed (substr (unspec (fsb.open_mode), 33, 2), 2); acc = fixed (substr (unspec (fsb.open_mode), 35, 2), 2); call ioa_ ( " ^a file ^a at ^p^/ opened by ^a for ^a with ^a organization and ^a access", eicon, fname, fsb_ptr, fsb.open_close_name, mode_con (mode), org_con (org), acc_con (acc)); end; end; end; end; end; if lsw & stat_ptr ^= null () then call ioa_ (""); end; call ioa_ (""); k = 0; do i = 1 to 8; if control.sense_sw (i) ^= 0 then do; if k = 0 then do; call ioa_$nnl ( "External-switch status: 1 2 3 4 5 6 7 8^/ " ); if i > 1 then do j = 1 to i - 1; call ioa_$nnl ("OFF "); end; k = 1; end; call ioa_$nnl ("ON "); end; else if k ^= 0 then call ioa_$nnl ("OFF "); end; if k = 0 then call ioa_ ("All external-switches off^/"); else call ioa_ ("^/"); return; /* *********************************** */ multics_error: call com_err_ (code, "display_cobol_run_unit"); return; invalid_arg_error: call com_err_ (error_table_$badopt, "display_cobol_run_unit", substr (arg, 1, arglen)); return; no_run_error: call com_err_ (0, "display_cobol_run_unit", "There is no cobol run-unit currently active."); return; /*[4.1-1]*/ bad_arg_error: call com_err_ (error_table_$bad_arg, "display_cobol_run_unit", substr (arg, 1, arglen)); return; /* *********************************** */ %include cobol_fixed_static; %include cobol_control; %include cobol_fsb; %include iocb; %include cobol_file_info; end display_cobol_run_unit;  expand_cobol_source.pl1 05/24/89 1048.6rew 05/24/89 0836.8 150984 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 expand_cobol_source.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 02/08/82 by FCH, [5.1-3], cobol$copy_file_size defined, phx11819(BUG517) */ /* Modified on 01/04/81 by FCH, [5.1-2], let cobol_expand_source know if called by command, phx11818(BUG519) */ /* Modified on 10/27/81 by FCH, [5.1-1], issue diag if long line found, phx11819(BUG517) */ /* Modified on 07/20/81 by FCH, [4.4-2], bit count not computed correctly, phx10605(BUG495) */ /* Modified on 03/06/81 by FCH, [4.4-1], test for zero length seg, release areas if error */ /* Modified on 10/09/79 by FCH, [4.0-4], new control arguments */ /* Modified on 10/03/79 by FCH, [4.0-3], new control arguments */ /* Modified on 03/08/79 by FCH, [4.0-2], -strip blanks option */ /* Modified on 02/23/79 by FCH, [4.0-1], copy library name qualification */ /* Created on 09/16/78 by FCH */ /* expand_cobol_source path1 {path2} {-control_args} where path1 name of input segment, ".cobol" suffix implied control_args one of the following -lower_case, -lc lower case conversion, implies formatting -upper_case, -uc upper case conversion, implies formatting -card card image format, strip trailing blanks -expand, -exp expand source -no_expand, -no_exp do not expand source -format,-fmt format cobol source */ /* format: style3 */ expand_cobol_source: ecs: proc; /*************************************/ call cu_$arg_count (nargs); command = "1"b; etype = 1; /*[4.4-1]*/ tssi_ind = "0"b; ecs_info_ptr = addr (ecs_info_table); if nargs = 0 then do; call ioa_ ("^a^/^a^/^a^/^a^/", "expand_cobol_source: Expected argument missing", "Usage: expand_cobol_source path1 path2 {control_args}", "Control Arguments: -format(-fmt) -lower_case(-lc) -upper_case(-uc)", /*[4.0-2]*/ "Control Arguments: -card -expand(-exp) -no_expand(-no_exp)" /*[4.0-3]*/); return; end; on cleanup call cl; on command_abort_ call cl; call init; if code ^= 0 then go to multics_error; /* path1 */ call cu_$arg_ptr (1, argptr, arglen, code); if code ^= 0 then go to multics_error; call expand_pathname_$add_suffix (arg, "cobol", dn_1, en_1, code); if code ^= 0 then go to multics_error; if nargs = 1 then do; call gen_path2; if code ^= 0 then go to multics_error; end; /*[4.0-3]*/ else do; i = 2; do while (i <= nargs); call cu_$arg_ptr (i, argptr, arglen, code); if code ^= 0 then go to multics_error; /*[4.0-3]*/ if i = 2 /*[4.0-3]*/ then do; if substr (arg, 1, 1) = "-" /*[4.0-3]*/ then do; call gen_path2;/*[4.0-3]*/ call process_control_arg; /*[4.0-3]*/ end; /*[4.0-3]*/ else call expand_pathname_$add_suffix (arg, "cobol", dn_2, en_2, code); /*[4.0-3]*/ end; /*[4.0-4]*/ else if substr (arg, 1, 1) = "-" /*[4.0-4]*/ then call process_control_arg; /*[4.0-4]*/ else go to too_many_args_error; i = i + 1; end; /*[4.0-3]*/ end; call hcs_$initiate_count (dn_1, en_1, "", bc, 1, s1_ptr, code); if s1_ptr = null () then do; en = en_1; go to multics_arg_error; end; /*[4.4-1]*/ if bc = 0 /*[4.4-1]*/ then do; code = error_table_$zero_length_seg; /*[4.4-1]*/ en = en_1; /*[4.4-1]*/ go to multics_arg_error; /*[4.4-1]*/ end; en = en_2; /*[4.0-4]*/ call hcs_$initiate_count (dn_2, en_2, "", bc_temp, 1, s2_ptr, code); /*[4.0-4]*/ if s1_ptr ^= s2_ptr /*[4.0-4]*/ then do; call tssi_$get_segment (dn_2, en_2, s2_ptr, aclinfo_ptr, code); /*[4.4-1]*/ tssi_ind = "1"b; /*[4.0-4]*/ if code ^= 0 then go to multics_arg_error; /*[4.0-4]*/ end; ecs_info_table_.format_indicator = "1"b; call finish; if code ^= 0 then go to multics_error; goto exp_end_1; expand: entry (ecs_ptr, e_code); on cleanup call cl; on command_abort_ call cl; ecs_info_ptr = ecs_ptr; command = "0"b; call init; if code ^= 0 then go to exp_end; call hcs_$fs_get_path_name (ecs_info_table_.input_ptr, dn_1, ldn, en_1, code); if code ^= 0 then go to exp_end; call hcs_$initiate_count (dn_1, en_1, "", bc, 1, s1_ptr, code); if s1_ptr = null () then go to exp_end; call tssi_$get_segment (ecs_info_table_.dir, ecs_info_table_.ent, ecs_info_table_.output_ptr, aclinfo_ptr, code) ; if code ^= 0 then go to exp_end; /*[4.4-1]*/ tssi_ind = "1"b; s1_ptr = ecs_info_table_.input_ptr; s2_ptr = ecs_info_table_.output_ptr; /*[4.0-4]*/ if ecs_info_table_.exp_indicator then etype = 1; else etype = -1; if ecs_info_table_.format_indicator then ftype = 1; /*[4.0-4]*/ if ecs_info_table_.card_indicator then ftype = 2; ecs_info_table_.format_indicator = "0"b; /*[4.0-4]*/ ecs_info_table_.card_indicator = "0"b; call finish; /* Used to reinitialize the new *.ex.cobol (expanded version) and return */ /* the pointer to COBOL */ call hcs_$initiate_count (ecs_info_table_.dir, ecs_info_table_.ent, "", bc, 01b, ecs_info_table_.output_ptr, code); if ^(code = 0 | code = error_table_$segknown) then go to exp_end; e_code = 0; /*[5.1-1]*/ ecs_info_table_.bc = bc; goto exp_end_1; exp_end: e_code = code; exp_end_1: if area_info_area.areap ^= null () then call release_area_ (area_info_area.areap); call release_temp_segments_ ("expand_cobol_source", temp_ptr, code); return; /*[4.0-1]*/ find_incl_file: entry (file_name, lib_name, source_ptr, file_ptr, e_code); /*[4.0-1]*/ if lib_name ^= "" /*[4.0-1]*/ then do; call expand_pathname_$add_suffix /*[4.0-1]*/ (lib_name || ">" || file_name, "incl.cobol", dn_1, en_1, e_code); /*[4.0-1]*/ if e_code ^= 0 then return; /*[4.0-2]*/ call hcs_$initiate_count (dn_1, en_1, "", bc, 1, file_ptr, e_code); /*[4.0-1]*/ if e_code = error_table_$segknown then e_code = 0; /*[4.0-1]*/ end; /*[4.0-1]*/ else do; call find_include_file_$initiate_count /*[4.0-1]*/ ("cobol", source_ptr, file_name || ".incl.cobol", bc, file_ptr, e_code); /*[4.0-1]*/ end; /*[5.1-3]*/ call cobol$copy_file_size (bc); /*[4.0-1]*/ return; /* Error Handling */ badopt_error: call com_err_ (error_table_$badopt, "expand_cobol_source", arg); /*[4.4-1]*/ call cl; return; too_many_args_error: code = error_table_$too_many_args; go to multics_error; sameseg_error: code = error_table_$sameseg; go to multics_error; multics_error: call com_err_ (code, "expand_cobol_source"); /*[4.4-1]*/ call cl; return; multics_arg_error: call com_err_ (code, "expand_cobol_source", "^a", en); /*[4.4-1]*/ call cl; return; cl: proc; if area_info_area.areap ^= null () then call release_area_ (area_info_area.areap); /*[4.4-1]*/ if tssi_ind then call tssi_$clean_up_segment (aclinfo_ptr); call release_temp_segments_ ("expand_cobol_source", temp_ptr, code); end; init: proc; call get_temp_segments_ ("expand_cobol_source", temp_ptr, code); if code ^= 0 then return; area_infop = addr (area_info_area); area_info_area.version = area_info_version_1; area_info_area.owner = "expand_cobol_source"; area_info_area.areap = temp_ptr (3); area_info_area.size = sys_info$max_seg_size; string (area_info_area.control) = "0"b; /*[4.4-1]*/ area_info_area.extend /* , area_info_area.zero_on_alloc*/ = "1"b; call define_area_ (area_infop, code); if code ^= 0 then return; comp_lev = 5; /*[4.0-2]*/ ctype, ftype, etype = 0; end; finish: proc; /* ctype -1 lc 0 no change +1 uc ftype 0 expand 1 fmt, lc, uc 2 card etype -1 no_exp 0 exp +1 exp (I) fmt/card (T1) move (I) (O) (I) copy (T2) replace (T1) move (I) (O) (I) fmt/card (T1) copy (T2) replace (T1) move (I) (O) */ /*[4.0-4]*/ declare o_ptr ptr; /*[4.0-4]*/ if s1_ptr = s2_ptr then o_ptr = temp_ptr (1); else o_ptr = s2_ptr; /*[4.0-4]*/ go to FT (ftype); FT (0): /* expand */ /*[4.0-4]*/ call CR (s1_ptr, temp_ptr (2), o_ptr); go to FT_END; FT (1): /* format */ FT (2): /* card */ /*[4.0-4]*/ if etype < 0 /*[4.0-4]*/ then call TRANS (s1_ptr, o_ptr); /*[4.0-4]*/ else do; call TRANS (s1_ptr, temp_ptr (1)); /*[4.0-4]*/ call CR (temp_ptr (1), temp_ptr (2), o_ptr); /*[4.0-4]*/ end; FT_END: /*[4.0-4]*/ call MOVE (o_ptr, s1_ptr); /*[4.0-4]*/ ecs_info_table_.output_ptr = o_ptr; /*[4.0-4]*/ return; CR: proc (in_ptr, t_p, out_ptr); /*[4.0-4]*/ declare (in_ptr, t_p, out_ptr) ptr; /*[4.0-4]*/ ecs_info_table_.input_ptr = in_ptr; /*[4.0-4]*/ ecs_info_table_.output_ptr = t_p; /*[4.0-4]*/ call SET (t_p, null ()); /*[5.1-2]*/ ecs_info_table_.command = command; /*[4.0-4]*/ call cobol_expand_source_$copy (ecs_info_ptr, bc, command, temp_ptr (3)); /*[4.0-4]*/ call SET (out_ptr, t_p); /*[4.0-4]*/ ecs_info_table_.input_ptr = t_p; /*[4.0-4]*/ ecs_info_table_.output_ptr = out_ptr; /*[4.0-4]*/ call cobol_expand_source_$replace (ecs_info_ptr, bc, command, temp_ptr (3)); /*[4.0-4]*/ call SET (t_p, out_ptr); end; SET: proc (tr_ptr, set_ptr); /*[4.0-4]*/ declare (tr_ptr, set_ptr) ptr; /*[4.0-4]*/ call hcs_$truncate_seg (tr_ptr, 0, code); /*[4.0-4]*/ if code ^= 0 then go to multics_error; /*[4.0-4]*/ if set_ptr = null () then return; /*[4.0-4]*/ call hcs_$set_bc_seg (set_ptr, bc, code); /*[4.0-4]*/ if code ^= 0 then go to multics_error; end; TRANS: proc (in_ptr, out_ptr); /*[4.0-4]*/ declare (in_ptr, IP, out_ptr, OP) ptr; /*[4.0-4]*/ IP = in_ptr; OP = out_ptr; /*[4.0-4]*/ call SET (OP, IP); /*[4.0-4]*/ go to TRAN (ftype); TRAN (1): /* format */ call cobol_source_formatter_ (IP, OP, bc, ctype, 0); go to TRAN_END; TRAN (2): /* card */ /*[4.0-4]*/ call cobol_blank_stripper_ (IP, OP, bc); TRAN_END: /*[4.0-4]*/ call hcs_$set_bc_seg (OP, bc, code); /*[4.0-4]*/ if code ^= 0 then go to multics_error; end; MOVE: proc (in_ptr, out_ptr); /*[4.0-4]*/ declare (in_ptr, out_ptr) ptr; /*[4.4-2]*/ declare cc fixed bin; /*[4.0-4]*/ declare seg char (500000) based; /*[4.0-4]*/ if s1_ptr = s2_ptr /*[4.0-4]*/ then do; call hcs_$truncate_seg (out_ptr, 0, code); /*[4.0-4]*/ if code ^= 0 then go to multics_error; /*[4.4-2]*/ cc = divide (bc, 9, 31, 0); /*[4.4-2]*/ substr (out_ptr -> seg, 1, cc) = substr (in_ptr -> seg, 1, cc); /*[4.4-2]*/ call hcs_$set_bc_seg (out_ptr, bc, code); /*[4.4-2]*/ if code ^= 0 then go to multics_error; /*[4.0-4]*/ end; /*[4.0-4]*/ else do; call tssi_$finish_segment (in_ptr, bc, "101"b, aclinfo_ptr, code); /*[4.0-4]*/ if code ^= 0 then go to multics_error; /*[4.0-4]*/ end; end; end; cobol_strip: proc (p); declare p ptr, sz fixed bin; declare name char (32) based (p); call get_length (p); if j > 9 then do; if substr (name, j - 8, 9) = ".ex.cobol" then do; name = substr (name, 1, j - 9); return; end; end; if j > 6 then if substr (name, j - 5, 6) = ".cobol" then name = substr (name, 1, j - 6); end; gen_path2: proc; dn_2 = get_wdir_ (); en_2 = en_1; code = 0; call cobol_strip (addr (en_2)); call get_length (addr (en_2)); if j <= 23 then en_2 = substr (en_2, 1, j) || ".ex.cobol"; else code = error_table_$entlong; end; process_control_arg: proc; if arg = "-upper_case" | arg = "-uc" /*[4.0-2]*/ then do; call test_arg (ctype, 1); /*[4.0-3]*/ call test_arg (ftype, 1); /*[4.0-3]*/ end; else if arg = "-lower_case" | arg = "-lc" /*[4.0-2]*/ then do; call test_arg (ctype, -1); /*[4.0-4]*/ call test_arg (ftype, 1); /*[4.0-4]*/ end; else if arg = "-format" | arg = "-fmt" then call test_arg (ftype, 1); else /*[4.0-3]*/ if arg = "-card" /*[4.0-3]*/ then call test_arg (ftype, 2); /*[4.0-3]*/ else /*[4.0-3]*/ if arg = "-expand" | arg = "-exp" /*[4.0-3]*/ then call test_arg (etype, 1); /*[4.0-3]*/ else /*[4.0-3]*/ if arg = "-no_expand" | arg = "-no_exp" /*[4.0-3]*/ then call test_arg (etype, -1); else if arg = "" then return; else go to badopt_error; end; test_arg: proc (type, val); /*[4.0-2]*/ /*[4.0-2]*/ dcl (type, val) fixed bin; /*[4.0-2]*/ if type = 0 /*[4.0-2]*/ then type = val; /*[4.0-2]*/ else /*[4.0-2]*/ call com_err_ (error_table_$arg_ignored, "expand_cobol_source", arg); end; /*[4.0-2]*/ get_length: proc (p); declare p ptr; declare name char (32) based (p); j = index (name, " "); if j = 0 then j = 32; else j = j - 1; end; dcl (file_name, lib_name) char (*), (source_ptr, file_ptr) ptr; /*[4.0-1]*/ dcl command bit (1); dcl dir_ptr ptr; dcl (aclinfo_ptr, ecs_ptr) ptr; dcl (e1_ptr, e2_ptr) ptr; dcl final_ptr ptr; dcl argptr ptr; dcl (s1_ptr, s2_ptr, sf_ptr) ptr; dcl tssi_ind bit (1); dcl (nargs, comp_lev) fixed bin; dcl arglen fixed bin; dcl arg char (arglen) based (argptr); dcl 1 area_info_area aligned automatic structure like area_info; dcl 1 ecs_info_table automatic structure like ecs_info_table_; dcl (code, e_code, abc) fixed bin (35); dcl (bc, bc_temp) fixed bin (24); dcl (i, j, ldn) fixed bin; dcl (ctype, etype, ftype) fixed bin; /*[4.0-2]*/ dcl (dn_1, dn_2) char (168); dcl (en, en_1, en_2) char (32); dcl tn char (32); dcl error_table_$segknown fixed bin (35) ext; dcl error_table_$sameseg fixed bin (35) ext; dcl error_table_$noarg fixed bin (35) ext; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$arg_ignored fixed bin (35) ext; dcl error_table_$too_many_args fixed bin (35) ext; dcl error_table_$entlong fixed bin (35) ext; dcl error_table_$zero_length_seg fixed bin (35) ext; dcl sys_info$max_seg_size fixed bin (35) ext; dcl cobol_source_formatter_ entry (ptr, ptr, fixed bin (24), fixed bin, fixed bin); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl cobol_source_formatter_$no_shift entry (ptr, ptr, fixed bin (24), fixed bin); dcl com_err_ entry options (variable); dcl cobol_expand_source_$copy entry (ptr, fixed bin (24), bit (1), ptr); dcl cobol_expand_source_$replace entry (ptr, fixed bin (24), bit (1), ptr); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_wdir_ entry returns (char (168)); dcl define_area_ entry (ptr, fixed bin (35)); dcl release_area_ entry (ptr); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); /*[4.0-2]*/ dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl tssi_$get_segment entry (char (*), char (*), ptr, ptr, fixed bin (35)); dcl find_include_file_$initiate_count entry (char (*), ptr, char (*), fixed bin (24), ptr, fixed bin (35)); /*[4.0-1]*/ dcl tssi_$finish_segment entry (ptr, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)); dcl tssi_$clean_up_segment entry (ptr); dcl cobol_blank_stripper_ entry (ptr, ptr, fixed bin (24)); /*[4.0-2]*/ /*[5.1-3]*/ declare cobol$copy_file_size entry (fixed bin (24)); dcl (addr, index, null, substr, divide) builtin; dcl temp_ptr (3) ptr; dcl (cleanup, command_abort_) condition; %include area_info; %include cobol_ecs_info; end expand_cobol_source;  format_cobol_source.pl1 05/24/89 1048.6rew 05/24/89 0836.8 53334 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 format_cobol_source.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Last modified on 02/01/77 by ORN to support the -lmargin control argument */ /* Last modified on 11/24/76 by ORN to fix bug in which input seg is truncated if same as output seg */ /* Last modified on 08/16/76 by ORN to support -uc and -lc control arguments */ /* format: style3 */ format_cobol_source: fcs: proc; dcl dir_ptr ptr; dcl ename_ptr (2) ptr; dcl final_ptr ptr; dcl argptr ptr; dcl segptr (2) ptr; dcl 1 i_o based (addr (segptr (1))), 2 inptr ptr, 2 outptr ptr; dcl nargs fixed bin; dcl arglen fixed bin; dcl arg char (arglen) based (argptr); dcl code fixed bin (35); dcl bc fixed bin (24); dcl (i, j) fixed bin; dcl (ctype, mtype) fixed bin; dcl shift bit (1); dcl dir char (168); dcl ename (2) char (32); dcl equalname char (32); dcl error_table_$sameseg fixed bin (35) ext; dcl error_table_$noarg fixed bin (35) ext; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$arg_ignored fixed bin (35) ext; dcl error_table_$too_many_args fixed bin (35) ext; dcl cobol_source_formatter_ entry (ptr, ptr, fixed bin (24), fixed bin, fixed bin); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl cobol_source_formatter_$no_shift entry (ptr, ptr, fixed bin (24), fixed bin); dcl com_err_ entry options (variable); dcl equal_ entry (ptr, ptr, ptr, fixed bin (35)); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl addr builtin; dcl index builtin; dcl null builtin; dcl substr builtin; /*************************************/ start: shift = "1"b; go to join; no_shift: entry; shift = "0"b; join: dir_ptr = addr (dir); ename_ptr (1) = addr (ename (1)); ename_ptr (2) = addr (equalname); call cu_$arg_count (nargs); if nargs > 4 then go to too_many_args_error; if nargs < 2 then go to noarg_error; /* Process arguments */ do i = 1 to 2; call cu_$arg_ptr (i, argptr, arglen, code); if code ^= 0 then go to multics_error; call expand_path_ (argptr, arglen, dir_ptr, ename_ptr (i), code); if code ^= 0 then go to multics_error; if i = 2 then do; final_ptr = addr (ename (2)); call equal_ (ename_ptr (1), ename_ptr (2), final_ptr, code); if code ^= 0 then go to multics_error; ename_ptr (2) = final_ptr; end; j = index (ename (i), " "); if j = 0 then j = 33; if substr (ename (i), j - 6, 6) ^= ".cobol" then substr (ename (i), j, 6) = ".cobol"; call hcs_$initiate (dir, ename (i), "", 0, 1, segptr (i), code); if i = 2 then do; if inptr = outptr then go to sameseg_error; if segptr (2) = null () then do; /* output segment doesn't exist; create it */ call hcs_$make_seg (dir, ename (2), "", 10, segptr (2), code); if code ^= 0 then go to multics_arg_error; end; else do; call hcs_$truncate_seg (segptr (2), 0, code); if code ^= 0 then go to multics_arg_error; end; end; else if segptr (1) = null () then go to multics_arg_error; end; ctype, mtype = 0; if nargs > 2 then do i = 3 to nargs; call cu_$arg_ptr (i, argptr, arglen, code); if code ^= 0 then go to multics_error; if arg = "-upper_case" | arg = "-uc" then do; if ctype = 0 then ctype = 1; else call com_err_ (error_table_$arg_ignored, "format_cobol_source", arg); end; else if arg = "-lower_case" | arg = "-lc" then do; if ctype = 0 then ctype = -1; else call com_err_ (error_table_$arg_ignored, "format_cobol_source", arg); end; else if arg = "-lmargin" | arg = "-lm" then mtype = 1; else go to badopt_error; end; /* Call routine which actually does reformatting. */ if ^shift then call cobol_source_formatter_$no_shift ((inptr), (outptr), bc, ctype); else call cobol_source_formatter_ ((inptr), (outptr), bc, ctype, mtype); /* pass by value so offsets remain 0 */ call hcs_$set_bc_seg (outptr, bc, code); if code ^= 0 then go to multics_error; return; /* Error Handling */ noarg_error: code = error_table_$noarg; go to multics_error; badopt_error: call com_err_ (error_table_$badopt, "format_cobol_source", arg); return; too_many_args_error: code = error_table_$too_many_args; go to multics_error; sameseg_error: code = error_table_$sameseg; go to multics_error; multics_error: call com_err_ (code, "format_cobol_source"); return; multics_arg_error: call com_err_ (code, "format_cobol_source", "^a", ename (i)); return; end format_cobol_source;  stop_cobol_run.pl1 05/24/89 1048.6rew 05/24/89 0836.8 23382 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 stop_cobol_run.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified on 10/25/76 by ORN to comply with error message standards */ /* Modified on 03/26/76 by ORN to call cobol_cancel_ instead of cancel_. Change made in conjunction with cobol_control_ modification. */ /* format: style3 */ stop_cobol_run: scr: proc; dcl nargs fixed bin; dcl code fixed bin; dcl arglen fixed bin; dcl rdsw fixed bin; dcl rfsw fixed bin; dcl mcode fixed bin (35); dcl i fixed bin; dcl arg char (arglen) based (argptr); dcl argptr ptr; dcl cobol_control_$cobol_stop_run_command_ entry (ptr, fixed bin, fixed bin, fixed bin); dcl com_err_ entry options (variable); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl error_table_$badopt fixed bin (35) ext static; /*************************************/ start: rfsw = 0; rdsw = 0; call cu_$arg_count (nargs); do i = 1 to nargs; call cu_$arg_ptr (i, argptr, arglen, mcode); if mcode ^= 0 then go to merror; if arg = "-retd" | arg = "-retain_data" then rdsw = 1; else if arg = "-rf" | arg = "-retain_files" then rfsw = 1; else go to bad_arg_error; end; code = 0; call cobol_control_$cobol_stop_run_command_ (null (), rdsw, rfsw, code); if code ^= 0 then go to no_run_error; return; /*************************************/ bad_arg_error: call com_err_ (error_table_$badopt, "stop_cobol_run", arg); return; merror: call com_err_ (mcode, "stop_cobol_run"); return; no_run_error: call com_err_ (0, "stop_cobol_run", "There is no cobol run-unit currently active."); return; end stop_cobol_run;  cobol_rwcs_.pl1 05/24/89 1048.6rew 05/24/89 0836.8 10269 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8060), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8060 cobol_rwcs_.pl1 Reformatted code to new Cobol standard. END HISTORY COMMENTS */ /* Modified since Version 4.2 */ /* format: style3 */ cobol_rwcs_: proc; /* Initial Version of the module for binding purposes */ end cobol_rwcs_;  process_cobol_report.pl1 05/24/89 1048.6rew 05/24/89 0828.1 160992 /* *********************************************************** * * * * * Copyright,(C) Honeywell Information Systems Inc.,1981 * * * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(89-04-23,Zimmerman), approve(89-04-23,MCR8081), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8081 process_cobol_report.pl1 Change behavior to prevent creation of zero or incorrect length output files. 2) change(89-04-23,Zimmerman), approve(89-04-23,MCR8084), audit(89-05-05,RWaters), install(89-05-24,MR12.3-1048): MCR8084 process_cobol_report.pl1 Correct problem with adding to MSF components. END HISTORY COMMENTS */ /* Modified on 11/28/84 by FCH, [5.3-2], BUG570(phx16601), MSFs give out of bounds */ /* Modified on 89/03/10 by LVZ, bug572(phx16632) delete null output file. */ /* Modified on 11/17/84 by FCH, {5.3-1], BUG572(phx16632),initialize bit count */ /* Modified since Version 5.0 */ /* format: style3 */ process_cobol_report: pcr: proc; dcl SZ_OF_INPUT_STRING fixed bin (35) static internal options (constant) init (1048576); dcl SZ_OF_INPUT_ARRAY fixed bin (35) static internal options (constant) init (1048576); dcl SZ_OF_OUT_STRING fixed bin (35) static internal options (constant) init (1048576); dcl SZ_OF_OUT_ARRAY fixed bin (35) static internal options (constant) init (1048576); dcl SZ_OF_DATA fixed bin (35) static internal options (constant) init (32768); dcl input_string char (SZ_OF_INPUT_STRING) based (in_ptr); dcl input_array (SZ_OF_INPUT_ARRAY) char (1) based (in_base_ptr); dcl sys_info$max_seg_size fixed bin (35) ext static; /*[5.3-2]*/ dcl (max_size, maxer_size) fixed bin (35); /*[5.3-2]*/ dcl (old_size, new_size) fixed bin; dcl character_offset fixed bin (35); dcl next_offset fixed bin (35); dcl 01 text_line_in based (in_ptr) unal, 02 size fixed bin (35) unal, 02 report_code char (2), 02 control char (1), 02 filler char (1), 02 data char (SZ_OF_DATA); dcl 01 skip_line_in based (in_ptr) unal, 02 size fixed bin (35) unal, 02 report_code char (2), 02 control char (1), 02 filler char (1), 02 number_of_skips fixed bin (35) unal; dcl skip_length fixed bin (21); dcl report_codes_in char (255) varying; dcl requested_code char (2); dcl cch char (1); dcl in_ptr pointer; dcl in_base_ptr pointer; dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl num_of_args fixed bin; dcl arg_no fixed bin; dcl arg_ptr pointer; dcl arg_len fixed bin; dcl code fixed bin (35); dcl arg char (arg_len) based (arg_ptr); dcl reply char (40); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$user_output pointer external; dcl user_out ptr init (null ()); dcl msf_manager_$open entry (char (*), char (*), pointer, fixed bin (35)); dcl msf_manager_$get_ptr entry (pointer, fixed bin, bit (1) aligned, pointer, fixed bin (24), fixed bin (35)); dcl msf_manager_$close entry (pointer); dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl in_dirname char (168); dcl in_entryname char (32); dcl who_am_i char (20) init ("process_cobol_report"); dcl com_err_ entry options (variable); dcl i fixed bin; dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$badpath fixed bin (35) ext static; dcl file_output bit (1); dcl fcb_ptr pointer; dcl component_of_msf fixed bin; dcl in_bit_count fixed bin (24); dcl previous_in_ptr pointer; dcl data_ptr pointer; dcl all_codes bit (1); dcl true bit (1) static internal options (constant) init ("1"b); dcl false bit (1) static internal options (constant) init ("0"b); dcl length_of_data fixed bin (35); dcl newline_buffer char (254) init ((254)" "); dcl eof bit (1); dcl in_seg_size fixed bin (35); dcl out_dirname char (168); dcl out_entryname char (32); dcl out_fcb_ptr pointer; dcl aclinfo_ptr pointer; dcl out_base_ptr pointer; dcl out_ptr pointer; dcl out_string char (SZ_OF_OUT_STRING) based (out_ptr); dcl out_array (SZ_OF_OUT_ARRAY) char (1) based (out_base_ptr); dcl out_bit_count fixed bin (24); dcl out_char_offset fixed bin (35); dcl new_line char (1) init (" "); dcl tssi_$get_file entry (char (*), char (*), ptr, ptr, ptr, fixed bin (35)); dcl tssi_$finish_file entry (ptr, fixed bin, fixed bin (24), bit (36) aligned, ptr, fixed bin (35)); dcl data_length fixed bin (21); dcl rcd_arg bit (1); dcl 1 component_list (0:15), 02 base_seg_ptr pointer, 02 character_count fixed bin (35); dcl report_code_list (64) char (2); dcl num_of_reports fixed bin; dcl position fixed bin (35); dcl last_component bit (1); dcl report_index fixed bin; dcl list_index fixed bin; dcl found bit; dcl num_of_components fixed bin; dcl rest_of_segment fixed bin; dcl buffer char (266); dcl next_out_char_off fixed bin; dcl out_component fixed bin; dcl out_bc fixed bin (24); /*[5.3-2]*/ dcl max_line_size fixed bin init (256); /*[5.3-2]*/ dcl max_rec_size fixed bin init (266); /*[5.3-2]*/ dcl cd_size fixed bin init (10); /*[5.3-2]*/ dcl (segres, recsize) fixed bin; dcl newpage_flag bit (1); dcl stop_flag bit (1); dcl newpage char (1) init (" "); /*[5.3-1]*/ out_bit_count = 0; newpage_flag = true; stop_flag = false; user_out = iox_$user_output; max_size = sys_info$max_seg_size * 4; /*[5.3-2]*/ maxer_size = max_size + 1; all_codes = false; rcd_arg = false; num_of_reports = 1; report_code_list (1) = " "; out_component = 0; file_output = false; call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code ^= 0 then go to error_and_out; if arg_len = 0 then call comerr (0, 1, "^R""""^B"); /* null pathname */ call expand_pathname_ (arg, in_dirname, in_entryname, code); if code ^= 0 then call comerr (code, 1, arg); call cu_$arg_count (num_of_args); do i = 2 to num_of_args; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then go to error_and_out; if arg = "-of" | arg = "-output_file" then do; file_output = "1"b; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then go to error_and_out; else do; call expand_pathname_ (arg, out_dirname, out_entryname, code); if code ^= 0 then go to error_and_out; end; end; else if arg = "-rcd" | arg = "-report_code" then do; if all_codes then call comerr (0, 1, "The arguments -a and -rcd are incompatible"); else rcd_arg = true; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then go to error_and_out; else do; num_of_reports = 0; do position = 3 to arg_len by 3; if substr (arg, position, 1) = "," then do; num_of_reports = num_of_reports + 1; report_code_list (num_of_reports) = substr (arg, position - 2, 2); end; else call comerr (0, 1, "Illegal report code list"); end; if position - 1 = arg_len then do; num_of_reports = num_of_reports + 1; report_code_list (num_of_reports) = substr (arg, position - 2, 2); end; else call comerr (0, 1, "Illegal report code list."); end; end; else if arg = "-a" | arg = "-all" then if rcd_arg then call comerr (0, 1, "The options -rcd and -a are incompatible"); else all_codes = true; else if arg = "-nnp" | arg = "-no_newpage" then newpage_flag = false; else if arg = "-sp" | arg = "-stop" then stop_flag = true; else call comerr (error_table_$badopt, 1, arg); end; call msf_manager_$open (in_dirname, in_entryname, fcb_ptr, code); if code ^= 0 then call comerr2 (code, 1, "^a>^a", in_dirname, in_entryname); do component_of_msf = 0 to 15; component_list.base_seg_ptr (component_of_msf) = null (); end; last_component = false; component_of_msf = -1; do while (^last_component); /* component table for report file */ component_of_msf = component_of_msf + 1; call msf_manager_$get_ptr (fcb_ptr, component_of_msf, "0"b, in_base_ptr, in_bit_count, code); if code = error_table_$noentry then last_component = true; else if code ^= 0 then call comerr2 (code, 2, "^a>^a", in_dirname, out_dirname); else do; component_list.base_seg_ptr (component_of_msf) = in_base_ptr; component_list.character_count (component_of_msf) = divide (in_bit_count, 9, 35, 0); end; end; num_of_components = component_of_msf - 1; if all_codes then call fill_code_list; if file_output then do; /*output file specified */ call tssi_$get_file (out_dirname, out_entryname, out_base_ptr, aclinfo_ptr, out_fcb_ptr, code); if code ^= 0 then call comerr2 (code, 2, "^a>^a", out_dirname, out_entryname); out_ptr = out_base_ptr; out_char_offset = 1; end; do report_index = 1 to num_of_reports; /* for each report */ requested_code = report_code_list (report_index); call set_comp0; eof = false; call get_line; if eof then call comerr2 (0, 3, "Requested report code,^a,not found or format error in ^a", requested_code, in_dirname || ">" || in_entryname); if file_output then do; /* output file specified */ do while (^eof); /* for each report record */ data_length = text_line_in.size; if cch = ":" then do; next_out_char_off = out_char_offset + 1 + data_length; /*[5.3-2]*/ if next_out_char_off > maxer_size then do; /* record does not fit */ /*[5.3-2]*/ call set_sizes; /*[5.3-2]*/ substr (out_string, 1, old_size) = substr (text_line_in.data, 1, old_size); call msf; /*[5.3-2]*/ if new_size > 1 /*[5.3-2]*/ then substr (out_string, 1, new_size - 1) = substr (text_line_in.data, old_size + 1); /*[5.3-2]*/ substr (out_string, new_size, 1) = new_line; end; else do; /* record fits */ substr (out_string, 1, data_length) = substr (text_line_in.data, 1, data_length); substr (out_string, data_length + 1, 1) = new_line; end; out_char_offset = next_out_char_off; end; else if cch = "r" then do; skip_length = skip_line_in.number_of_skips; if skip_length <= 254 then do; next_out_char_off = out_char_offset + skip_length; /*[5.3-2]*/ if next_out_char_off > maxer_size then do; /* record does not fit */ /*[5.3-2]*/ call set_sizes; /*[5.3-2]*/ substr (out_string, 1, old_size) = substr (newline_buffer, 1, old_size); call msf; /*[5.3-2]*/ substr (out_string, 1, new_size) = substr (newline_buffer, 1, new_size); end; else substr (out_string, 1, skip_length) = substr (newline_buffer, 1, skip_length); out_char_offset = next_out_char_off; end; else call comerr (0, 3, "Too many successive new lines for output. Limit is 254.") ; end; else if cch = "n" then if newpage_flag then do; /* emit newpage */ substr (out_string, 1, 1) = newpage; out_char_offset = out_char_offset + 1; end; else ; else call comerr2 (0, 3, "Format error in input file. ^a>^a", in_dirname, in_entryname); out_ptr = addr (out_array (out_char_offset)); call get_line; end; out_bit_count = (out_char_offset - 1) * 9; end; else do; /* terminal output specified */ if stop_flag then call iox_$get_line (user_out, addr (reply), length (reply), 0, 0); do while (^eof); if text_line_in.control = ":" then do; data_length = text_line_in.size; call iox_$put_chars (user_out, addr (text_line_in.data), data_length, code); call iox_$put_chars (user_out, addr (newline_buffer), 1, code); end; else if cch = "r" then do; skip_length = skip_line_in.number_of_skips; if skip_length <= 254 then call iox_$put_chars (user_out, addr (newline_buffer), skip_length, code); else call comerr (0, 2, "Too many successive new lines for output. Limit is 254.") ; end; else if cch = "n" then if stop_flag then call iox_$get_line (user_out, addr (reply), length (reply), 0, 0); else ; else call comerr2 (0, 2, "Format error in input file. ^a>^a", in_dirname, in_entryname); call get_line; end; end; end; fill_code_list: proc; call set_comp0; num_of_reports = 0; eof = false; do while (^eof); call getl; found = false; do list_index = 1 to num_of_reports while (^found); if text_line_in.report_code = report_code_list (list_index) then found = true; end; if ^found then do; num_of_reports = num_of_reports + 1; report_code_list (num_of_reports) = text_line_in.report_code; end; end; end fill_code_list; get_line: proc; do while (^eof); call getl; if text_line_in.report_code = requested_code then return; end; end get_line; getl: proc; /* get the nest record */ /*[5.3-2]*/ segres = in_seg_size - next_offset + 1; /* size of remaining data */ /*[5.3-2]*/ in_ptr = addr (input_array (next_offset + 2)); /*[5.3-2]*/ if segres >= max_rec_size /*[5.3-2]*/ then do; /* next record in component */ /*[5.3-2]*/ next_offset = next_offset + cd_size + text_line_in.size; /*[5.3-2]*/ go to srx; /*[5.3-2]*/ end; /*[5.3-2]*/ if segres > 6 /*[5.3-2]*/ then do; /* size control word in component */ /*[5.3-2]*/ recsize = cd_size + text_line_in.size; /*[5.3-2]*/ if segres >= recsize /*[5.3-2]*/ then do; next_offset = next_offset + recsize; /* next rec in comp */ /*[5.3-2]*/ go to srx; /*[5.3-2]*/ end; /*[5.3-2]*/ segres = segres - 2; recsize = recsize - 2; /*[5.3-2]*/ call set_buff (segres, recsize - segres); /* split record */ /*[5.3-2]*/ next_offset = recsize - segres + 1; /*[5.3-2]*/ go to srx; /*[5.3-2]*/ end; /*[5.3-2]*/ go to sr (segres); /* size control word not completely in record */ sr (0): sr (1): sr (2): /*[5.3-2]*/ if segres = 1 /*[5.3-2]*/ then if component_of_msf = num_of_components /*[5.3-2]*/ then do; eof = true; /*[5.3-2]*/ return; /*[5.3-2]*/ end; /*[5.3-2]*/ call set_comp; /* get next component */ /*[5.3-2]*/ next_offset = 3 - segres; /*[5.3-2]*/ in_ptr = addr (input_array (next_offset)); /*[5.3-2]*/ next_offset = next_offset + 8 + text_line_in.size;/*[5.3-2]*/ go to srx; sr (3): sr (4): sr (5): sr (6): /* split size control word */ /*[5.3-2]*/ segres = 6 - segres; /*[5.3-2]*/ call set_buff (segres, 256 + 8 - segres); /* split record */ /*[5.3-2]*/ next_offset = 4 + text_line_in.size - segres; /*[5.3-2]*/ go to srx; srx: /*[5.3-2]*/ if text_line_in.size > max_line_size then go to format_error; /*[5.3-2]*/ cch = text_line_in.control; end; set_buff: proc (lsz, rsz); /* assemble split record */ /*[5.3-2]*/ dcl (lsz, rsz, sz) fixed bin; /*[5.3-2]*/ if lsz > 0 then substr (buffer, 1, lsz) = substr (input_string, 1, lsz); /*[5.3-2]*/ call set_comp; /*[5.3-2]*/ in_ptr = in_base_ptr; /*[5.3-2]*/ sz = min (rsz, 256 - lsz); /*[5.3-2]*/ if rsz > 0 then substr (buffer, lsz + 1, sz) = substr (input_string, 1, sz); /*[5.3-2]*/ in_ptr = addr (buffer); end; msf: proc; out_component = out_component + 1; call msf_manager_$get_ptr (out_fcb_ptr, out_component, "1"b, out_base_ptr, out_bc, code); out_ptr = out_base_ptr; end; set_sizes: proc; old_size = maxer_size - out_char_offset; new_size = next_out_char_off - max_size; next_out_char_off = new_size + 1; end; set_comp0: proc; component_of_msf = 0; in_base_ptr = component_list.base_seg_ptr (0); in_seg_size = component_list.character_count (0); next_offset = 0; end; set_comp: proc; if component_of_msf = num_of_components then go to format_error; component_of_msf = component_of_msf + 1; in_base_ptr = component_list.base_seg_ptr (component_of_msf); in_seg_size = component_list.character_count (component_of_msf); end; comerr: proc (code, labnum, message); dcl code fixed bin (35), labnum fixed bin, message char (*); call com_err_ (code, who_am_i, message); go to lab (labnum); lab (1): go to the_end; lab (2): go to close_and_end; lab (3): go to close_both_and_end; end; comerr2: proc (code, labnum, message, arg1, arg2); dcl code fixed bin (35), labnum fixed bin, message char (*); dcl (arg1, arg2) char (*); call com_err_ (code, who_am_i, message, arg1, arg2); go to lab (labnum); lab (1): go to the_end; lab (2): go to close_and_end; lab (3): go to close_both_and_end; end; close_both_and_end: if file_output then call tssi_$finish_file (out_fcb_ptr, out_component, out_bit_count, "110"b, aclinfo_ptr, code); close_and_end: call msf_manager_$close (fcb_ptr); if out_bit_count = 0 then call delete_$path (out_dirname, out_entryname, "011110"b, who_am_i, code); go to the_end; format_error: call comerr (0, 3, "format error"); error_and_out: call com_err_ (code, who_am_i); the_end: end; 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