fort_bfp_builtins_.fortran 01/10/85 1316.0rew 01/10/85 1306.2 46998 c ****************************************** c * * c * Copyright, (C) Honeywell Limited, 1984 * c * * c ****************************************** %global ansi77, bfp real function abs_(arg) real arg abs_ = abs(arg) end real function acos_(arg) real arg acos_ = acos(arg) end real function aimag_(arg) complex arg aimag_ = aimag(arg) end real function aint_(arg) real arg aint_ = aint(arg) end real function amod_(arg1, arg2) real arg1, arg2 amod_ = amod(arg1, arg2) end real function anint_(arg) real arg anint_ = anint(arg) end real function asin_(arg) real arg asin_ = asin(arg) end real function atan2_(arg1, arg2) real arg1, arg2 atan2_ = atan2(arg1, arg2) end real function atan_(arg) real arg atan_ = atan(arg) end real function cabs_(arg) complex arg cabs_ = cabs(arg) end complex function ccos_(arg) complex arg ccos_ = ccos(arg) end complex function cexp_(arg) complex arg cexp_ = cexp(arg) end complex function clog_(arg) complex arg clog_ = clog(arg) end complex function conjg_(arg) complex arg conjg_ = conjg(arg) end real function cos_(arg) real arg cos_ = cos(arg) end real function cosh_(arg) real arg cosh_ = cosh(arg) end complex function csin_(arg) complex arg csin_ = csin(arg) end complex function csqrt_(arg) complex arg csqrt_ = csqrt(arg) end complex function cxp2_(arg1, arg2) complex arg1, arg2 cxp2_ = arg1**arg2 end double precision function dabs_(arg) double precision arg dabs_ = dabs(arg) end double precision function dacos_(arg) double precision arg dacos_ = dacos(arg) end double precision function dasin_(arg) double precision arg dasin_ = dasin(arg) end double precision function datan2_(arg1, arg2) double precision arg1, arg2 datan2_ = datan2(arg1, arg2) end double precision function datan_(arg) double precision arg datan_ = datan(arg) end double precision function dcos_(arg) double precision arg dcos_ = dcos(arg) end double precision function dcosh_(arg) double precision arg dcosh_ = dcosh(arg) end double precision function ddim_(arg1, arg2) double precision arg1, arg2 ddim_ = ddim(arg1, arg2) end double precision function dexp_(arg) double precision arg dexp_ = exp(arg) end real function dim_(arg1, arg2) real arg1, arg2 dim_ = dim(arg1, arg2) end double precision function dint_(arg) double precision arg dint_ = dint(arg) end double precision function dlog10_(arg) double precision arg dlog10_ = dlog10(arg) end double precision function dlog_(arg) double precision arg dlog_ = dlog(arg) end double precision function dmod_(arg1, arg2) double precision arg1, arg2 dmod_ = dmod(arg1, arg2) end double precision function dnint_(arg) double precision arg dnint_ = dnint(arg) end double precision function dprod_(arg1, arg2) real arg1, arg2 dprod_ = dprod(arg1, arg2) end double precision function dsign_(arg1, arg2) double precision arg1, arg2 dsign_ = dsign(arg1, arg2) end double precision function dsin_(arg) double precision arg dsin_ = dsin(arg) end double precision function dsinh_(arg) double precision arg dsinh_ = dsinh(arg) end double precision function dsqrt_(arg) double precision arg dsqrt_ = dsqrt(arg) end double precision function dtan_(arg) double precision arg dtan_ = dtan(arg) end double precision function dtanh_(arg) double precision arg dtanh_ = dtanh(arg) end real function exp_(arg) real arg exp_ = exp(arg) end integer function idnint_(arg) double precision arg idnint_ = idnint(arg) end real function alog10_(arg) real arg alog10_ = log10(arg) end real function alog_(arg) real arg alog_ = log(arg) end integer function nint_(arg) real arg nint_ = nint(arg) end real function sign_(arg1, arg2) real arg1, arg2 sign_ = sign(arg1, arg2) end real function sin_(arg) real arg sin_ = sin(arg) end real function sinh_(arg) real arg sinh_ = sinh(arg) end real function sqrt_(arg) real arg sqrt_ = sqrt(arg) end real function tan_(arg) real arg tan_ = tan(arg) end real function tanh_(arg) real arg tanh_ = tanh(arg) end  fort_cleanup_.pl1 12/27/84 0853.8rew 12/27/84 0838.6 20880 /* ****************************************************** * * * Copyright, (C) Honeywell Limited, 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* format: style3,^delnl,linecom */ fort_cleanup_: proc (dp1, dc1, dp2, dp3, db1, sp); /* This procedure is the cleanup controller for Fortran Large and Very Large arrays, and for fortran_io_ cleanup. It is called by 'unwind_stack_' when 'cleanup' is signaled to a fortran program. */ /* Modification History. Created: August 30, 1982 by Tom Oke (UNCA). Modified: 15 Novemeber 1982, TO - Change to 'fortran_storage_' and 'fortran_storage_manager_' from 'fsd_' and 'fsm_'. */ /* SPECIAL ENTRY CONDITIONS REQUIRED FROM 'unwind_stack_'. */ /* 'unwind_stack_' uses an entry variable in which the label has been set to this routine, and the descripter pointer is set to the stack pointer of the frame in which the cleanup handler exists. If this stack pointer functionality is changed then we have no way of knowing what the stack frame pointer is to do the cleanup with. The unwind_stack_ definition is: dcl entry_variable variable entry (ptr, char (*), ptr, ptr, bit (1) aligned); By adding an additional pointer to the expected parameters, we can find the address of this pointer (the argument block pointer) and thus find the stack pointer value left by unwind_stack_. A bit kludgy, but functional and fast. */ dcl (dp1, dp2, dp3) ptr; /* Dummy Pointers */ dcl dc1 char (*); /* Dummy Characters */ dcl db1 bit (1) aligned; /* Dummy bit */ dcl sp ptr; /* stack pointer deferred */ dcl fortran_storage_manager_$free entry (ptr); /* Passed 'owning' stack ptr */ /* Find the stack frame pointer of the cleanup handler, then pass it to both the fortran_storage_manager_$free entry to free up Large and Very Large Arrays, and to fortran_io_$cleanup to free up files associated with that level. */ call fortran_storage_manager_$free (addr (sp)); end fort_cleanup_;  fort_hfp_builtins_.fortran 01/10/85 1316.0rew 01/10/85 1306.2 91701 c ****************************************** c * * c * Copyright, (C) Honeywell Limited, 1984 * c * * c ****************************************** %global ansi77, hfp real function abs_(arg) real arg abs_ = abs(arg) end real function acos_(arg) real arg acos_ = acos(arg) end real function aimag_(arg) complex arg aimag_ = aimag(arg) end real function aint_(arg) real arg aint_ = aint(arg) end real function amod_(arg1, arg2) real arg1, arg2 amod_ = amod(arg1, arg2) end real function anint_(arg) real arg anint_ = anint(arg) end real function asin_(arg) real arg asin_ = asin(arg) end real function atan2_(arg1, arg2) real arg1, arg2 atan2_ = atan2(arg1, arg2) end real function atan_(arg) real arg atan_ = atan(arg) end real function cabs_(arg) complex arg real major, minor, temp real max_real, max_real_by_root_2, max_real_by_16 data max_real/o376777777777/, max_real_by_root_2/o376552023631/, & max_real_by_16/o375777777777/ major = abs(real(arg)) minor = abs(aimag(arg)) if (major.lt.minor) then temp = major major = minor minor = temp endif if (major.eq.0.0) then cabs_ = 0.0 else if (major.le.max_real_by_root_2) then temp = minor/major cabs_ = major*sqrt(temp*temp + 1.0) else temp = minor/major temp = 0.0625*major*sqrt(temp*temp + 1.0) cabs_ = 16.0*temp if (temp.gt.max_real_by_16) cabs_ = max_real endif end complex function ccos_(arg) complex arg real x, y x = real(arg) y = aimag(arg) ccos_ = cmplx(cos(x)*cosh_(y), -sin(x)*sinh_(y)) end complex function cexp_(arg) complex arg real x, y x = real(arg) y = aimag(arg) cexp_ = exp(x)*cmplx(cos(y), sin(y)) end complex function clog_(arg) complex arg real r, x, y r = cabs_(arg) x = real(arg) y = aimag(arg) clog_ = cmplx(log(r), atan2(y, x)) end complex function conjg_(arg) complex arg conjg_ = conjg(arg) end real function cos_(arg) real arg cos_ = cos(arg) end real function cosh_(arg) real arg real f, max_real, x data max_real/o376777777777/ external signal (descriptors) x = abs(arg) if (x .gt. 352.8119) then call signal ("error", "-info_string", " sinh(x) or cosh(x), |x| > 352.8119, not allowed. Type ""start"" to set result to + or - .83798798+153") cosh_ = max_real else if (x .gt. 9.704) then f = exp(0.5*x) cosh_ = 0.5*f*f else f = exp(x) cosh_ = 0.5*(f + 1/f) endif end complex function csin_(arg) complex arg real x, y x = real(arg) y = aimag(arg) csin_ = cmplx(sin(x)*cosh_(y), cos(x)*sinh_(y)) end complex function csqrt_(arg) complex arg real factor, scaled_r, scaled_x, scaled_y if (abs(real(arg)).ge.1 .or. abs(aimag(arg)).ge.1) then factor = 4 scaled_x = 0.03125*real(arg) scaled_y = 0.03125*aimag(arg) else factor = 0.25 scaled_x = 8*real(arg) scaled_y = 8*aimag(arg) endif scaled_r = cabs_(cmplx(scaled_x, scaled_y)) csqrt_ = cmplx(factor*sqrt(scaled_r + scaled_x), & sign(factor*sqrt(scaled_r - scaled_x), scaled_y)) end complex function cxp2_(arg1, arg2) complex arg1, arg2 double precision f, x1, x2, x3, x4, y1, y2, y3, y4 c Set (x1, y1) = arg1 and (x2, y2) = arg2. x1 = real(arg1) y1 = aimag(arg1) x2 = real(arg2) y2 = aimag(arg2) c Set (x3, y3) = log(arg1). x3 = 0.5*dlog(x1*x1 + y1*y1) y3 = datan2(y1, x1) c Set (x4, y4) = log(arg1)*arg2. x4 = x3*x2 - y3*y2 y4 = x3*y2 + y3*x2 c Set cxp2_ = exp(log(arg1)*arg2). f = exp(x4) cxp2_ = cmplx(f*dcos(y4), f*dsin(y4)) end double precision function dabs_(arg) double precision arg dabs_ = dabs(arg) end double precision function dacos_(arg) double precision arg dacos_ = dacos(arg) end double precision function dasin_(arg) double precision arg dasin_ = dasin(arg) end double precision function datan2_(arg1, arg2) double precision arg1, arg2 datan2_ = datan2(arg1, arg2) end double precision function datan_(arg) double precision arg datan_ = datan(arg) end double precision function dcos_(arg) double precision arg dcos_ = dcos(arg) end double precision function dcosh_(arg) double precision arg double precision f, max_double, x data max_double/o376777777777777777777777/ external signal (descriptors) x = dabs(arg) if (x .gt. 352.8119149050121623d0) then call signal ("error", "-info_string", " sinh(x) or cosh(x), |x| > 352.8119, not allowed. Type ""start"" to set result to + or - .83798798+153") dcosh_ = max_double else if (x .gt. 22.18) then f = dexp(0.5*x) dcosh_ = 0.5*f*f else f = dexp(x) dcosh_ = 0.5*(f + 1/f) endif end double precision function ddim_(arg1, arg2) double precision arg1, arg2 ddim_ = ddim(arg1, arg2) end double precision function dexp_(arg) double precision arg dexp_ = exp(arg) end real function dim_(arg1, arg2) real arg1, arg2 dim_ = dim(arg1, arg2) end double precision function dint_(arg) double precision arg dint_ = dint(arg) end double precision function dlog10_(arg) double precision arg dlog10_ = dlog10(arg) end double precision function dlog_(arg) double precision arg dlog_ = dlog(arg) end double precision function dmod_(arg1, arg2) double precision arg1, arg2 dmod_ = dmod(arg1, arg2) end double precision function dnint_(arg) double precision arg dnint_ = dnint(arg) end double precision function dprod_(arg1, arg2) real arg1, arg2 dprod_ = dprod(arg1, arg2) end double precision function dsign_(arg1, arg2) double precision arg1, arg2 dsign_ = dsign(arg1, arg2) end double precision function dsin_(arg) double precision arg dsin_ = dsin(arg) end double precision function dsinh_(arg) double precision arg double precision f, max_double, x, xx data max_double/o376777777777777777777777/ external signal (descriptors) x = dabs(arg) if (x .gt. 352.8119149050121623d0) then call signal ("error", "-info_string", " sinh(x) or cosh(x), |x| > 352.8119, not allowed. Type ""start"" to set result to + or - .83798798+153") dsinh_ = max_double else if (x .gt. 22.18) then f = dexp(0.5*x) dsinh_ = 0.5*f*f else if (x .gt. 0.332) then f = dexp(x) dsinh_ = 0.5*(f - 1/f) else if (x .gt. 8.06e-10) then xx = x*x dsinh_ = x*(1 + xx*(1.666666666666666667d-1 & + xx*(8.333333333333333333d-3 & + xx*(1.984126984126984127d-4 & + xx*(2.755731922398589065d-6 & + xx*(2.505210838544171878d-8 & + xx*(1.60590438368216146d-10))))))) else dsinh_ = x endif if (arg .lt. 0) dsinh_ = -dsinh_ end double precision function dsqrt_(arg) double precision arg dsqrt_ = dsqrt(arg) end double precision function dtan_(arg) double precision arg dtan_ = dtan(arg) end double precision function dtanh_(arg) double precision arg double precision dcosh_, dsinh_ if (abs(arg) .gt. 22.18) then dtanh_ = dsign(1d0, arg) else dtanh_ = dsinh_(arg)/dcosh_(arg) endif end real function exp_(arg) real arg exp_ = exp(arg) end integer function idnint_(arg) double precision arg idnint_ = idnint(arg) end real function alog10_(arg) real arg alog10_ = log10(arg) end real function alog_(arg) real arg alog_ = log(arg) end integer function nint_(arg) real arg nint_ = nint(arg) end real function sign_(arg1, arg2) real arg1, arg2 sign_ = sign(arg1, arg2) end real function sin_(arg) real arg sin_ = sin(arg) end real function sinh_(arg) real arg real f, max_real, x double precision xx data max_real/o376777777777/ external signal (descriptors) x = abs(arg) if (x .gt. 352.8119) then call signal ("error", "-info_string", " sinh(x) or cosh(x), |x| > 352.8119, not allowed. Type ""start"" to set result to + or - .83798798+153") sinh_ = max_real else if (x .gt. 9.704) then f = exp(0.5*x) sinh_ = 0.5*f*f else if (x .gt. 0.419) then f = exp(x) sinh_ = 0.5*(f - 1/f) else if (x .gt. 2.11e-4) then xx = dprod(x, x) sinh_ = x*(1 + xx*(1.666666666666666667d-1 & + xx*(8.333333333333333333d-3 & + xx*(1.984126984126984127d-4)))) else sinh_ = x endif if (arg .lt. 0) sinh_ = -sinh_ end real function sqrt_(arg) real arg sqrt_ = sqrt(arg) end real function tan_(arg) real arg tan_ = tan(arg) end real function tanh_(arg) real arg if (abs(arg) .gt. 9.704) then tanh_ = sign(1e0, arg) else tanh_ = sinh_(arg)/cosh_(arg) endif end  fort_int_builtins_.fortran 12/27/84 0853.8r w 12/27/84 0838.6 11475 c ****************************************** c * * c * Copyright, (C) Honeywell Limited, 1984 * c * * c ****************************************** %global ansi77 integer function iabs_(arg) integer arg iabs_ = iabs(arg) end integer function idim_(arg1, arg2) integer arg1, arg2 idim_ = idim(arg1, arg2) end integer function index_(arg1, arg2) character*(*) arg1, arg2 index_ = index(arg1, arg2) end integer function isign_(arg1, arg2) integer arg1, arg2 isign_ = isign(arg1, arg2) end integer function len_(arg) character*(*) arg len_ = len(arg) end integer function mod_(arg1, arg2) integer arg1, arg2 mod_ = mod(arg1, arg2) end integer function ilr_(arg1, arg2) integer arg1, arg2 ilr_ = ilr(arg1, arg2) end integer function ils_(arg1, arg2) integer arg1, arg2 ils_ = ils(arg1, arg2) end integer function irl_(arg1, arg2) integer arg1, arg2 irl_ = irl(arg1, arg2) end integer function irs_(arg1, arg2) integer arg1, arg2 irs_ = irs(arg1, arg2) end  fortran_buffer_.cds 12/27/84 0853.8rew 12/27/84 0838.6 25092 /* ****************************************************** * * * Copyright, (C) Honeywell Limited, 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* format: style3,^delnl,linecom */ fortran_buffer_: proc; /* This cds program initializes and creates the FORTRAN buffer segment */ /* used as the file state blocks for fortran io files. R.Schoeman 11/76 */ /* Modified: 6 June 1977, D. Levin for new I/O system. */ dcl sys_info$max_seg_size external fixed bin (18); dcl 1 my_buffer like fortran_buffer_; dcl 1 my_cds_args like cds_args; dcl create_data_segment_ entry (ptr, fixed bin (35)); dcl com_err_ entry options (variable); dcl (addr, binary, length, null, rel, size, unspec) builtin; dcl p ptr; dcl exclude_array (1) char (32) init ("**"); dcl code fixed bin (35) init (0); %include fortran_buffer; %include fortran_io_consts; %include cds_args; unspec (my_cds_args) = "0"b; unspec (my_buffer) = "0"b; my_buffer.table.switch_p = null; /* aggregate assignment */ my_buffer.table (5).default_input = "1"b; my_buffer.table (41).default_input = "1"b; my_buffer.table (6).default_output = "1"b; my_buffer.table (42).default_output = "1"b; my_buffer.table (6).printer_file = "1"b; my_buffer.table (42).printer_file = "1"b; my_buffer.maximum_buffer = (sys_info$max_seg_size - (size (fortran_buffer_) - 1)); /* The * 4 is because its 4 chars per word */ my_buffer.all_files_closed = "1"b; my_buffer.table (0).connected = "1"b; my_buffer.table (0).formatted_records = "1"b; my_buffer.table (0).direction.in = "1"b; my_buffer.table (0).direction.out = "1"b; my_buffer.table (0).allow.seq_access = "1"b; my_buffer.table (0).carriage_controllable = "1"b; my_buffer.table (0).type_of_io = stream_file; my_buffer.table (0).open_code = 3; /* stream_input_output */ my_buffer.table (0).previous = open_opr; my_buffer.table (0).switch_ready = "1"b; my_cds_args.have_text = "1"b; my_cds_args.seg_name = "fortran_buffer_"; my_cds_args.struct_name = "my_buffer"; my_cds_args.sections (1).len = size (fortran_buffer_) - 1; /* the -1 is cause last word doesn't really exist but is a kludge */ my_cds_args.sections (1).p = addr (my_buffer); my_cds_args.num_exclude_names = 1; my_cds_args.exclude_array_ptr = addr (exclude_array); call create_data_segment_ (addr (my_cds_args), code); if code ^= 0 then call com_err_ ("Call to create_data_segment_ to create fortran_buffer_ failed."); end;  fortran_io_.pl1 08/06/87 1148.6rew 08/06/87 1045.1 2434104 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1987 * * * * Copyright, (C) Honeywell Limited, 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105): Fix fortran bugs 427, 451, 453, 454, 464, and 467. 2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105): Fix fortran bugs 122 and 490 (SCP6284). 3) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen), install(87-08-06,MR12.1-1069): Implemented SCP 6315: Fortran runtime error handler argument. END HISTORY COMMENTS */ /* format: style2 */ fortran_io_: procedure options (support); /* This entry must not be referenced */ call print_error (fortran_io_error_$fio_sys_error, me, "Wrong fortran_io_$fortran_io_ entry."); /* Written: 6 August 1973, David Levin */ /* Modified: 15 May 87, RW SCP 6315: added the -debug_io argument to call cu_$cl after an I/O error. 22 Jan 86, SH & AG - 490: Add "append" option to the "status" keyword in the "open"statement. 25 Nov 85, RW - 122: Changed max number of items in a format statement to 1023, up from 510 12 Sept 85, BW - 467: Return an error message when attempting to write beyond the end of files attached with -no_end. 09 Sept 85, BW - 427: Remove "kludge_for_no_end" procedure since vfile_ now supports "-no_end" for unstructured files. This also fixes the incorrect opening of a non-existant random binary stream file. 09 Aug 85, BW - 464: Check that user specified filenames, I/O switch names, and attach descriptions aren't blank. 23 May 85, BW - 454: Allow a character string to overwrite itself when used as an internal file. 16 May 85, BW - 453: Make list termination characters ";" and "/" work properly. 07 May 85, BW - 451: Return a "noentry" status code when opening non-existent files with status="old". 22 Jan 85, MM - 448: Make sure that the variable "current" is always initialized by fortran_io_$read_or_write. 27 Aug 84, BW - 440: Fix F-formatting error of numbers between -.5 and 0. 09 May 84, MM - 404: Make "version" entry use fort_version_info 28 Mar 84, MM - Install HFP support. 25 Aug 83, MM - 402: Pad output records to tape_nstd_ to make them word aligned. 19 Aug 83, MM - 400: Fix suppression of newlines in an absout. 14 July 83, MM - 407: Create new entry point: "set_cc_defer" for set_cc command. 14 July 83, MM - 406: Allow fortran_io_ to delete files it didn't create. 14 July 83, MM - 116: Fix defaulting to formatted files. 20 June 83, TO - 405: Speedup getting data type by index conversion table. 04 May 83, MM - 98: Correct error code for 2 open statement errors. 04 May 83, MM - 93: Change the nonstandard fortran character "|" to "I" in one of the error messages. 04 May 83, TO - 372: Fix namelist_io to pick up the runtime_block from the namelist symbol's father (skip back as necessary to find a level 0). 18 Mar 83, HH - Install LA/VLA support. 18 Mar 83, RG - 123: Make 'close_for_stop' realize that a unit can be connected but not attached nor opened by 'fortran_io_'. 10 Mar 83, HH - 101: Prevent F-format output in '77 mode from displaying minus zero. 08 Mar 83, HH - 83/91/95/97: Remove incorrect MR9 fix for bug 83 (TR 6459) in blocked files (i.e. change the value of 'open_modes (4).for_output' back to 6) and supply the correct fix: Never use 'sqio' mode for blocked files. 24 Feb 83, HH - 120: Fix list-directed output in '77 mode to supply a leading space for carriage control if the 'carriage' attribute is off. 09 Feb 83, HH - 119: Hang changes to format of list-directed and namelist output off the 'ansi_77' switch, so old programs don't break. 24 Nov 82, HH - 118: Change method of doing I format output conversion because old way failed for Iw.m format when m > 15. (New way is also a little faster.) 23 Nov 82, HH - 116: If FORM is not specified in an OPEN statement in '77 mode, assume 'FORMATTED' unless ACCESS is specified to be 'DIRECT'. 21 Nov 82, HH - 113: Improve list-directed output by suppressing the separator between consecutive items if either is a character value. 21 Nov 82, HH - 112: Improve list-directed output of numbers in F format by requiring at least 1 digit in the fraction part and rounding to suppress trailing 9's in the fraction part. 04 Nov 82, HH - 111: If scale factor is outside legal range for D and E output formats, fill the output field with stars rather than terminating the run. 01 Nov 82, HH - 110: In D, E, F and G input, ignore spaces and zeroes before the first significant digit of the mantissa and after the last nonzero digit of the fraction part. 01 Nov 82, HH - 107: If blanks are null, ignore them in D, E, F, G and I input while building the decimal representation of the input value, rather than by altering the input field. 30 Oct 82, HH - 109: Make list-directed output of double precision values the same as for real values, except allow up to 18 significant digits. 29 Oct 82, HH - 108: Remove the restriction that double precision constants may not be read into integer or real variables with list-directed input. 29 Oct 82, HH - 100: Fix T, TL, TR and X processing in '77 mode so that they alter the position in the record without changing its length or transmitting any characters. 27 Oct 82, HH - 103: Fix logical list-directed input to follow the FORTRAN/77 Standard. 20 Oct 82, TO - 106: Fix internal file write of 'FORMAT ()' to clear first record. 19 Oct 82, TO - 99: Fix inability of list directed character string to span records. 19 Oct 82, TO - 102: Fix formatted output to use an E-type exponent for an 'E' or 'G' format specification, and a D-type exponent for a 'D' format specification, instead of choosing the exponent type according to the data type. 18 Oct 82, TO - 104: Fix bug in 'get_associated_unit', where iocb_ptr not set. 18 Oct 82, TO - 105: Fix bug in 'INQUIRE' where filename not 'ltrim'd. 20 Jul 82, HH - Fix I/O bug 96: A file may randomly be opened for INOUT when either IN or OUT is requested in an OPEN statement. 19 Jul 82, HH - Fix I/O bug 94: DECODE randomly gets 'End of info encountered' because it checks 'internal_file_count', which is only set for internal file reads. 17 Jun 82, HH - Hang simulation of EOF records on the 'ansi_77' switch, so old programs don't break. 19 May 82, HH - Improve NAMELIST and list-directed output: drop extraneous leading spaces and trailing zeroes, and use G-format rather than E-format for real values. 13 May 82, HH - Make ENDFILE try to reopen for output if unit is open for input only. 10 May 82, HH - Add 'version' entrypoint to print the version of the compiler at the last time 'fortran_io_' was modified. 10 May 82, HH - Add 'skip_line_numbers' variable so that the list-directed I/O routines need not access 'runtime_format'. This is necessary since a runtime format is decoded into a working area used by the list-directed I/O routines! 07 May 82, TO - Change 'r' format pre-clear to use substr of spaces, rather than fio_ps.element_p -> words (1) = 0. 29 Apr 82, HH - Treat 'error_table_$asynch_deletion' as 'error_table_$no_record' in 'get_record'. 26 Apr 82, HH - Test for invalid scale factors according to the Standard (cf 13.5.9.2.1). 21 Apr 82, HH - Quote character values in NAMELIST output so they can be read by NAMELIST input. 19 Apr 82, HH - Revise implementation of ENDFILE to conform to the Standard. 25 Mar 82, TO - fix navy test bug 8 - logical input. (2 spots) 17 Mar 82, TO (for MEP) - fix navy test bug 9 - endfile on non-connected file. 13 Nov 81, MEP - fix bug 90, ENDFILE ignored. 6 Nov 81, MEP - finish? INQUIRE, fix bug in t_format (read), and alter stop entry not to use automatic variables it does not initialize (e.g. in based_work_area) 27 Oct 81, MEP - Start of inclusion of INQUIRE statement. 16 Oct 81, CRD - Change open_mode(4).for_output from 6 to 7 so that direct access blocked files get opened in sequential_update mode if reopened for output. 11 Oct 81, Fix open not to break in ansi66 mode for violation of ansi77 rules and change to fortran_open_data.incl.pl1 (alm). 3 Oct 81, MEP - Support for ansi77 internal files. Use of fio_ps.modes = internal_file (like string_io). Aug 81, MEP - ansi77 I/O features. 4 August 1981, CRD - Fix bug 088. 11 June 1981, CRD - Implement repetition counts in list directed input. Also changed store_null not to store anything if in ansi77 mode. 10 June 1981, CRD - Fix bug 87. 8 June 1981, CRD - Fix an unreported bug in which buffer_read may fault while doing list directed input. 15 Oct 1980, CRD - Fix bug 82. get_record was being called for a direct access binary stream read as well as for each element transfer. 14 Oct 1980, CRD - Fix quote doubling bug in list directed input, and use sequential_update rather than sequential_input_output for blocked files to avoid truncating the file on each write. 28 Aug 1980, CRD - Fix many bugs. 15 Aug 1980, MEP - Add code to calculate the namelist part of fortran77 character mode stuff. 12 May 1980, MEP - Add code to implement ansi_77 character array io. This causes rewriting of references to char_len, word_len, and the calculation of element_count. This also alters the way in which the element_pointer is updated, i.e. by characters rather than words. 04 Aug 1979, PES - Complete the fix to bug 079, by fixing the case in which the v format requires additional records, whose sequence numbers must also be ignored. This case was inadvertently overlooked in the 22 Jul 79 fix. 22 Jul 1979, PES - Fix bug 079, in which the s format item is ignored in the context "format (s,v)". 13 Jul 1979, CRD - Implement suggested improvement 078 to make namelist input insensitive to case when the program unit is compiled with -fold or -card. 05 Jul 1979, PES - Implement planned feature 074 for "v" format output, which was overlooked in the 13 Jun change. 15 Jun 1979, RAB - fix bug 76 in which an attempt to do a direct access write to an empty blocked file causes a "record not found". Bug was introduced by incomplete fix to bug 67. 13 Jun 1979, PES - fix bug 072 in which fortran_io_ improperly strips trailing blanks when doing formatted output to non-terminal files, causing problems with word oriented i/o modules; implements planned feature 036, in which the "Close files?" query should be eliminated, and planned feature 074, in which upper case characters D, E, F, and T should be used for outputting dp, real, and logical values, for compatibility with other systems; and implements suggested improvement 007, in which fortran_io_ should print a|7 instead of a$a (a|7) in error messages when all the names are the same. 25 May 1979, PES & RAB - fix bug 75 in which an uninitialized variable in fortran_io_ (fortran_open_data.char_str) may cause processing of the open statement to take an out_of_bounds_fault, with a probability which is initially small but which increases with each successive open in a process. 19 Apr 1979, RAB - fix bug 73 in which an attempt to open a non-vfile_ ( such as a tape file) for output causes the file to be initially opened for input, causing errors when doing label checking on an uninitialized volume. 19 Dec 1978, PES - fix bug 67 in which an attempt to read a non_existent record in a blocked file results in the next-higher record which is present being read, with no error indication. This fix (and other parts of the code) assume that direct_access files are being handled by vfile_. Should this cease to be the case, all calls to iox_$control will have to be checked. 13 Sep 78, PES - fix bug 065, in which fio takes a fault_tag_1 if an attempt is made to open a non-existent file; and bug 066, in which an attempt to access beyond the end of a direct_access file should result in the err= branch being taken, if specified. 11 Sep 78, PES - Fix bug 064, in which fio will not accept complex input of the form a=(1.,2.) unless a space is added before the ")". 07 Aug 78, PES - Change signal command_abort_ to call stop_run to interface with run unit facility. 15 Jun 78, DSL - Remove display_fortranio_error (dfe); fix bug in which FORTRAN I/O erroneously treats all files as closed even though the user answered "no" to our query; leave I/O switch attached if connection fails (this includes changing the file closing routines, close_fortran_file, etc., to recognize and properly handle this case). 08 Jun 78, DSL - Fix bug in f-format output in which incorrect format is used if zerodivide is signalled during conversion; fix bug in which /-format is ignored if it is the first field desc. 05 Jun 78, DSL - Implement display_fortranio_error (dfe); create structure for all double word variables; move all "static" declarations to ext proc; change "syntax_error", "too_much_input", "too_much_output", "conversion_error", "bad_char", to entry points. Fix bug in format processing in which an excess right parenthesis causes faults. Recognize "IOS compatability" as a valid open description. 11 May 78, DSL - Fix open to attempt input only opening if incorrect access to write and user did not explicitly request write access; minor change to get_open_field. 25 Apr 78, DSL - Minor change to allow fio to recover if old fio is invoked before new fio. 05 Apr 78, DSL - Only print input record if it is relevant to the error message; insure that rel(frd_$fio_buf_p) >= area_size; use ioa_$ioa_switch to print warnings instead of com_err_ (bug 54); support iostat var for EOF; do not trim white space if $-format is used; use -extend if fio creates attach desc for vfile_ and file is open for output (this also means that the file is rewound after it is opened); file is opened for output if: inout and fio attach desc or empty file; recognize if any type of vfile_ file is empty; on error, print input record using ioa_$ioa_switch rather than com_err_; also, print pointer to bad char; allow "$" and "_" in variable names for namelist input (bug 55). 21 Mar 78, DSL - Convert to new format representation; completely rewrite carriage control code. 06 Feb 78, DSL - Fix char control code to only print one blank line for the format "(1h )". Also fix deferred output to put newlines between its records. 03 Jan 78, DSL - More changes for "static" stack frames. 19 Dec 77, DSL - Changed to support new "static" stack frame. Stack frame for fortran_io_ is pushed the first time any entry point is referenced by a given user stack frame and is popped with the user stack frame. 06 Dec 77, DSL - Bug fixes: Finish handler should be an external entry not an internal entry; proc get_record does not set record_found correctly (introduced on 23 Nov 77). Also, more clean up in formatted I/O. 23 Nov 77, DSL - Bug fixes: correct handling of empty (or nonexistent) files; suppress newline char for structured files; put "-no_end" in attach desc for blocked files. 15 Nov 77, DSL - Fix open statement to recognize unstructured file as possible binary stream file. Also clean up changes started 10/24/77. 24 Oct 77, DSL - some quickie speedups. a) copy format as it is used to minimize number of times it is unpacked. b) change write_a_record to call iox_$put_chars only at the end of the write statement rather than at each newline character. 19 Sep 77, DSL - allow backspace even if file is at BOF; fix list-dir output to print imaginary part of complex value. 07 Sep 77, DSL - implement status specifier for close statement. fix bug in open for nonexistent blocked file. 30 Aug 77, DSL - delete extra comma in namelist output; prevent printing of record on EOF error; file 0 is not closed; change defer_newline to affect generation of all carriage_controllable files. NOTE -- implementation of defer attr conflicts with documentation with this change. 11 Aug 77, DSL - Bug fixes: close_file does not close 0 if nothing else is open; wrong open modes for tape_mult_; EOF on binary files not detected correctly; iostat var must always be set if given; form only allowed when connecting; fix error messages; implement rewind for tape I/O modules. 02 Aug 77, DSL - Change reopen; implement s-format; better treatment of terminal files. 21 Jul 77, DSL - fix bugs; change inplementation for opening a nonexistent file for inout; prevent close files query for fast or dfast; April thru June 1977 David Levin - Completely restructured. Obsolete code removed. */ /* This program extensively changed 11/76 to fix many bugs, improve */ /* performance, and change actions performed. --R.Schoeman */ /* The following comments outline the implementatin of "static" stack frame. Refer to MCR 3153. When a FORTRAN program's stack frame is created and the program performs I/O, stack_frame.ps_ptr is initialized as an ITS pair pointing to the PS for the program. This field is never modified again by the object segment or by pl1_operators_. In this change to the implementation of fortran_io_, I propose using the high-order bit of this field as flag. The bit is ignored if the field is used as an ITS pair and the value of this bit is zero when the ITS pair is stored. All FORTRAN programs reference fortran_io_, the support procedure for FORTRAN I/O, via operator calls (to pl1_operators_, of course). Therefore, all valid references to fortran_io_ support entry points enter fortran_io_ via pl1_operators_. Once in pl1_operators_, the sign of stack_frame.ps_ptr indicates the value of our flag. First Reference to fortran_io_ The first time fortran_io_ is referenced from a (user) stack frame, the sign of stack_frame.ps_ptr is positive because the high-order bit is zero. In this case, a full PL/I call is made to the appropriate support entry point in fortran_io_. (It does not matter which entry point is used to create the stack frame for fortran_io_.) Once within fortran_io_ the following actions are performed in order to implement the "static" stack frame for fortran_io_: 1. Copy fortran_io_'s stack_frame|4 to the user's stack_frame|4. This field is used by PL/I and FORTRAN to determine the true end of the stack frame when a temporary stack extension is freed. By copying this field, a temporary stack extension in the user's stack frame will not cause an accidental freeing of fortran_io_'s stack frame. 2. Store the address of a PL/I goto statement within fortran_io_ at fio_ps.label_addr. This goto statement contains a subscripted reference to a label array, in which the variable mentioned below in item 3 is the subscript, to transfer control to the correct support entry point in fortran_io_. (N.B. - The structure "fio_ps" is in fortran_io_'s stack frame.) 3. Store the address of a fortran_io_ variable at fio_ps.label_index_addr. This variable is used as the subscript of the label array reference mentioned above. Code in pl1_operators_ uses this address to store the value of index register 6. The value of this register identifies the support entry point desired. The variable itself is initialized to zero. 4. Store the address of fortran_io_'s stack frame at fio_ps.stack_frame_p. 5. Store a packed ptr to fio_ps at the user's stack_frame.support_ptr. 6. Set high-order bit of the user's stack_frame.ps_ptr to "1"b. 7. Now that the stack frames are properly set up and control is at the appropriate entry point, fortran_io_ can perform the requested task. Subsequent References to fortran_io_ If the sign of the user's stack_frame.ps_ptr is negative, the high-order bit of the word is "1"b and this indicates that a stack frame already exists for fortran_io_. In this case the following actions are performed instead of a PL/I call: 1. The value of index register 0 is stored at the user's stack_frame.return_ptr+1. This field now forms an ITS pair pointing the return point in the user's program. 2. A pointer to fortran_io_'s stack frame, obtained from fio_ps.stack_frame_p, is stored in the user's stack_frame.next_sp. (Fortran_io_'s stack_frame.prev_sp does not have to be set as it is still valid from when the stack frame was created.) 3. The sp, pr6, is loaded from fio_ps.stack_frame_p. 4. The value of index register 6 is stored indirectly through fio_ps.label_index_addr using a "sxl6" instruction. This sets the value of the fortran_io_ variable, i.e., sets the subscript of the label array reference. Control is now transferred indirectly through fio_ps.label_addr. This results in tranferring to the PL/I goto statement mentioned earlier and the execution of that statement results in a transfer to the appropriate entry point within fortran_io_. 5. Control is now in fortran_io_ with pr6 pointing to the correct stack frame!! Perform the requested task. Returning From fortran_io_ In order to return control to the user program, return_to_user$special_return is called. This routine: - copies fortran_io_'s stack_frame.next_sp into the user's stack_frame.next_sp (this makes fortran_io_'s stack frame part of the user's frame) - sets pr6 to the user's frame - does a short_return Fortran_io_'s stack frame is now part of the user's stack frame and remains so until the next I/O operation. Each user stack frame has its own fortran_io_ stack frame. Notes The procedure fortran_io_ must never execute a return_mac, i.e., a return from the external procedure fortran_io_, or fortran_io_'s stack frame goes away while the flag in the user's stack frame proclaims its existence. The procedure return_to_user.alm was initially added to bound_fortran_io_ in order to provide a faster non-local return for the FORTRAN err= and end= exits. It now performs that function, following the guidelines outlined here, as well as the "normal" return mentioned above. The following include files and source segments are used to implement these changes: fortran_io_.pl1 fortran_ps.incl.alm fortran_ps.incl.pl1 pl1_operators_.alm return_to_user.alm stack_frame.incl.alm stack_frame.incl.pl1 */ /* The following structure is declared to insure that all double word variables are close packed. Using a structure prevents storage allocation dependencies. */ dcl 1 dummy_for_double_word_alignment aligned structure, 2 PS_ptr ptr, 2 block_pt ptr, 2 buffer_seg_pointer ptr, 2 buffer_pointer ptr, 2 constant_ptr ptr, 2 count_pt ptr, 2 end_pt ptr, 2 fcb_ptr ptr, 2 fmt_ptr ptr, 2 format_p ptr, 2 iocb_ptr ptr, 2 link_pt ptr, 2 name_pt ptr, 2 namelist_name_ptr ptr, 2 ok_pt ptr, 2 subs_pt ptr, 2 symbol_pt ptr, 2 table_pt ptr, 2 text_pt ptr, 2 user_sp ptr; dcl 1 file_desc like fortran_buffer_.table aligned based (fcb_ptr); dcl CPDW fixed bin (8) init (8) int static options (constant); dcl CPW fixed bin (8) init (4) int static options (constant); dcl EOF1 char (1) aligned int static options (constant) init (""); /* \034 */ dcl EOF2 char (2) aligned int static options (constant) init ("\f"); /* \134 \146 */ dcl EOF3 char (2) aligned int static options (constant) init ("\F"); /* \134 \106 */ declare FALSE bit (1) int static options (constant) init ("0"b); declare TRUE bit (1) int static options (constant) init ("1"b); dcl fio_data_type_index (0:63) static options (constant) initial (0, 6, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 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, 1, 1, 1, 1, 1, 1); declare abs builtin; declare add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; dcl addr builtin; dcl addrel builtin; dcl area_size fixed bin int static options (constant) init (2048); dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); dcl attach_desc_len fixed bin; dcl b_var_str char (256) varying based; dcl base fixed bin (3); dcl baseno builtin; dcl baseptr builtin; dcl begin_index fixed bin (21); dcl binary builtin; dcl binary_type (4) fixed bin init (6, 9, 94, 97) internal static options (constant); dcl binary_prec (4) fixed bin (35) init (27, 63, 27, 63) internal static options (constant); dcl bin_type fixed bin; dcl bit builtin; dcl buffer_index fixed bin (21); dcl buffer_length fixed bin (21); dcl buffer_max_len fixed bin (21); dcl call_sw fixed bin (1); /* <0 first; =0 all others; >0 last */ dcl capital_letters char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl ch char (1) aligned; dcl char_len fixed bin (21); declare char_offset fixed binary (21); dcl character_type fixed bin static options (constant) init (6); dcl chars_left fixed bin (21); dcl chars_per_item fixed binary (21); dcl chars char (4096) based; declare code fixed binary (35); dcl column_one fixed bin; dcl com_err_ entry options (variable); dcl convert builtin; dcl copy builtin; dcl count fixed bin; dcl create_if_not_found bit (1) aligned int static options (constant) init ("1"b); dcl cu_$cl entry (bit (1) aligned); dcl cu_$stack_frame_ptr entry () returns (ptr); dcl current fixed bin (4); dcl dec_flt float decimal (59) aligned based (addr (work)); dcl dec_int fixed decimal (11) aligned based (addr (work)); dcl default_error_handler_$add_finish_handler entry (entry, fixed bin (35)); dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl dexp fixed decimal (3); declare dirname character (168); dcl divide builtin; dcl dp_flt_pic picture "-9.v(17)9es99" aligned based (addr (work)); dcl dp_fxd_pic picture "(18)-9.v(21)9" aligned based (addr (work)); dcl data_type_of_prev_item fixed bin; dcl e fixed bin; dcl element_count fixed bin (24); dcl entry_point fixed bin; declare entryname character (32); dcl error_table_$asynch_deletion fixed bin (35) ext static; dcl error_table_$end_of_info fixed bin (35) ext static; dcl error_table_$moderr fixed bin (35) ext static; dcl error_table_$no_file fixed bin (35) ext static; dcl error_table_$no_operation fixed bin (35) ext static; dcl error_table_$no_record fixed bin (35) ext static; dcl error_table_$noentry fixed bin (35) ext static; dcl error_table_$pathlong fixed bin (35) ext static; dcl error_table_$short_record fixed bin (35) ext static; dcl exists bit (1) aligned; dcl exists_file_code fixed bin; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl exps char (4) aligned int static options (constant) init ("edED"); dcl ext_float_decimal fixed bin internal static options (constant) init (162); dcl fast_related_data_$fortran_buffer_p ptr ext static; dcl fast_related_data_$fortran_io_initiated bit (1) aligned ext static; dcl fast_related_data_$in_dfast bit (1) aligned ext static; dcl fast_related_data_$in_fast_or_dfast bit (1) aligned ext static; dcl fast_related_data_$terminate_run ext static entry variable; dcl fixed builtin; dcl fixedoverflow condition; dcl flt_pic picture "-9.v(7)9es99" aligned based (addr (work)); dcl format_type (0:3) char (13) int static options (constant) init ("List-directed", "Unformatted", "Formatted", "Namelist"); dcl fortran_buffer_$ ext static; dcl fortran_io_error_$access_field_error fixed bin (35) ext static; dcl fortran_io_error_$already_connected fixed bin (35) ext static; dcl fortran_io_error_$already_opened fixed bin (35) ext static; dcl fortran_io_error_$attach_desc_field_error fixed bin (35) ext static; dcl fortran_io_error_$bad_char fixed bin (35) ext static; declare fortran_io_error_$blank_field_error fixed bin (35) ext static; dcl fortran_io_error_$cannot_position fixed bin (35) ext static; dcl fortran_io_error_$cannot_read fixed bin (35) ext static; dcl fortran_io_error_$cannot_reopen fixed bin (35) ext static; dcl fortran_io_error_$cannot_truncate fixed bin (35) ext static; dcl fortran_io_error_$cannot_write fixed bin (35) ext static; dcl fortran_io_error_$conversion_error fixed bin (35) ext static; declare fortran_io_error_$close_attr_error fixed binary (35) external static; dcl fortran_io_error_$dnumeric_file fixed bin (35) ext static; dcl fortran_io_error_$filename_field_error fixed bin (35) ext static; dcl fortran_io_error_$fio_sys_error fixed bin (35) ext static; dcl fortran_io_error_$form_field_error fixed bin (35) ext static; dcl fortran_io_error_$format_error fixed bin (35) ext static; dcl fortran_io_error_$format_is_infinite fixed bin (35) ext static; dcl fortran_io_error_$formatted_file fixed bin (35) ext static; dcl fortran_io_error_$incompatible_opening fixed bin (35) ext static; declare fortran_io_error_$internal_file_oflow fixed bin (35) ext static; dcl fortran_io_error_$invalid_file0_attr fixed bin (35) ext static; dcl fortran_io_error_$invalid_file0_type fixed bin (35) ext static; dcl fortran_io_error_$invalid_for_file0 fixed bin (35) ext static; dcl fortran_io_error_$io_switch_field_error fixed bin (35) ext static; dcl fortran_io_error_$long_record fixed bin (35) ext static; dcl fortran_io_error_$missing_header fixed bin (35) ext static; dcl fortran_io_error_$mode_field_error fixed bin (35) ext static; dcl fortran_io_error_$must_be_empty fixed bin (35) ext static; dcl fortran_io_error_$namelist_error fixed bin (35) ext static; dcl fortran_io_error_$not_blocked fixed bin (35) ext static; dcl fortran_io_error_$not_direct fixed bin (35) ext static; dcl fortran_io_error_$not_open fixed bin (35) ext static; dcl fortran_io_error_$not_scratch_file fixed bin (35) ext static; dcl fortran_io_error_$not_sequential fixed bin (35) ext static; dcl fortran_io_error_$open_attr_conflict fixed bin (35) ext static; declare fortran_io_error_$open_attr_incomplete fixed bin (35) ext static; dcl fortran_io_error_$parens_too_deep fixed bin (35) ext static; dcl fortran_io_error_$read_after_eof fixed bin (35) ext static; dcl fortran_io_error_$short_record fixed bin (35) ext static; dcl fortran_io_error_$status_field_error fixed bin (35) ext static; dcl fortran_io_error_$syntax_error fixed bin (35) ext static; dcl fortran_io_error_$unformatted_file fixed bin (35) ext static; dcl fortran_io_error_$unknown_filetype fixed bin (35) ext static; dcl fortran_io_error_$write_after_eof fixed bin (35) ext static; dcl fortran_io_error_$wrong_mode fixed bin (35) ext static; dcl fxd_pic picture "(8)-9.v(11)9" aligned based (addr (work)); dcl general_format_parse_$runtime entry (char (1024) aligned, char (4096) aligned, bit (1) aligned, fixed bin (35)) ; declare get_pdir_ entry () returns (char (168)); dcl have_runtime_format bit (1) aligned; dcl hbound builtin; declare hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); declare hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl i fixed bin (18); dcl illegal_return condition; dcl in fixed bin; dcl index builtin; dcl integer_dtype fixed bin init (2) internal static options (constant); dcl integer_prec fixed bin (35) init (35) internal static options (constant); dcl interactive bit (1); declare internal_file_count fixed binary (17); dcl int_pic picture "(15)-9" aligned based (addr (work)); dcl io_buf char (buffer_length) based (buffer_pointer); dcl ioa_$ioa_switch entry options (variable); dcl iox_$attach_iocb entry (ptr, char (*), fixed (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$error_output ptr ext static; dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$find_iocb entry (char (*) aligned, ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); dcl iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl iox_$user_input ptr ext static; dcl iox_$user_io ptr ext static; dcl iox_$user_output ptr ext static; dcl j fixed bin (18); dcl k fixed bin (18); dcl l fixed bin (18); dcl last fixed bin (21); declare lbound builtin; dcl length builtin; dcl lower_letters char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl ltrim builtin; dcl max_fixed fixed bin int static options (constant) init (11); dcl max_float fixed bin int static options (constant) init (59); dcl me char (12) init ("fortran_io_") int static options (constant); dcl min builtin; dcl mod builtin; declare must_produce_plus bit (1) aligned; dcl my_code fixed bin (35); dcl new_buffer_length fixed bin (21); declare no_uid bit (36) aligned internal static options (constant) initial (""b); dcl null builtin; dcl operation_name (0:14) char (12) int static options (constant) init ("ZERO-ERROR", " write", "Old endfile", " read", "Rewind", "Unused 5", "Closefile", "Close", "Backspace", "Inquire", "Openfile", "Open", "Margin", "Unused 13", "Endfile"); dcl overflow condition; dcl overflow_label label; dcl pl1_operators_$VLA_words_per_seg_ fixed bin (19) ext; dcl prec fixed bin; dcl process_type fixed bin; dcl prompt_char char (4) aligned int static init ("? ") options (constant); dcl psp ptr; dcl ptr builtin; dcl rel builtin; dcl return_if_not_found bit (1) aligned int static options (constant) init ("0"b); dcl return_to_user entry (ptr, ptr); dcl return_to_user$special_return entry; dcl round builtin; dcl rtrim builtin; dcl search builtin; dcl sent fixed bin (21); dcl size condition; dcl skip_line_numbers bit (1); dcl stop_run external entry; dcl str_len fixed bin; dcl string builtin; dcl substr builtin; dcl suppress_final_newline bit (1) aligned; dcl sys_info$max_seg_size fixed bin (18) ext static; dcl terminal_file bit (1) aligned; dcl translate builtin; dcl underflow condition; declare unique_chars_ entry (bit (*)) returns (char (15)); dcl unspec builtin; dcl user_info_$process_type entry (fixed bin); dcl verify builtin; declare vfile_status_ entry (char (*), char (*), ptr, fixed bin (35)); dcl white_space char (2) aligned int static options (constant) init (" "); /* SP TAB */ dcl word_len fixed bin (19); dcl words (2) fixed bin (35) aligned based; dcl zero_label label; dcl zerodivide condition; /* WARNING !!! these structures proport to know the internal representation of extended float decimal data */ dcl 1 number aligned structure based (addr (work)), 2 sign char (1) unaligned, 2 digit char (prec) unaligned, 2 exp fixed bin (8) unaligned, 1 flt_dec aligned structure based (addr (work)), 2 pad1 char (60) unaligned, 2 exp fixed bin (8) unaligned; dcl 1 word_align_1 aligned based, 2 based_bits bit (72) unaligned; dcl 1 word_align_2 aligned based, 2 based_dp float bin (63) unaligned; dcl 1 word_align_3 aligned based, 2 double_word fixed bin (71) unaligned; /* I/O module information. */ dcl 1 open_mode (13) aligned structure int static options (constant), 2 io_type bit (3) unal init ((3) (1)"001"b, (10) (1)"010"b), 2 direction unaligned structure, 3 in bit (1) init ("1"b, "0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b, "1"b), 3 out bit (1) init ("0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b, "1"b, "1"b), 2 for_input fixed bin (4) unal init (0, 1, 0, 0, 4, 0, 0, 0, 8, 0, 0, 11, 0), 2 for_output fixed bin (4) unal init (3, 0, 2, 6, 0, 7, 5, 10, 0, 9, 13, 0, 12); /* Structures for formatted input/output processing. These overlay the buffer. */ /* Used to clear first record of internal file write. */ dcl buffer char (buffer_max_len) based (buffer_pointer); dcl 1 record_structure aligned structure based (buffer_pointer), 2 pad char (buffer_index) unaligned, /* these are already processed */ 2 rest_of_record char (buffer_length - buffer_index) unaligned; /* What's left of the record */ dcl 1 field_structure aligned structure based (buffer_pointer), 2 pad char (buffer_index) unaligned, /* these are already processed */ 2 rest_of_field char (last - buffer_index) unaligned; /* What's left of the field */ dcl 1 output_structure aligned structure based (buffer_pointer), 2 pad char (buffer_length) unaligned, /* these are already processed */ 2 rest_of_output char (1024) unaligned; /* What's added to the output record */ /* valid values for fields in open and close statements */ declare open_status_values (5) char (12) varying internal static options (constant) init ("unknown", "new", "old", "scratch", "append"); declare open_mode_values (3) char (12) varying internal static options (constant) init ("in", "out", "inout"); declare open_access_values (2) char (12) varying internal static options (constant) init ("sequential", "direct"); declare open_form_values (2) char (12) varying internal static options (constant) init ("formatted", "unformatted"); declare open_blank_values (2) char (12) varying internal static options (constant) init ("null", "zero"); declare close_status_values (2) char (12) varying internal static options (constant) init ("keep", "delete"); /* various named constants */ declare new_file fixed bin int static options (constant) init (1); declare old_file fixed bin int static options (constant) init (2); declare scratch_file fixed bin int static options (constant) init (3); declare append_file fixed bin int static options (constant) init (4); declare unknown_file fixed bin int static options (constant) init (0); declare COMMA char (1) int static options (constant) init (","); dcl two_NLs char (2) aligned int static options (constant) init (" "); dcl ( SP init (" "), NL init (" "), CR init (" "), FF init (" ") ) char (1) aligned internal static options (constant); dcl 1 stack_f aligned based, 2 pad (2) bit (72) aligned, 2 sp_up_4 bit (72) aligned, 2 pad2 bit (72) aligned, 2 xr (0:7) fixed bin (17) unal; /* The following data structure overlays the PS data structure. */ dcl 1 dfast_communications_area aligned based (addr (PS.data_word (1))), 2 max_recl fixed bin, 2 pad fixed bin, 2 pathname_ptr pointer, 2 filetype_ptr pointer; /* BUFFER SEGMENT STRUCTURE - These fields are stored in the buffer segment. */ dcl 1 based_work_area aligned based (buffer_seg_pointer), /* OFFSET (octal) LENGTH IN WORDS (octal) */ 2 version fixed bin, /* 0001 */ /* These fields are used for conversions and should not be overlayed. */ /* 1*/ 2 work char (64) aligned, /* 0020 */ /* 21*/ 2 work_str char (4096) aligned, /* 1000 */ /* These fields are only used by open. */ /* 1021*/ 2 attachment char (256) unaligned, /* 0100 */ /* 1121*/ 2 dir char (168) unaligned, /* 0052 */ /* 1173*/ 2 ent char (32) unaligned, /* 0010 */ /* 1203*/ 2 ioname char (32) aligned, /* 0010 */ /* 1213*/ 2 info (20) fixed bin, /* 0024 */ /* These fields allow us to save info from most recent error. */ /* 1237*/ 2 actual_error fixed bin (35), /* 0001 */ /* 1240*/ 2 ps_at_error ptr; /* 0002 */ /* 1242 - next free offset */ /* 4000 - last free offset */ dcl NL_FF char (2) aligned int static options (constant) init (" "); %include fortran_ps; %include fortran_buffer; %include fortran_open_data; %include fortran_inquire_data; %include stack_frame; %include rs_info; %include iocb; %include format_tables; %include vfs_info; %include iox_modes; /* IMPLEMENTS THE STATIC STACK FRAME TRANSFER VECTOR */ label_for_entry (0): goto label_for_entry (entry_point); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* ENTRY TO INITIATE READ OR WRITE */ read_or_write: entry (psp); PS_ptr = psp; call make_static_frame; /* The following enables all handlers used during fortran I/O. */ overflow_label = no_handler; zero_label = no_handler; on fixedoverflow, overflow, underflow, size goto overflow_label; on zerodivide goto zero_label; label_for_entry (12): /* read_or_write */ /* Prepare for I/O operation. If the operation is not a string operation then call initialize_fortran_io to validate the request and initialize the buffer. For string I/O requests (encode and decode)and ansi77 internal files set up the various buffer pointers to look right. For internal files, calculate the number of records of the internal file. if PS.buffer_length = 0, then it is not an array and there is 1 record else PS.buffer_length gives the number of words for the array (ansi66) or the number of characters for the array (ansi77). See the comment in set_size_and_count for a more graphic explanation. */ call_sw = -1; /* first call */ if fio_ps.mode = string_io | fio_ps.mode = internal_file then do; buffer_max_len = PS.max_buffer; buffer_pointer = PS.buffer_p; if fio_ps.ansi_77 then char_offset = buffer_max_len; else char_offset = divide (buffer_max_len + CPW - 1, CPW, 17, 0) * CPW; if fio_ps.read then buffer_length = buffer_max_len; else buffer_length = 0; if fio_ps.mode = internal_file then do; if ^fio_ps.read & ^fio_ps.list/* clear record */ then buffer = ""; if PS.buffer_size = 0 /* internal_file isn't an array */ then internal_file_count = 1; else if fio_ps.ansi_77 then internal_file_count = divide (PS.buffer_size, buffer_max_len, 17, 0); else internal_file_count = divide (PS.buffer_size * CPW, char_offset, 17, 0); end /* internal_file */; end /* string_io and internal_file */; if fio_ps.read /* Determine the I/O operation to be performed. */ then current = read_opr; else current = write_opr; call initialize_fortran_io; have_runtime_format = "0"b; suppress_final_newline = "0"b; go to initiate_routine (fixed (fio_ps.format, 2)); initiate_routine (0): /* Free format I/O(list-directed) */ overflow_label = conversion_error_handler; zero_label = no_handler; if fio_ps.read & fio_ps.format = list_directed then buffer_index = 0; fio_ps.format = list_directed; /* the parse prevents list_directed I/O on internal files */ if ^fio_ps.read & fio_ps.mode ^= string_io then if (file_desc.printer_file & file_desc.carriage_controllable) | fio_ps.ansi_77 then do; if buffer_length = buffer_max_len then call too_much_output; substr (rest_of_output, 1, 1) = SP;/* append NL to existing contents */ buffer_length = buffer_length + 1; end; if fio_ps.read then call initialize_list_input (); else data_type_of_prev_item = character_type; /* Suppress separator before 1st item. */ go to initiate_common; initiate_routine (1): /* Unformatted I/O. */ buffer_index = 0; /* number of words read from buffer so far */ go to initiate_common; initiate_routine (2): /* Formatted I/O. */ call initialize_formatted_io; initiate_common: if ^fio_ps.list then goto terminate_no_list; call return_to_user$special_return; initiate_routine (3): /* Namelist */ overflow_label = conversion_error_handler; zero_label = no_handler; call namelist_io; goto terminate_no_list; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* ERROR - ATTEMPT TO ENTER fortran_io_ VIA STANDARD CALL. */ element: terminate: entry (psp); PS_ptr = psp; fio_ps.file_number = PS.file_number; string (fio_ps.job_bits) = string (PS.job_bits); fio_ps.error_label, fio_ps.iostat_var, fio_ps.have_input = "0"b; fortran_buffer_ptr = fast_related_data_$fortran_buffer_p; call print_error (fortran_io_error_$fio_sys_error, me, "Wrong version of pl1_operators_."); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* ELEMENT CALL - TRANSMIT ONE SCALAR OR ONE ARRAY */ label_for_entry (15): call_sw = 0; /* all others */ go to element_routine (fixed (fio_ps.format, 2)); element_routine (0): if ^fio_ps.end_of_input /* user can signal end of input; rest of list not set */ then call list_io; element_list_abort: call return_to_user$special_return; element_routine (1): call unformatted_io; call return_to_user$special_return; element_routine (2): call formatted_io; call return_to_user$special_return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* TERMINATE CALL - FINISH UP I/O REQUEST */ label_for_entry (14): terminate_no_list: call_sw = 1; /* last call */ if ^fio_ps.read then call write_a_record; return_error_code: call return_to_user$special_return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* FILE CONTROL CALL - PERFORM FILE CONTROL */ file_control: entry (psp); PS_ptr = psp; call make_static_frame; /* The following enables all handlers used during fortran I/O. */ overflow_label = no_handler; zero_label = no_handler; on fixedoverflow, overflow, underflow, size goto overflow_label; on zerodivide goto zero_label; label_for_entry (13): call_sw = 0; /* all others */ current = binary (fio_ps.control_type, 4, 0); /* determine the io operation */ call initialize_fortran_io; call return_to_user$special_return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* GET AREA PTR CALL - RETURN PTR TO WORK AREA */ get_io_area_ptr: entry (psp); /* Returns a pointer to a work area for open and close statements. */ PS_ptr = psp; call make_static_frame; /* The following enables all handlers used during fortran I/O. */ overflow_label = no_handler; zero_label = no_handler; on fixedoverflow, overflow, underflow, size goto overflow_label; on zerodivide goto zero_label; label_for_entry (22): call_sw = 0; /* all others */ PS.buffer_p = addr (fortran_buffer_.buf); fortran_open_data.char_str = ""; call return_to_user$special_return; /* ENTRY POINTS TO IMPLEMENT I/O RELATED FEATURES */ stop: entry; /* Implements file system part of FORTRAN stop statement. As this is called with fortran_stop_ on the stack, we CANNOT rely on any automatic variables in fortran_io_ having thier values saved, as we can in other entries. */ if fast_related_data_$in_fast_or_dfast then call close_all_files ("1"b); /* dont ask, just close them */ else call close_for_stop; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ finish_handler: entry; /* This entry point is the finish handler for FORTRAN I/O. */ call close_all_files ("0"b); call release_buffer_ptr; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Entry to implement the close_file command. */ close_file: entry (close_unit, close_code); dcl close_unit fixed bin, close_code fixed bin (35); call get_buffer_ptr (return_if_not_found, exists);/* do not force creation of buffer segment */ if ^exists /* no buffer segment, therefore nothing is open */ then do; close_code = 0; return; end; if close_unit < 0 then do; /* Request to close all files. */ call close_all_files ("0"b); close_code = 0; return; end; if close_unit >= 1 & close_unit <= 99 then do; /* request to close particular file. */ fio_ps.file_number = close_unit; fcb_ptr = addr (fortran_buffer_.table (fio_ps.file_number)); iocb_ptr = file_desc.switch_p; call close_fortran_file; close_code = 0; return; end; else if close_unit = 0 then do; close_code = fortran_io_error_$invalid_for_file0; return; end; close_code = error_table_$no_file; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Entry to implement the set_cc command. */ set_cc: entry (cc_unit, status_bit, error_code); dcl cc_unit fixed bin, status_bit bit (1) aligned, error_code fixed bin (35); call get_buffer_ptr (create_if_not_found, exists);/* output value ignored */ if cc_unit < 0 | cc_unit > 99 then error_code = error_table_$no_file; else do; fortran_buffer_.table (cc_unit).printer_file = status_bit; error_code = 0; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* New entry to allow the set_cc command to set defer on. */ set_cc_defer: entry (file_unit, cc_bit, defer_bit, defer_specified, err_code); dcl file_unit fixed bin, cc_bit bit (1) aligned, defer_bit bit (1) aligned, defer_specified bit (1) aligned, err_code fixed bin (35); call get_buffer_ptr (create_if_not_found, exists);/* output value ignored */ if file_unit < 0 | file_unit > 99 then error_code = error_table_$no_file; else do; fortran_buffer_.table (file_unit).printer_file = cc_bit; if defer_specified then fortran_buffer_.table (file_unit).defer_newline = defer_bit; error_code = 0; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Entry to print the version of the compiler at the last modification to 'fortran_io_'. */ version: entry; dcl fort_version_info$greeting char (16) aligned ext static; dcl fort_version_info$version_number char (16) aligned ext static; dcl ioa_ entry options (variable); call ioa_ (rtrim (fort_version_info$greeting) || substr (fort_version_info$version_number, 10)); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ conversion_error_handler: buffer_index = begin_index; /* Point to beginning of constant for error. */ call print_error (fortran_io_error_$conversion_error); no_handler: call print_error (fortran_io_error_$fio_sys_error, me, "Condition for which there is no handler."); get_buffer_ptr: proc (a_create_sw, seg_exists); dcl a_create_sw bit (1) aligned; /* "1"b create if not found; "0"b do not create if not found */ dcl seg_exists bit (1) aligned; /* "1"b buffer seg already exists; "0"b does not exist */ dcl create_sw bit (1) aligned; dcl get_segment bit (1) aligned; dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl size builtin; create_sw = a_create_sw; seg_exists = fast_related_data_$fortran_io_initiated; /* If buffer seg is already initiated, just set up the global pointers. */ if fast_related_data_$fortran_io_initiated then do; fortran_buffer_ptr = fast_related_data_$fortran_buffer_p; /* If rel(fortran_buffer_ptr) < area_size we must increase its value in order to prevent an invalid value for buffer_seg_pointer. This code is only needed as long as old style fortran_io_'s exist in the system. */ if fixed (rel (fortran_buffer_ptr), 18) < area_size then do; unspec (addrel (fortran_buffer_ptr, area_size) -> fortran_buffer_) = unspec (fortran_buffer_ptr -> fortran_buffer_); fortran_buffer_ptr = addrel (fortran_buffer_ptr, area_size); fast_related_data_$fortran_buffer_p = fortran_buffer_ptr; /* so we only do it once a process */ fortran_buffer_.maximum_buffer = (sys_info$max_seg_size - (binary (rel (addr (fortran_buffer_.buf)), 18) - 1)) * CPW; end; buffer_seg_pointer = addrel (fortran_buffer_ptr, -area_size); return; end; else if ^create_sw then return; /* not there yet, return if we shouldn't create it */ /* Segment is not initiated. (Create and) Inititate it. */ fortran_buffer_ptr = fast_related_data_$fortran_buffer_p; /* Get buffer pointer */ /* First see if we must allocate our own segment. */ if fortran_buffer_ptr ^= null then do; get_segment = "0"b; /* Segment, or part thereof, already allocated */ buffer_seg_pointer = fortran_buffer_ptr; fortran_buffer_ptr, fast_related_data_$fortran_buffer_p = addrel (buffer_seg_pointer, area_size); end; else do; if ^create_sw /* not there yet, return if we shouldn't create it */ then do; seg_exists = "0"b; return; end; get_segment = "1"b; /* Must free it when we are done */ call get_temp_segments_ (me, ptr_array, (0)); /* will never be non-zero */ buffer_seg_pointer = ptr_array (1); fortran_buffer_ptr, fast_related_data_$fortran_buffer_p = ptr (buffer_seg_pointer, area_size); /* also must establish a finish handler. */ call default_error_handler_$add_finish_handler (finish_handler, my_code); if my_code ^= 0 then call print_error (my_code, me, "Cannot establish finish handler for FORTRAN I/O."); end; /* Now initialize. First assignment to buffer segment is to prevent hardware bug from screwing actual assignment. If hardware bug occurs, first assignment will fail. */ fortran_buffer_ptr -> words (1) = 0; /* Insures that initialization is not the first */ /* reference to the segment. */ unspec (fortran_buffer_) = unspec (addr (fortran_buffer_$) -> fortran_buffer_); fortran_buffer_.maximum_buffer = (sys_info$max_seg_size - (binary (rel (addr (fortran_buffer_.buf)), 18) - 1)) * CPW; if get_segment then fortran_buffer_.allocated_by_fortran = "1"b; if fast_related_data_$in_dfast /* insure file table entry is right for file 0 */ then do; fortran_buffer_.table (0).prompt = "1"b; fortran_buffer_.table (0).defer_newline = "0"b; fortran_buffer_.table (0).printer_file = "0"b; end; fast_related_data_$fortran_io_initiated = "1"b; return; release_buffer_ptr: entry (); /* Releases buffer seg and resets all external fields. */ if ^fast_related_data_$fortran_io_initiated /* i.e., never referenced */ then return; ptr_array (1) = fast_related_data_$fortran_buffer_p; /* Get buffer pointer. */ if ptr_array (1) -> fortran_buffer_.allocated_by_fortran /* Release seg only if we allocated it. */ then do; ptr_array (1) = ptr (ptr_array (1), 0); call release_temp_segments_ (me, ptr_array, my_code); fast_related_data_$fortran_buffer_p = null; /* Prevent use of invalid seg no. */ end; else fast_related_data_$fortran_buffer_p = addrel (ptr_array (1), -area_size); fast_related_data_$fortran_io_initiated = "0"b; /* Segment must be initiated before next use. */ end get_buffer_ptr; make_static_frame: proc; /* This procedure is responsible for setting up the "static" frame and setting all fields in the user's stack frame and fortran_io_'s stack frame that are constant. */ sp = cu_$stack_frame_ptr (); /* Pointer to our stack frame. */ user_sp = sp -> stack_frame.prev_sp; /* Pointer to user's stack frame. */ /* Set fields in fio_ps. */ fio_ps.file_number = PS.file_number; /* Copy values from user ps to ours. */ string (fio_ps.job_bits) = string (PS.job_bits); fio_ps.element_p = null; /* Store a pointer to the label array goto used to enter this procedure and at the same time store a pointer to our stack frame. */ entry_point = 0; /* To initialize and insure correct address in next stmnt. */ /* By using a variable index, the optimizer treats all members */ /* of the label array as having been referenced here. */ fio_ps.label_for_transfer = label_for_entry (entry_point); fio_ps.address_of_index = addr (entry_point); /* So code in pl1_operators_ can find it. */ /* Update user's stack frame. */ user_sp -> sp_up_4 = sp -> sp_up_4; /* So user stack extension works around us. */ user_sp -> stack_frame.support_ptr = addr (fio_ps); /* store in stack frame at reserved location. */ substr (addr (user_sp -> stack_frame_flags.pl1_ps_ptr) -> based_bits, 1, 1) = "1"b; /* tell ops we're initialized. */ /* Initialize constant parts of our stack frame. */ column_one = 0; /* Set up the buffer segment. */ call get_buffer_ptr (create_if_not_found, exists);/* output value ignored */ ps_at_error = null; actual_error = 0; /* set the "interactive" bit */ call user_info_$process_type (process_type); if process_type = 1 then interactive = "1"b; else interactive = "0"b; end make_static_frame; initialize_fortran_io: procedure; /* the following table controls the operation performed in response to any given FORTRAN I/O statement. It embodies the logic to maintain the file table entry for each file reference number. */ /* format: off */ dcl control_matrix(0:14, 0:14) fixed bin int static options(constant) /* bounds depend on the domain of io_op */ initial ( /* Current P R E V I O U S O P E R A T I O N */ /* Z w o r r u c c b i o o m u e */ /* E r l e e n l l a n p p a n n */ /* R i d a w u o o c q e e r u d */ /* O t d i s s s k u n n g s f */ /* e e n e e e s i f i e i */ /* n d d f p r i n d l */ /* d _ i a e l _ e */ /* f 5 l c e 1 */ /* e e 3 */ /* ZERO */ 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, /* write */ 4, 3, 19, 3, 3, 19, 19, 19, 3, 19, 3, 3, 19, 19, 3, /* old endf */ 6, 6, 19, 6, 6, 19, 19, 19, 6, 19, 6, 6, 19, 19, 6, /* read */ 2, 5, 19, 1, 1, 19, 19, 19, 1, 19, 1, 1, 19, 19, 1, /* rewind */ 9, 9, 19, 9, 0, 19, 19, 19, 9, 19, 0, 9, 19, 19, 9, /* unused_5 */ 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, /* closefile */ 10, 10, 19, 10, 10, 19, 19, 19, 10, 19, 10, 10, 19, 19, 10, /* close */ 11, 11, 19, 11, 11, 19, 19, 19, 11, 19, 11, 11, 19, 19, 11, /* backspace */ 8, 8, 19, 8, 0, 19, 19, 19, 8, 19, 0, 8, 19, 19, 8, /* inquire */ 12, 12, 12, 12, 12, 19, 12, 12, 12, 12, 12, 12, 12, 19, 12, /* openfile */ 15, 15, 19, 15, 15, 19, 19, 19, 15, 19, 15, 15, 19, 19, 15, /* open */ 16, 16, 19, 16, 16, 19, 19, 19, 16, 19, 16, 16, 19, 19, 16, /* margin */ 17, 17, 19, 17, 17, 19, 19, 19, 17, 19, 17, 17, 19, 19, 17, /* unused_13 */ 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, /* endfile */ 7, 7, 19, 7, 7, 19, 19, 19, 7, 19, 7, 7, 19, 19, 7); /* format: on */ /* If this is not an inquire statement, get the unit reference number. */ if current ^= inquire_opr /* we may not know the unit number */ then do; if fio_ps.file_number >= 1 & fio_ps.file_number <= 99 then do; fcb_ptr = addr (fortran_buffer_.table (fio_ps.file_number)); iocb_ptr = file_desc.switch_p; if ^file_desc.connected /* in dfast, the file must be opened before it is used */ then if fast_related_data_$in_dfast then if current ^= open_opr & current ^= openfile_opr then do; k = file_desc.open_code; /* get the code that tells why the open failed */ file_desc.open_code = 0; /* next time just say it is closed */ if k = 0 then call print_error (fortran_io_error_$not_open); else call print_error (binary (unspec (file_desc.switch_p), 35), me, "Openfile failed."); end; end /* 1 <= file >= 99 */; else if fio_ps.file_number = 0 /* terminal I/O, encode/decode or internal-file */ then do; fcb_ptr = addr (fortran_buffer_.table (0)); file_desc.blank_null = fio_ps.ansi_77; if fio_ps.mode = string_io | fio_ps.mode = internal_file then return; file_desc.previous = open_opr;/* operations are never dependent on previous operation */ if current = read_opr then do; iocb_ptr, file_desc.switch_p = iox_$user_input; /* If user_input and user_output reference the same target, a read effectively outputs a newline character. Remember this fact. */ if iox_$user_input -> iocb.actual_iocb_ptr = iox_$user_output -> iocb.actual_iocb_ptr then fortran_buffer_.terminal_needs_newline = "0"b; end; else if current = write_opr then iocb_ptr, file_desc.switch_p = iox_$user_output; else if current ^= openfile_opr & current ^= open_opr then call print_error (fortran_io_error_$invalid_for_file0); end /* file = 0 */; else call print_error (error_table_$no_file); end /* not inquire */; /* file table entry is ready;perform appropriate actions */ if fio_ps.iostat_var then PS.iostat_p -> words (1) = 0; /* value if operation is successful */ /* for inquire operation, we may not know yet which file, and previous doesn't matter anyway */ if current = inquire_opr then goto action (12); else goto action (control_matrix (current, file_desc.previous)); /* The logic required to execute any user request is presented here. If the operation is a file positioning request, the code below should completely perform the request. For input and output transfers of data, various housekeeping steps are taken, and in the case of a user request for input, the first record is read. */ action (0): /* Rewind or backspace after rewind. */ /* Endfile on non-connected file */ return; /* The last operation was more final. Forget I ever called. */ action (2): /* Read, the first time the file is referenced. */ dcl unwritten_eofs fixed bin (3) unsigned; unwritten_eofs = file_desc.unwritten_eofs; call implicit_open; /* Open the file. */ file_desc.unwritten_eofs = unwritten_eofs; /* Implicit opening clears this field. */ action (1): /* Read a record from the designated file. */ buffer_pointer = addr (fortran_buffer_.buf); buffer_max_len = fortran_buffer_.maximum_buffer; call validate_mode_and_access; file_desc.previous = current; /* If this is the first call for a direct access read on a binary stream file, do nothing. The records will be read by the element transfer calls. */ if file_desc.type_of_io = binary_file & call_sw < 0 & fio_ps.list then return; /* A goto is used here instead of a call so that referencing read_a_record is not needed. Of course, I could have made read_a_record a separate procedure... */ goto read_a_record_label; action (4): /* Write, the first time the file is referenced. */ unwritten_eofs = file_desc.unwritten_eofs; call implicit_open; /* Open the file. */ file_desc.unwritten_eofs = unwritten_eofs; /* Implicit opening clears this field. */ action (3): /* An output transfer. Prepare the buffer for output. */ call validate_mode_and_access; buffer_pointer = addr (fortran_buffer_.buf); buffer_max_len = fortran_buffer_.maximum_buffer; /* If this is a deferred newline file without carriage control, output the first newline now. Moving the code here removes it from "write_a_record" which is an inner loop of fortran_io_. */ if file_desc.newline_needed & ^(file_desc.printer_file & file_desc.carriage_controllable) then do; column_one, buffer_length = 1; substr (io_buf, 1, 1) = NL; end; else buffer_length = 0; goto store_op_and_return; action (5): /* Read after write. */ call finish_line; /* Make sure the last line is completely written. */ if my_code ^= 0 then call print_error (my_code); go to action (1); action (19): /* impossible (current, previous) combination */ call print_error (fortran_io_error_$fio_sys_error, me, "File table entry is wrong."); action (10): /* closefile */ if ^fast_related_data_$in_dfast then goto not_supported; action (6): /* Close the file. (closefile, old endfile) */ call close_fortran_file; return; action (11): /* Close the file. (close) */ call close_statement; return; action (12): /* INQUIRE */ call inquire_statement; return; /* does no action, dont set op */ action (8): /* BACKSPACE. */ if file_desc.unwritten_eofs > 0 then file_desc.unwritten_eofs = file_desc.unwritten_eofs - 1; else if file_desc.switch_ready then do; if file_desc.connected then do; if ^file_desc.allow.positioning | iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io then call print_error (fortran_io_error_$cannot_position); call finish_line; if my_code ^= 0 then call print_error (my_code); end; call iox_$position (iocb_ptr, 0, -1, my_code); if my_code = error_table_$end_of_info then my_code = 0; /* We were at BOI. */ else if my_code ^= 0 then call iox_$control (iocb_ptr, "backspace_record", null, my_code); /* Try something else. */ if my_code ^= 0 then call print_error (fortran_io_error_$cannot_position); end; goto set_BOR_store_op_and_return; action (9): /* REWIND */ file_desc.unwritten_eofs = 0; /* Forget about any unwritten EOF records. */ if file_desc.switch_ready then do; if file_desc.connected then do; if ^file_desc.allow.positioning | iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io then call print_error (fortran_io_error_$cannot_position); call finish_line; if my_code ^= 0 then call print_error (my_code); end; call iox_$position (iocb_ptr, -1, 0, my_code); if my_code = error_table_$end_of_info then my_code = 0; /* File is empty. */ else if my_code ^= 0 then do; /* probably failed because not 'vfile_' */ call iox_$control (iocb_ptr, "rewind", null, my_code); if my_code ^= 0 /* probably failed because not 'tape_nstd_' */ then if file_desc.fortran_opened then do; call iox_$close (iocb_ptr, my_code); if my_code ^= 0 then call print_error (fortran_io_error_$cannot_position); file_desc.switch_ready = FALSE; file_desc.newline_needed = "0"b; file_desc.previous = 0; /* forces reopen on next data transfer */ return; /* must not execute usual exit code */ end; end; if my_code ^= 0 then call print_error (fortran_io_error_$cannot_position); end; set_BOR_store_op_and_return: /* current operation positions to Beginning Of a Record */ file_desc.newline_needed = "0"b; store_op_and_return: /* All logic, except closing a file, terminates here. */ if file_desc.connected then file_desc.previous = current; /* The operation type is stored for further use. */ else file_desc.previous = 0; /* Force subsequent READ or WRITE to open first. */ return; /* The implementation of ENDFILE is tricky for several reasons: */ /* */ /* (1) It can be applied to a file which is not connected, in which case we */ /* must perform an implicit association. We cannot perform an implicit */ /* connection via the 'implicit_open' routine, since we have no way to */ /* discover the form of the file. Moreover, we may not even be able to */ /* associate the file correctly, if the I/O module allows both stream */ /* and sequential openings. */ /* */ /* (2) The Standard says that ENDFILE must appear to produce a record as */ /* far as BACKSPACE is concerned. Thus we must keep a count of the */ /* "unwritten" EOF records for I/O modules that do not support EOF */ /* records (i.e. all standard I/O modules other than 'tape_nstd_'). */ /* */ /* (3) The Standard says that ENDFILE must alter the file so that only the */ /* records preceeding the ENDFILE are retained. This means that we */ /* must disallow ENDFILE if the I/O module does not support truncation, */ /* as is the case with 'tape_mult_' and 'tty_'. */ action (7): /* ENDFILE */ dcl switch_for_endfile char (6) aligned, unit_for_endfile pic "99"; if file_desc.unwritten_eofs > 0 then if file_desc.unwritten_eofs < Max_unwritten_eofs then file_desc.unwritten_eofs = file_desc.unwritten_eofs + 1; else call print_error (fortran_io_error_$cannot_truncate, me, "More than ^i successive ENDFILEs.", Max_unwritten_eofs); else do; /* Try to write or simulate an EOF record. */ if file_desc.connected then do; /* Check that ENDFILE is allowed. */ if ^file_desc.allow.positioning then call print_error (fortran_io_error_$cannot_truncate); if file_desc.out then do; call finish_line; if my_code ^= 0 then call print_error (my_code); end; else if file_desc.allow_reopen then call reopen_for_output; else call print_error (fortran_io_error_$cannot_truncate); end; else file_desc.out = TRUE; /* Ensure subsequent connection allows output. */ if ^file_desc.switch_ready then do; /* Implicitly associate the unit. */ unit_for_endfile = fio_ps.file_number; switch_for_endfile = "file" || unit_for_endfile; call iox_$find_iocb (switch_for_endfile, iocb_ptr, my_code); if my_code ^= 0 then call print_error (my_code, me, "Cannot get iocb for ^a.", switch_for_endfile); if iocb_ptr -> iocb.attach_descrip_ptr = null then do; /* Attach unit to disk file of same name as switch. */ call iox_$attach_iocb (iocb_ptr, "vfile_ " || switch_for_endfile, my_code); if my_code ^= 0 then call print_error (my_code, me, switch_for_endfile); file_desc.fortran_attached = TRUE; end; else if before (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, " ") = "tape_nstd_" then do; /* 'tape_nstd_' is special: it really has EOF records. */ file_desc.switch_ready = TRUE; /* Must maintain the association till connection. */ file_desc.eofs_are_records = TRUE; file_desc.switch_p = iocb_ptr; end; if iocb_ptr -> iocb.open_descrip_ptr = null then do; /* Open the unit for stream or sequential output. */ call iox_$open (iocb_ptr, 2, ""b, my_code); /* Try stream output. */ if my_code ^= 0 then call iox_$open (iocb_ptr, 5, ""b, my_code); /* Try sequential output. */ if my_code ^= 0 then call print_error (my_code, me, switch_for_endfile); file_desc.fortran_opened = TRUE; end; end; call iox_$control (iocb_ptr, "write_eof", null, my_code); if my_code ^= 0 then do; /* EOF records not supported -- try to simulate. */ if file_desc.previous ^= 1 then do; /* Truncate if last op not WRITE. */ call iox_$control (iocb_ptr, "truncate", null, my_code); if my_code ^= 0 then call print_error (fortran_io_error_$cannot_truncate); end; if fio_ps.ansi_77 then file_desc.unwritten_eofs = 1; end; if file_desc.fortran_opened & ^file_desc.switch_ready then do; /* Close the file in case we opened in wrong mode. */ call iox_$close (iocb_ptr, my_code); file_desc.fortran_opened = FALSE; end; end; goto set_BOR_store_op_and_return; action (15): /* openfile */ if ^fast_related_data_$in_dfast then goto not_supported; call dfast_openfile; goto store_op_and_return; action (16): /* open */ call open_statement; goto store_op_and_return; action (17): /* margin */ if ^fast_related_data_$in_dfast then goto not_supported; call set_max_recl (max_recl); return; /* use of margin is not recorded as previous operation */ not_supported: call ioa_$ioa_switch (iox_$error_output, "Warning: ^a (on file ^d) is not supported in Multics or FAST. The statement is ignored.", operation_name (current), fio_ps.file_number); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* These two entries are called by the various I/O processing entries to perform additional data transfers as required. read_a_record is called only if the input transfer requires more than one record. write_a_record must be called each time a record is to be output. */ read_a_record: entry; if fio_ps.mode = string_io | fio_ps.mode = internal_file then do; buffer_pointer = add_char_offset_ (buffer_pointer, char_offset); if fio_ps.mode = internal_file then do; /* Check for EOF. */ internal_file_count = internal_file_count - 1; if internal_file_count <= 0 then goto end_of_file; end; return; end; read_a_record_label: buffer_length = buffer_max_len; /* get maximum buffer length */ fio_ps.have_input = "0"b; /* record is undefined till after the read */ /* Position to record if required */ if fio_ps.mode = direct_access then call get_record (exists); /* output value is ignored */ /* Now, read */ if file_desc.type_of_io = stream_file then do; /* special processing for terminals */ if iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io then do; if interactive then fortran_buffer_.terminal_needs_newline = "0"b; /* output prompt_character if required */ if file_desc.prompt then do; call iox_$put_chars (iox_$user_io, addr (prompt_char), 2, my_code); if my_code ^= 0 then call print_error (my_code); end; end; call iox_$get_line (iocb_ptr, buffer_pointer, buffer_length, sent, my_code); /* remove newline from record if present */ if my_code = 0 then sent = sent - 1; else if my_code = error_table_$short_record /* record does not end with newline */ then my_code = 0; /* special end-of-file for formatted sequential stream files */ if file_desc.carriage_controllable then do; if sent = length (EOF1) then if substr (io_buf, 1, length (EOF1)) = EOF1 then goto end_of_file; else ; else if sent = length (EOF2) then if substr (io_buf, 1, length (EOF2)) = EOF2 then goto end_of_file; else if substr (io_buf, 1, length (EOF3)) = EOF3 then do; end_of_file: /* If user provided iostat var, set it; and if end= is not supplied then return. */ if fio_ps.ansi_77 then if my_code = error_table_$end_of_info & ^file_desc.eofs_are_records then if file_desc.unwritten_eofs = 0 then file_desc.unwritten_eofs = 1; /* Remember we hit EOI. */ else call print_error (fortran_io_error_$read_after_eof); if fio_ps.iostat_var then do; PS.iostat_p -> words (1) = -error_table_$end_of_info; /* Standard requires negative code for EOF. */ if ^fio_ps.end_label then goto return_error_code; end; if fio_ps.end_label /* return to user if end= specified */ then call return_to_user (PS.end_p, PS.stack_frame_p); /* Prevent err= transfer for EOF unless direct_access. */ if fio_ps.mode ^= direct_access then fio_ps.error_label = "0"b; fio_ps.have_input = "0"b; /* if EOF then nothing to print */ if fio_ps.mode = internal_file then call internal_file_overflow; else call print_error (error_table_$end_of_info); end; end; /* formatted end of file */ file_desc.newline_needed = "0"b; /* in case write follows */ end; else if file_desc.type_of_io = record_file | file_desc.type_of_io = blocked_file then do; call iox_$read_record (iocb_ptr, buffer_pointer, buffer_length, sent, my_code); end; else if file_desc.type_of_io = binary_file then do; /* If there is an I/O list, data is read directly from the device into each item on demand. If there is no list, one "record" (single word or double word) is read and discarded. */ if ^fio_ps.list then do; fio_ps.element_p = buffer_pointer; /* need a place to put data; it will be discarded */ if file_desc.double_word_file /* get default length */ then buffer_length = CPDW; else buffer_length = CPW; end; else if call_sw < 0 /* do nothing on first call if there is a list */ then do; buffer_length = 0; /* Nothing read. */ my_code = 0; /* No errors occurred. */ return; end; else do; /* get char len of item */ buffer_length = fio_ps.element_count; end; if ^fio_ps.element_desc.VLA then call iox_$get_chars (iocb_ptr, fio_ps.element_p, buffer_length, sent, my_code); else do; chars_left = 4 * pl1_operators_$VLA_words_per_seg_ - char_pos (fio_ps.element_p) + 1; if buffer_length <= chars_left then call iox_$get_chars (iocb_ptr, fio_ps.element_p, buffer_length, sent, my_code); else do; /* Target crosses into next VLA component. */ call iox_$get_chars (iocb_ptr, fio_ps.element_p, chars_left, sent, my_code); if my_code = 0 then do; call iox_$get_chars (iocb_ptr, baseptr (fixed (baseno (fio_ps.element_p)) + 1), buffer_length - chars_left, sent, my_code); sent = sent + chars_left; end; end; end; if my_code ^= 0 then if my_code = error_table_$short_record /* i.e., less data returned than requested. */ then goto end_of_file; /* Some data was not returned. */ end; if my_code ^= 0 then if my_code = error_table_$end_of_info then go to end_of_file; else call print_error (my_code); buffer_length = sent; fio_ps.have_input = fio_ps.format ^= unformatted; /* i.e., fmt, namelist, or list-dir */ return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* called to output a record to the I/O module. */ write_a_record: entry; /* NOTE - Some code directly relating to output has been moved to action(3) in the in the main body of this internal procedure. The code was moved so as to remove a test from the write loop. For internal_files, blank out remainder of record if the format is insufficiently long (buffer_length < buffer_max_len) and on terminate call (call_sw = 1), pad with blanks if there is any unflushed buffer. Decrement the internal_file_count each time, when it hits zero, set buffer_max_len to zero, so expand_buffer will prevent the writing of the next record, as it is impossible to know if the next reocrd is going to be written. We can detect an error if there has been an attemp to write a zero_length record, as internal_file_count will go negative. Do not make this check on terminate call. */ if fio_ps.mode = string_io | fio_ps.mode = internal_file then do; if fio_ps.mode = internal_file then do; if buffer_max_len > buffer_length then if call_sw < 1 | buffer_length > 0 then substr (buffer_pointer -> chars, buffer_length + 1, buffer_max_len - buffer_length) = SP; internal_file_count = internal_file_count - 1; if internal_file_count = 0 then buffer_max_len = -1; else if internal_file_count < 0 & call_sw <= 0 then call internal_file_overflow; end /* internal_file only */; buffer_length = 0; buffer_pointer = add_char_offset_ (buffer_pointer, char_offset); return; end; /* Check for WRITE after EOF record. */ if file_desc.unwritten_eofs > 0 then if ^file_desc.carriage_controllable then call print_error (fortran_io_error_$write_after_eof); else do; /* Write appropriate number of EOF records. */ call finish_line; if my_code ^= 0 then call print_error (my_code); do while (file_desc.unwritten_eofs > 0); call iox_$put_chars (iocb_ptr, addr (EOF1), length (EOF1), my_code); if my_code = 0 then call iox_$put_chars (iocb_ptr, addr (NL), length (NL), my_code); if my_code ^= 0 then call print_error (my_code); file_desc.unwritten_eofs = file_desc.unwritten_eofs - 1; end; end; /* Special processing for formatted records */ if file_desc.formatted_records then do; /* state of the terminal is maintained elsewhere; copy it. */ terminal_file = iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io; if terminal_file then do; file_desc.newline_needed = fortran_buffer_.terminal_needs_newline; fortran_buffer_.terminal_needs_newline = file_desc.defer_newline; end; /* IF REQUIRED, CONVERT CARRIAGE CONTROL CHAR TO SLEW CHAR OR ADD NEWLINE CHAR */ if file_desc.carriage_controllable /* ="1"b if file contain newline chars */ then if file_desc.printer_file /* File requires CC char conversion. */ then if column_one = buffer_length then do; /* a blank line */ if column_one = 0 & ^file_desc.newline_needed then if terminal_file then fortran_buffer_.terminal_needs_newline = "1"b; else file_desc.newline_needed = "1"b; else do; buffer_length = buffer_length + 1; substr (io_buf, buffer_length, 1) = NL; end; end; else if substr (io_buf, column_one + 1, 1) = SP /* Most common CC char. */ then goto single_space; else if substr (io_buf, column_one + 1, 1) = "0" then do; /* Double space. */ if column_one = 0 then if file_desc.newline_needed then do; /* first record, no need to move text. */ buffer_pointer = addr (fortran_buffer_.extra_char); buffer_length = buffer_length + 1; substr (io_buf, 1, 2) = two_NLs; end; else substr (io_buf, 1, 1) = NL; else do; if buffer_length - column_one - 1 > 0 /* i.e., text follows CC char */ then substr (io_buf, column_one + 3, buffer_length - column_one - 1) = copy ( substr (io_buf, column_one + 2, buffer_length - column_one - 1), 1); substr (io_buf, column_one + 1, 2) = two_NLs; buffer_length = buffer_length + 1; end; end; /* double space */ else if substr (io_buf, column_one + 1, 1) = "1" then do; /* Slew to top of next page. */ if column_one = 0 then if file_desc.newline_needed then do; /* first record, no need to move text. */ buffer_pointer = addr (fortran_buffer_.extra_char); buffer_length = buffer_length + 1; substr (io_buf, 1, 2) = NL_FF; end; else substr (io_buf, 1, 1) = FF; else do; if buffer_length - column_one - 1 > 0 /* i.e., text follows CC char */ then substr (io_buf, column_one + 3, buffer_length - column_one - 1) = copy ( substr (io_buf, column_one + 2, buffer_length - column_one - 1), 1); substr (io_buf, column_one + 1, 2) = NL_FF; buffer_length = buffer_length + 1; end; end; /* top of page */ else if substr (io_buf, column_one + 1, 1) = "+" then do; /* Overprint on previous record. */ if column_one = 0 & ^file_desc.newline_needed then do; /* too late, newline already printed */ buffer_length = buffer_length - 1; buffer_pointer = addr (substr (io_buf, 2, 1)); end; else substr (io_buf, column_one + 1, 1) = CR; end; /* overprint */ else do; /* Single space. */ single_space: if column_one = 0 & ^file_desc.newline_needed then do; buffer_length = buffer_length - 1; buffer_pointer = addr (substr (io_buf, 2, 1)); end; else substr (io_buf, column_one + 1, 1) = NL; end; /* single space */ /* Add newline for files without carriage control */ else do; if column_one = 0 & file_desc.newline_needed then do; buffer_length = buffer_length + 1; buffer_pointer = addr (fortran_buffer_.extra_char); fortran_buffer_.extra_char = NL; end; if call_sw <= 0 then do; substr (io_buf, buffer_length + 1, 1) = NL; buffer_length = buffer_length + 1; end; end; end; /* code for formatted records */ /* perform record positioning if required */ if fio_ps.mode = direct_access then do; call get_record (exists); end; else exists = "0"b; /* write the record */ if file_desc.type_of_io = stream_file then goto write_stream; else if file_desc.type_of_io = record_file then do; if file_desc.using_tape_nstd & (mod (buffer_length, 4) ^= 0) then do; new_buffer_length = buffer_length + 4 - mod (buffer_length, 4); /* pad with spaces for formatted records; pad with null bytes otherwise. */ if file_desc.formatted_records then substr (buffer, buffer_length + 1, new_buffer_length - buffer_length) = " "; else substr (buffer, buffer_length + 1, new_buffer_length - buffer_length) = low (1); buffer_length = new_buffer_length; end; if ^exists then call iox_$write_record (iocb_ptr, buffer_pointer, buffer_length, my_code); else call iox_$rewrite_record (iocb_ptr, buffer_pointer, buffer_length, my_code); buffer_length = 0; end; else if file_desc.type_of_io = blocked_file then do; if my_code = error_table_$end_of_info then call print_error (my_code); /* file probably attached without -no_end option */ call iox_$write_record (iocb_ptr, buffer_pointer, buffer_length, my_code); buffer_length = 0; if my_code = 0 & fio_ps.mode = sequential_access & file_desc.open_code = Sequential_update then call iox_$control (iocb_ptr, "truncate", null, my_code); end; else do; write_stream: if call_sw > 0 /* i.e., last call */ then do; /* If file contains newline chars, one more may be needed. */ if file_desc.carriage_controllable /* i.e., does file have newline chars? */ then if ^file_desc.defer_newline /* yes, and they are not deferred */ then if suppress_final_newline then ; else do; substr (io_buf, buffer_length + 1, 1) = NL; /* so put final newline char in */ buffer_length = buffer_length + 1; if terminal_file /* reset need for initial newline char */ then fortran_buffer_.terminal_needs_newline = "0"b; else file_desc.newline_needed = "0"b; end; else if ^file_desc.newline_needed then file_desc.newline_needed = "1"b; call iox_$put_chars (iocb_ptr, buffer_pointer, buffer_length, my_code); column_one = 0; end; else do; /* Write text later; just update virtual origin */ column_one = buffer_length; my_code = 0; /* "write call" was successful */ end; end; if my_code ^= 0 then call print_error (my_code); return; validate_mode_and_access: proc; /* compare mode and access of request to that of the file */ /* CHECK MODE - input or output */ if fio_ps.read then if ^file_desc.in then if ^file_desc.allow_reopen then call print_error (fortran_io_error_$cannot_read); else call reopen_for_input; else ; /* file is already open for input */ else if ^file_desc.out then if ^file_desc.allow_reopen then call print_error (fortran_io_error_$cannot_write); else call reopen_for_output; /* CHECK ACCESS - sequential or direct */ if fio_ps.mode = direct_access then if ^file_desc.allow.direct_access then call print_error (fortran_io_error_$not_direct); else ; /* file does support it */ else if ^file_desc.allow.seq_access then call print_error (fortran_io_error_$not_sequential); /* CHECK FORM - formatted or unformatted */ if fio_ps.format = unformatted then if file_desc.formatted_records then call print_error (fortran_io_error_$formatted_file); else ; /* they match */ else if ^file_desc.formatted_records then call print_error (fortran_io_error_$unformatted_file); end validate_mode_and_access; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_record: proc (record_found); dcl record_found bit (1) aligned; dcl record_key picture "99999999"; dcl record_length fixed bin (21); /* is record number in range ? */ if PS.record_number < 0 | PS.record_number > 99999999 then call print_error (error_table_$no_record); file_desc.last_rec = PS.record_number; record_found = "1"b; /* Reset only if I/O module cannot find the record. */ /* position the file. */ if file_desc.type_of_io = record_file then do; record_key = PS.record_number; /* convert number to character string */ call iox_$seek_key (iocb_ptr, (record_key), record_length, my_code); if my_code ^= 0 then if my_code = error_table_$no_record then record_found = "0"b; end; else if file_desc.type_of_io = blocked_file then do; /* vfile_ really should support a seek_key operation for blocked files. Since it doesn't, we must use record_status to locate a record for read (in order to tell us if a record has been deleted) and iox_$position for write (because record_status has a bug talking about records located by seek_key having been deleted by another opening). */ if fio_ps.read then do; rs_info_ptr = addr (info); unspec (rs_info) = "0"b; rs_info.version = rs_info_version_2; rs_info.flags.locate_pos_sw = "1"b; rs_info.record_length = PS.record_number; call iox_$control (iocb_ptr, "record_status", rs_info_ptr, my_code); if my_code ^= 0 then if my_code = error_table_$no_record | my_code = error_table_$asynch_deletion then record_found = "0"b; end; else do; call iox_$position (iocb_ptr, 2, (PS.record_number), my_code); if my_code ^= 0 then record_found = "0"b; end; end; else if file_desc.type_of_io = binary_file then do; call iox_$position (iocb_ptr, 2, PS.record_number * CPW, my_code); end; else do; /* double binary */ call iox_$position (iocb_ptr, 2, PS.record_number * CPDW, my_code); end; PS.record_number = PS.record_number + 1; if my_code ^= 0 then if fio_ps.read | record_found then do; /* Convert error code if it may not be helpful. */ if my_code = error_table_$no_record/* Record not found. */ then ; else if my_code = error_table_$end_of_info /* Record number is too large. */ then ; else if my_code = error_table_$asynch_deletion then my_code = error_table_$no_record; else my_code = fortran_io_error_$not_direct; /* Assume I/O module complained about order call. */ call print_error (my_code); end; end get_record; end initialize_fortran_io; set_max_recl: proc (maxl); dcl maxl fixed bin; info (1) = -1; /* vfile_ returns old value here */ info (2) = maxl; call iox_$control (iocb_ptr, "max_rec_len", addr (info), my_code); if my_code ^= 0 then if my_code ^= error_table_$no_operation then call print_error (fortran_io_error_$not_blocked); else if info (1) < 0 /* file does not have max rec len */ then call print_error (fortran_io_error_$not_blocked); else if info (1) ^= info (2) /* file is not empty or not open for output */ then if open_mode (file_desc.open_code).out then call print_error (fortran_io_error_$must_be_empty); else call print_error (fortran_io_error_$cannot_write, me, "A file must be opened for output in order to change its maximum record length."); else ; /* old recl is the same; therefore no operation */ end set_max_recl; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ strip_line_no: proc; /* Removes line no, a field of digits, from the beginning of a record */ dcl ln fixed bin; if length (rest_of_record) = 0 then ln_error: call print_error (fortran_io_error_$syntax_error, me, "No line number on this line."); ln = verify (rest_of_record, "0123456789") - 1; if ln < 0 /* all digits */ then do; buffer_index = buffer_index + length (rest_of_record); last = buffer_index; return; end; else if ln = 0 /* no digits */ then goto ln_error; buffer_index = buffer_index + (ln + 1); /* skip digits plus one character */ last = buffer_index; end strip_line_no; dfast_openfile: proc (); dcl filetypes char (36) int static options (constant) init ("ter pri str bin rec raw num dnu key "); in = divide (index (filetypes, translate (substr (filetype_ptr -> chars, 1, 3), lower_letters, capital_letters)) + 3, 4, 17, 0); if in = 0 then call print_error (fortran_io_error_$unknown_filetype, me, """^a""", substr (filetype_ptr -> chars, 1, 3)); if fio_ps.file_number = 0 then do; if in = 1 /* terminal */ then file_desc.printer_file = "0"b; else if in = 2 /* print */ then file_desc.printer_file = "1"b; else call print_error (fortran_io_error_$invalid_file0_type); return; end; if file_desc.connected then call close_fortran_file; unspec (fortran_open_data.specified) = "0"b; fortran_open_data.specified.attach_desc = "1"b; fortran_open_data.specified.form = "1"b; fortran_open_data.specified.mode = "1"b; fortran_open_data.specified.access = "1"b; fortran_open_data.specified.prompt = "1"b; fortran_open_data.specified.carriage = "1"b; fortran_open_data.specified.defer = "1"b; string (fortran_open_data.specified.direction) = "11"b; fortran_open_data.specified.dfast_openfile = "1"b; fortran_open_data.prompt = "0"b; fortran_open_data.carriage = "0"b; fortran_open_data.defer = "0"b; fortran_open_data.attach_desc.offset = 0; /* Build an attach description to support the desired file type. */ fortran_open_data.char_str = "vfile_ "; fortran_open_data.char_str = fortran_open_data.char_str || rtrim (substr (pathname_ptr -> chars, 1, PS.max_buffer)); goto convert_dfast_file (in); convert_dfast_file (1): /* terminal */ fortran_open_data.formatted_records = "1"b; fortran_open_data.char_str = fortran_open_data.char_str || " -append"; in = unstructured; goto finish_dfast_open; convert_dfast_file (2): /* print */ fortran_open_data.carriage = "1"b; fortran_open_data.formatted_records = "1"b; fortran_open_data.char_str = fortran_open_data.char_str || " -append"; in = unstructured; goto finish_dfast_open; convert_dfast_file (3): /* string */ fortran_open_data.direct_access = "1"b; fortran_open_data.formatted_records = "1"b; fortran_open_data.char_str = fortran_open_data.char_str || " -blocked 12"; in = blocked; goto finish_dfast_open; convert_dfast_file (4): /* binary */ fortran_open_data.direct_access = "1"b; fortran_open_data.char_str = fortran_open_data.char_str || " -blocked 12"; in = blocked; goto finish_dfast_open; convert_dfast_file (5): /* record */ fortran_open_data.char_str = fortran_open_data.char_str || " -append"; in = sequential; goto finish_dfast_open; convert_dfast_file (6): /* raw */ fortran_open_data.direct_access = "1"b; fortran_open_data.char_str = fortran_open_data.char_str || " -no_trunc"; in = binary_stream; goto finish_dfast_open; convert_dfast_file (7): /* numeric */ fortran_open_data.direct_access = "1"b; fortran_open_data.char_str = fortran_open_data.char_str || " -header 1"; in = binary_stream; goto finish_dfast_open; convert_dfast_file (8): /* dnumeric */ fortran_open_data.direct_access = "1"b; fortran_open_data.char_str = fortran_open_data.char_str || " -header 2"; in = binary_stream; goto finish_dfast_open; convert_dfast_file (9): /* keyed */ fortran_open_data.formatted_records = "1"b; in = indexed; finish_dfast_open: fortran_open_data.char_str = fortran_open_data.char_str || " -ssf"; fortran_open_data.attach_desc.length = length (fortran_open_data.char_str); call open_fortran_file (in); end dfast_openfile; open_statement: proc; /* code for open and close statements */ dcl allow_default bit (1) aligned; dcl desired_file_type fixed bin; dcl desired_type fixed bin; dcl erasable_file bit (1) aligned; dcl file picture "99"; dcl file_is_empty bit (1) aligned; dcl file_name (-1:6) char (12) int static options (constant) init ("undefined", "nonexistent", "unstructured", "sequential", "blocked", "indexed", "binary", "non vfile_"); dcl keep_status fixed bin; dcl fio_vfile_attach bit (1) aligned; dcl i fixed bin; dcl implicit_opening bit (1) aligned; dcl job_index fixed bin; dcl len fixed bin; dcl nstd_opening (13) fixed bin int static options (constant) init (1, 4, 8, 11, 6, 7, 5, 3, 2, 10, 9, 13, 12); dcl off fixed bin; dcl offset_for_direct_access fixed bin int static options (constant) init (2); dcl offset_for_out_mode fixed bin int static options (constant) init (4); dcl open_index fixed bin; dcl using_vfile bit (1) aligned; dcl 1 nstd aligned structure int static options (constant), 2 first (8) fixed bin (17) init (1, 2, 3, 3, 5, 5, 10, 10), 2 last (8) fixed bin (17) init (2, 2, 4, 4, 9, 7, 13, 13); /* format: off */ dcl file_type_matrix (-1:5, -1:5) fixed bin int static options (constant) init (/* desired actual */ /* und ^ex uns seq blo ind bin */ /* und */ 0, 0, 1, 2, 3, 4, 5, /* ^ex */ 0, 0, 1, 2, 3, 4, 5, /* uns */ 1, 1, 1, 2, 3, 4, 5, /* seq */ 2, 2, 2, 2, -1, -1, -1, /* blo */ 3, 3, -1, -1, 3, -1, -1, /* ind */ 4, 4, -1, -1, -1, 4, -1, /* bin */ 5, 5, 5, -1, -1, -1, 5); dcl opening (8, 0:5) fixed bin int static options (constant) /* bounds depend on job_index and file_type */ init (/* n u s b i b */ /* o n e l n i */ /* n s q o d n */ /* e t u c e a */ /* x r e k x r */ /* i u n e e y */ /* s c t d d */ /* in seq fmt */ 1, 1, 4, 4, 4, 0, /* in seq unf */ 4, 0, 4, 4, 4, 1, /* in D/A fmt */ 8, 0, 0, 4, 8, 0, /* in D/A unf */ 8, 0, 0, 4, 8, 1, /* out seq fmt */ 3, 3, 6, 7, 0, 0, /* out seq unf */ 6, 0, 6, 7, 0, 3, /* out D/A fmt */ 10, 0, 0, 7, 10, 0, /* out D/A unf */ 10, 0, 0, 7, 10, 3); /* format: on */ /* procedure to open a fortran file regardless how the open is requested. Currently, there are three methods, implicitly by a read or write statement, explicitly by the open statement, and explicitly by the dfast openfile statement. */ /* open statement */ /* PROCESS FIELDS SUPPLIED BY THE USER */ if fortran_open_data.specified.status then do; call convert_from_character (status_field, open_status_values, i); fortran_open_data.file_status = i - 1; end; else fortran_open_data.file_status = unknown_file;/* default value */ if fortran_open_data.specified.mode then do; call convert_from_character (mode_field, open_mode_values, i); if i = 1 /* value is "in" */ then string (fortran_open_data.direction) = "10"b; else if i = 2 /* value is out */ then string (fortran_open_data.direction) = "01"b; else string (fortran_open_data.direction) = "11"b; /* inout */ end; else string (fortran_open_data.direction) = "11"b;/* default is "inout" */ if fortran_open_data.specified.access then do; call convert_from_character (access_field, open_access_values, i); if i = 2 /* 1 is sequential, 2 direct */ then fortran_open_data.direct_access = "1"b; end; if fortran_open_data.specified.form then do; call convert_from_character (form_field, open_form_values, i); if i = 1 /* 1 is formatted, 2 unformatted */ then fortran_open_data.formatted_records = "1"b; end; if fortran_open_data.specified.blank then do; call convert_from_character (blank_field, open_blank_values, i); fortran_open_data.blank_null = (i = 1); /* 1 is null , 2 zero */ end; else fortran_open_data.blank_null = fio_ps.ansi_77; /* default to zero iff ansi66 */ /* CHECK open statement conflicts */ if fortran_open_data.specified.recl & fortran_open_data.specified.binary & fortran_open_data.binary then call print_error (fortran_io_error_$open_attr_conflict, me, "Binary stream and recl."); if fortran_open_data.specified.filename then do; if fortran_open_data.specified.attach_desc then call print_error (fortran_io_error_$open_attr_conflict, me, "Attach and file."); call exists_file (exists_file_code); if exists_file_code = 1 then call print_error (error_table_$pathlong, me, "A filename may not be longer than 168 characters.") ; else if exists_file_code = 2 then call print_error (fortran_io_error_$open_attr_incomplete, me, "A non-blank filename is required."); end; /* The STATUS= specifier is ignored in ansi66 program units. */ if fio_ps.ansi_77 then do; /* If status = "scratch", no "file=" specifier can be used. */ if fortran_open_data.specified.filename & fortran_open_data.file_status = scratch_file then call print_error (fortran_io_error_$open_attr_conflict, me, "File and status = ""scratch""."); /* If status = "old", a "file=" specifier must be present in the open statement and the named file must exist. */ if fortran_open_data.file_status = old_file then do; if ^fortran_open_data.specified.filename then call print_error (fortran_io_error_$open_attr_incomplete, me, "A filename is required for status = ""old""."); else if exists_file_code = 3 then call print_error (error_table_$noentry, me, "The file must exist if status = ""old"".") ; end; /* If status = "new", a "file=" specifier must be present in the open statment, but the named file cannot exist already. */ else if fortran_open_data.file_status = new_file then do; if ^fortran_open_data.specified.filename then call print_error (fortran_io_error_$open_attr_incomplete, me, "A filename is required for status = ""new""."); else if exists_file_code = 0 then call print_error (fortran_io_error_$status_field_error, me, "The file must not exist if status = ""new""."); end; /* If status = "append", the access control must be "sequential", no attach description may be present, no io_switch name may be present. */ else if fortran_open_data.file_status = append_file then do; if fortran_open_data.direct_access then call print_error (fortran_io_error_$open_attr_conflict, me, "Access = ""direct"" and status = ""append""."); if fortran_open_data.specified.binary & fortran_open_data.binary then call print_error (fortran_io_error_$open_attr_conflict, me, "Binary stream and status = ""append""."); if fortran_open_data.specified.attach_desc then call print_error (fortran_io_error_$open_attr_conflict, me, "Attach and status = ""append""."); if fortran_open_data.specified.io_switch then call print_error (fortran_io_error_$open_attr_conflict, me, "Ioswitch and status = ""append""."); end; end; desired_file_type = undefined; implicit_opening = "0"b; goto open_common; implicit_open: entry; unspec (fortran_open_data.specified) = "0"b; fortran_open_data.specified.form = "1"b; fortran_open_data.specified.mode = "1"b; fortran_open_data.specified.access = "1"b; fortran_open_data.direction.out = file_desc.direction.out; /* Sets 'out' if an ENDFILE has occurred. */ if fio_ps.read then fortran_open_data.direction.in = "1"b; else fortran_open_data.direction.out = "1"b; if fio_ps.mode = direct_access then fortran_open_data.direct_access = "1"b; if fio_ps.format ^= unformatted then fortran_open_data.formatted_records = "1"b; desired_file_type = undefined; implicit_opening = "1"b; goto open_common; open_fortran_file: entry (desired_type); desired_file_type = desired_type; /* caller supplies desired type */ implicit_opening = "0"b; open_common: if implicit_opening /* already done for open statement */ then fortran_open_data.blank_null = fio_ps.ansi_77; if fio_ps.file_number = 0 /* Process file 0 separately. */ then do; if fortran_open_data.specified.status | fortran_open_data.specified.io_switch | fortran_open_data.specified.attach_desc | fortran_open_data.specified.filename | fortran_open_data.specified.mode | fortran_open_data.specified.access | fortran_open_data.specified.form | fortran_open_data.specified.recl | fortran_open_data.specified.binary then do; call print_error (fortran_io_error_$invalid_file0_attr); return; end; if fortran_open_data.specified.prompt then file_desc.prompt = fortran_open_data.prompt; if fortran_open_data.specified.carriage then file_desc.printer_file = fortran_open_data.carriage; if fortran_open_data.specified.defer then file_desc.defer_newline = fortran_open_data.defer; file_desc.blank_null = fortran_open_data.blank_null; return; end; /* file 0 */ /* begin open code */ file = fio_ps.file_number; /* convert file number to character in case is needed */ uns_info.type = undefined; /* to prevent erroneous use of the structure */ erasable_file, /* accumulates the condition: attached and opened by FIO */ file_is_empty, /* Assume a non-empty file. */ using_vfile, /* Assume I/O switch is not vfile_. */ fio_vfile_attach = "0"b; /* ="1"b if fio creates a vfile_ attach desc */ fortran_buffer_.all_files_closed = "0"b; /* file table is modified */ /* SET FILE TYPE ATTRIBUTES AS REQUIRED */ if fortran_open_data.specified.recl then desired_file_type = blocked; if fortran_open_data.specified.binary & fortran_open_data.binary then desired_file_type = binary_stream; /* FILE IS NOT CONNECTED; CONNECT IT */ if ^file_desc.connected then do; /* file is not connected yet */ /* File may be partially connected if last connection failed; it must be disconnected. */ call close_fortran_file; /* disconnects partially open file and zeros table entry */ /* GET IOCB NAME AND THEN IOCB PTR */ if fortran_open_data.specified.io_switch then do; call get_open_field (io_switch_field, off, len); if len > length (ioname) then call print_error (field_error (io_switch_field), me, "I/O switch name is longer than ^d characters.", length (ioname)); else if len < 1 then call print_error (field_error (io_switch_field), me, "I/O switch name must be non-blank."); ioname = substr (fortran_open_data.char_str, off + 1, len); end; else do; /* use default I/O switch name */ ioname = "file"; substr (ioname, 5, 2) = file; end; call iox_$find_iocb (ioname, iocb_ptr, my_code); /* get iocb pointer */ if my_code ^= 0 then do; call print_error (my_code, me, "Cannot get iocb for ^a.", ioname); return; end; file_desc.switch_p = iocb_ptr; /* Save in table for future use */ /* FILE IS NOT ATTACHED; ATTACH IT */ if iocb_ptr -> iocb.attach_descrip_ptr = null then do; /* the following determines if default attachment is possible */ allow_default = ^fortran_open_data.specified.io_switch /* attach and file also not allowed */ & ^fortran_open_data.direct_access & fortran_open_data.formatted_records & string (fortran_open_data.direction) ^= "11"b & (desired_file_type = undefined); /* CHOOSE AN ATTACH DESCRIPTION */ if fortran_open_data.specified.attach_desc /* CASE: user supplies attach desc */ then do; call get_open_field (attach_desc_field, off, attach_desc_len); if attach_desc_len > length (attachment) then call print_error (field_error (attach_desc_field), me, "Attach description is longer than ^d characters.", length (attachment)) ; else if attach_desc_len < 1 then call print_error (field_error (attach_desc_field), me, "Attach description must be non-blank."); attachment = substr (fortran_open_data.char_str, off + 1, attach_desc_len); end; else if fortran_open_data.specified.filename /* CASE: user supplies filename */ then do; call get_open_field (filename_field, off, len); if len > length (attachment) - 7 then call print_error (field_error (filename_field), me, "File name is longer than ^d characters.", length (attachment) - 7); else if len < 1 then call print_error (field_error (filename_field), me, "File name must be non-blank."); substr (attachment, 1, 7) = "vfile_ "; substr (attachment, 8) = substr (fortran_open_data.char_str, off + 1, len); attach_desc_len = len + 7; using_vfile = "1"b; /* I/O module is vfile_ */ end; /* CASE: default input */ else if allow_default & file_desc.default_input & fortran_open_data.in then do; /* file is default input */ attachment = "syn_ user_input -inhibit put_chars"; attach_desc_len = 34; uns_info.type = unstructured; implicit_opening = "0"b; /* KLUDGE - prevents mode from being input/output */ end; /* CASE: default output */ else if allow_default & file_desc.default_output & fortran_open_data.out then do; /* file is default output */ attachment = "syn_ user_output -inhibit get_line get_chars"; attach_desc_len = 44; uns_info.type = unstructured; implicit_opening = "0"b; /* KLUDGE - prevents mode from being input/output */ end; /* CASE: status = "scratch" */ else if fortran_open_data.file_status = scratch_file then do; attachment = "vfile_ " || rtrim (get_pdir_ ()) || ">file" || file || "." || unique_chars_ (""b); /* attach_desc_len is found after the SECOND blank, the first is after "vfile_" */ attach_desc_len = index (substr (attachment, 8), SP) - 1; attach_desc_len = 7 + attach_desc_len; using_vfile = TRUE; end; /* CASE: FORTRAN I/O attachment */ else do; attachment = "vfile_ file"; substr (attachment, 12, 2) = file; attach_desc_len = 13; using_vfile = "1"b; /* I/O module is vfile_ */ end; /* ADD NECESSARY ATTACH CONTROL ARGUMENTS TO FORTRAN I/O'S VFILE_ ATTACHMENT */ if ^fortran_open_data.specified.attach_desc & using_vfile then do; fio_vfile_attach = "1"b; /* this is a fio created vfile_ attach desc */ /* Attach control arguments for vfile_ blocked files. */ if fortran_open_data.specified.recl then do; call add_attach_option ("-no_end"); /* Any record number is valid at any time. */ /* add "-blocked n" to force the file type */ call add_attach_option ("-blocked"); int_pic = fortran_open_data.max_rec_len; /* convert binary to char */ call add_attach_option ((int_pic)); end; /* Attach control arguments for vfile_ binary stream files. */ if desired_file_type = binary_stream then do; call add_attach_option ("-no_trunc"); /* prevents write from truncating */ call add_attach_option ("-no_end"); /* Any record number is valid at any time. */ end; /* If opening for output and file is not binary stream, add "-extend". */ else if fortran_open_data.out then do; call add_attach_option ("-extend"); file_desc.rewind_on_open = "1"b; end; end; /* code to add attach control arguments */ /* ATTACH THE FILE */ call iox_$attach_iocb (iocb_ptr, attachment, my_code); if my_code ^= 0 then do; call print_error (my_code); return; end; file_desc.fortran_attached = "1"b; end; /* code to attach a file */ /* FILE TYPE IS UNKNOWN; CALCULATE IT */ if uns_info.type = undefined then if substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 7) = "vfile_ " then do; using_vfile, erasable_file = "1"b; /* I/O module is vfile_ */ uns_info.info_version = vfs_version_1; call iox_$control (iocb_ptr, "file_status", addr (info), my_code); call process_vfile_status (/* file_type */); /* If file is attached by fortran I/O using an attach description created by fortran I/O, check that the correct attach description was generated. Fix it if it isn't. Currently this code is only executed if the target file is blocked or binary stream and the user did not specify the appropriate attribute in the open statement. */ if fio_vfile_attach then if uns_info.type = blocked & desired_file_type ^= blocked then do; call iox_$detach_iocb (iocb_ptr, my_code); call add_attach_option ("-no_end"); call iox_$attach_iocb (iocb_ptr, attachment, my_code); if my_code ^= 0 then call print_error (my_code); end; else if uns_info.type = binary_stream & desired_file_type ^= binary_stream then do; call iox_$detach_iocb (iocb_ptr, my_code); call add_attach_option ("-no_trunc"); call add_attach_option ("-no_end"); call iox_$attach_iocb (iocb_ptr, attachment, my_code); if my_code ^= 0 then call print_error (my_code); end; end; /* non vfile_ cases */ else if iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io then uns_info.type = unstructured; else if substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 11) = "tape_mult_ " then do; uns_info.type = binary_stream; uns_info.header_present = "0"b; end; else if substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 11) = "tape_nstd_ " then file_desc.using_tape_nstd = "1"b; /* IS DESIRED FILE TYPE COMPATIBLE WITH ACTUAL FILE TYPE? */ if ^fortran_open_data.dfast_openfile /* dfast ignores actual file type */ then do; if file_type_matrix (desired_file_type, uns_info.type) = undefined then do; call print_error (fortran_io_error_$incompatible_opening, me, "^/Existing file is a ^a file, but opening requires a ^a file.", file_name (uns_info.type), file_name (desired_file_type)); return; end; else desired_file_type = file_type_matrix (desired_file_type, uns_info.type); end; /* FILE IS NOT OPEN; OPEN IT */ if iocb_ptr -> iocb.open_descrip_ptr = null /* file is closed, open it */ then do; /* DETERMINE REQUEST TYPE */ /* formatted or unformatted */ if fortran_open_data.specified.form then if fortran_open_data.formatted_records then job_index = 1; else job_index = 2; else if fio_ps.ansi_77 & ^fortran_open_data.direct_access then job_index = 1; else job_index = 2; if fortran_open_data.direct_access /* direct or sequential */ then job_index = job_index + offset_for_direct_access; /* INPUT / OUTPUT -- in and inout are considered input, except for the case of inout and the file is empty or the file is not empty and fio created the attach desc, then inout is treated as output. This is done to protect vfiles from accidental truncation. If the attachment is not to a vfile and the mode is output, we treat this as output no matter what. */ if fortran_open_data.out & (file_is_empty | fio_vfile_attach | (^using_vfile & ^fortran_open_data.in)) then job_index = job_index + offset_for_out_mode; /* VFILE_ OPENING */ if using_vfile then do; open_index = opening (job_index, desired_file_type); if open_index = 0 then if job_index > offset_for_out_mode /* an output opening */ & ^fortran_open_data.specified.mode /* but OUT not explicitly requested */ & opening (job_index - offset_for_out_mode, desired_file_type) ^= 0 /* and IN is ok */ then do; job_index = job_index - offset_for_out_mode; /* change to input only opening */ open_index = opening (job_index, desired_file_type); end; else do; /* attributes conflict with existing file */ call print_error (fortran_io_error_$incompatible_opening, me, "A ^a file.", file_name (desired_file_type)); return; end; call iox_$open (iocb_ptr, open_index, "0"b, my_code); if my_code ^= 0 then do; /* Opening can fail because of no write access. If so, try input only. */ if my_code = error_table_$moderr /* insufficient access */ then if job_index > offset_for_out_mode /* and attempted output opening */ then if ^fortran_open_data.specified.mode /* and no explicit mode */ then if opening (job_index - offset_for_out_mode, desired_file_type) ^= 0 /* and IN is ok */ then do; job_index = job_index - offset_for_out_mode; open_index = opening (job_index, desired_file_type); call iox_$open (iocb_ptr, open_index, "0"b, my_code); end; if my_code ^= 0 then call print_error (my_code); end; /* Some attach/open combinations position at the end of the file; if rewind_on_open is true, position at the beginning of the file. */ if file_desc.rewind_on_open then do; call iox_$position (iocb_ptr, -1, 0, my_code); if my_code ^= 0 then call print_error (my_code); end; /* In ANSI 77 program units, if status = "append" in the open statement, position the file pointer to the end of the file. */ if fio_ps.ansi_77 then do; if fortran_open_data.file_status = append_file then do; call iox_$position (iocb_ptr, +1, 0, my_code); if my_code ^= 0 then call print_error (my_code); end; end; end; /* vfile opening */ /* NON VFILE_ BINARY FILE - tape_mult_ */ else if desired_file_type = binary_stream then do; if fortran_open_data.out then open_index = 2;/* stream_output */ else open_index = 1;/* stream_input */ call iox_$open (iocb_ptr, open_index, "0"b, my_code); if my_code ^= 0 then call print_error (my_code); end; /* UNKNOWN FILE TYPE, OPENING WILL DEFINE TYPE OF I/O */ else do; retry_non_vfile_opening: my_code = 1; do i = nstd (job_index).first to nstd (job_index).last while (my_code ^= 0); open_index = nstd_opening (i); call iox_$open (iocb_ptr, open_index, "0"b, my_code); if my_code ^= 0 then if my_code = error_table_$moderr /* error is insufficient access */ then if job_index > offset_for_out_mode /* and attempted output opening */ then if ^fortran_open_data.specified.mode /* and no explicit mode */ then do; /* so try an input opening; only possible once */ job_index = job_index - offset_for_out_mode; goto retry_non_vfile_opening; end; end; if my_code ^= 0 then call print_error (my_code, me, "Cannot open."); end; /* non vfile_ opening */ file_desc.fortran_opened = "1"b; end; /* code to open the file */ /* FILE IS OPEN; DETERMINE TYPE OF I/O IF UNKNOWN */ else do; /* determine opening mode used */ text_pt = iocb_ptr -> iocb.open_descrip_ptr; /* point to open descrip */ i = length (before (text_pt -> b_var_str, " ")); /* get open mode length */ do open_index = 1 to hbound (iox_modes, 1) while (substr (text_pt -> b_var_str, 1, i) ^= iox_modes (open_index)); end; /* If it is a non-standard open desc, see if we know about it. */ if open_index > hbound (iox_modes, 1) then if substr (text_pt -> b_var_str, 1, 18) = "IOS compatability " then open_index = 3; /* stream_input_output */ else do; call print_error (fortran_io_error_$fio_sys_error, me, "Unrecognized opening. ""^a""", text_pt -> b_var_str); return; end; end; /* not opened by fortran */ file_desc.open_code = open_index; file_desc.switch_ready = TRUE; if before (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, " ") = "tape_nstd_" then file_desc.eofs_are_records = TRUE; /* An EOF is a physical record. */ /* STORE ATTRIBUTES INTO FILE TABLE ENTRY */ /* type of I/O -- how to read, write, and position the file */ if desired_file_type = binary_stream then do; file_desc.type_of_io = binary_file; if uns_info.type = binary_stream & uns_info.header_present & uns_info.header_id = 2 then file_desc.double_word_file = "1"b; end; else if desired_file_type = blocked then file_desc.type_of_io = blocked_file; else file_desc.type_of_io = open_mode (open_index).io_type; /* Set allow_delete if and only if a) I/O switch is attached by FIO, b) I/O switch is opened by FIO, c) I/O switch is vfile_. */ if erasable_file then if file_desc.fortran_attached & file_desc.fortran_opened then file_desc.allow_delete = "1"b; call merge_attributes; /* must precede assignment to file_desc.connected */ file_desc.connected = "1"b; end; /* code to connect a file */ /* FILE IS CONNECTED; UPDATE ITS FILE TABLE ENTRY */ else do; /* If I/O switch is open, this is a normal open to a connected file. */ if iocb_ptr -> iocb.open_descrip_ptr ^= null then do; using_vfile = substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 7) = "vfile_ "; call merge_attributes; end; /* I/O switch is closed. this must be an implicit opening */ else if ^implicit_opening /* i.e. - not caused by a data transfer */ then call print_error (fortran_io_error_$fio_sys_error); /* Open file. Use new opening mode only if allowed by user and necessary. */ else if ((string (open_mode (file_desc.open_code).direction) /* compare previous opening mode */ & string (fortran_open_data.direction)) ^= "0"b) /* to desired one; nonzero means compatible */ | ^file_desc.allow_reopen /* unchangable */ then do; /* Old one is unchangable or compatible; use it */ call iox_$open (iocb_ptr, (file_desc.open_code), "0"b, my_code); if my_code ^= 0 then call print_error (my_code); end; /* Must reopen the file. */ else if fortran_open_data.in then call reopen_for_input; else call reopen_for_output; end; /* code to process connected file */ /* Set previous as open in case I/O transmission fails. */ file_desc.previous = open_opr; /* save trouble of reopening later */ return; /* code for open statement */ /* CODE FOR CLOSE STATEMENT */ close_statement: entry; /* If user gives status specifer, use it; otherwise the default is "keep". keep_status = 1 is "keep", 2 is "delete" */ if fortran_open_data.specified.status then call convert_from_character (status_field, close_status_values, keep_status); else keep_status = 1; erasable_file = file_desc.allow_delete; /* Copy values because close_fortran_file zeros them */ if (keep_status = 2 & erasable_file) | file_desc.file_status = scratch_file then call save_attach_desc (attachment); call close_fortran_file; /* close the file first */ /* If file is to be deleted, delete it now. */ if file_desc.file_status = scratch_file then do; if fortran_open_data.specified.status & keep_status = 1 /* user wants to keep */ then call print_error (fortran_io_error_$close_attr_error, me, "Cannot keep scratch file associated with unit number ^d.", fio_ps.file_number); else do; call delete_file (attachment, fio_ps.file_number); file_desc.has_been_deleted = TRUE; end; end; else if keep_status = 2 then do; if ^erasable_file /* FIO does not have access to delete */ then call print_error (fortran_io_error_$not_scratch_file, me, "Cannot delete file associated with unit number ^d.", fio_ps.file_number); else do; call delete_file (attachment, fio_ps.file_number); file_desc.has_been_deleted = TRUE; end; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ add_attach_option: proc (a_str); dcl a_str char (256) varying; if attach_desc_len + length (a_str) + 1 > length (attachment) then do; call print_error (fortran_io_error_$fio_sys_error, me, "Generated attach description is too long."); return; end; substr (attachment, attach_desc_len + 2, length (a_str)) = a_str; attach_desc_len = attach_desc_len + length (a_str) + 1; end add_attach_option; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_vfile_status: procedure (/* file_type */); if my_code = 0 then if uns_info.info_version ^= vfs_version_1 then do; call print_error (fortran_io_error_$fio_sys_error, me, "Wrong vfs version."); return; end; else do; if uns_info.end_pos = 0 then file_is_empty = "1"b; if uns_info.type = unstructured then do; if uns_info.header_present then uns_info.type = binary_stream; else if iocb_ptr -> iocb.attach_descrip_ptr ^= null then call check_attach_options; /* attach options change file type */ if uns_info.end_pos = 0 & uns_info.type = unstructured /* zero length segment */ then uns_info.type = nonexistent; end; end; /* vfile files */ else if my_code = error_table_$noentry /* file does not exist, but may be attached */ then do; uns_info.type = nonexistent; file_is_empty = "1"b; /* File is obviously empty. */ if iocb_ptr -> iocb.attach_descrip_ptr ^= null then call check_attach_options; /* attach options specify file type */ end; else do; call print_error (my_code); /* error from vfile status */ return; end; /* END OF process_vfile_status CODE */ check_attach_options: proc; /* converts attach options to file type */ dcl adp ptr; /* attach description pointer */ adp = iocb_ptr -> iocb.attach_descrip_ptr; if index (adp -> b_var_str, "-blocked") ^= 0 then uns_info.type = blocked; end check_attach_options; end process_vfile_status; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ merge_attributes: proc; dcl (actual_mode, desired_mode) bit (2) aligned; if fortran_open_data.dfast_openfile then if file_desc.connected | ^file_desc.fortran_attached | ^file_desc.fortran_opened then do; call print_error (fortran_io_error_$fio_sys_error, me, "Connected attached, or opened in dfast.") ; return; end; /* THE FOLLOWING ARE ERRORS IF FILE IS ALREADY CONNECTED */ if file_desc.connected then if fortran_open_data.specified.status then call print_error (fortran_io_error_$already_connected, me, "File status."); else if fortran_open_data.specified.io_switch then call print_error (fortran_io_error_$already_connected, me, "I/O switch name."); else if fortran_open_data.specified.form then call print_error (fortran_io_error_$already_connected, me, "Format attribute (form)."); else if fortran_open_data.specified.binary then call print_error (fortran_io_error_$already_connected, me, "Binary stream attribute."); /* ERRORS IF CONNECTED OR NOT ATTACHED BY FORTRAN */ if file_desc.connected | ^file_desc.fortran_attached then do; if fortran_open_data.specified.attach_desc then do; call print_error (fortran_io_error_$already_opened, me, "Attach description."); return; end; if fortran_open_data.specified.filename then do; call print_error (fortran_io_error_$already_opened, me, "Filename."); return; end; end; /* MODE - in, out, inout. Set only if explicitly specified or if file is being connected. "file_desc.allow_reopen" is set at the same time and allows reopening the file if the file opening does not support a specific data transfer. This attribute is set if and only if the following conditions are met: 1) FIOS opens the I/O module during connection; 2) the most recent mode specified for the file is "inout", or the file was connected implicitly as a result of a read or write, or a mode has never been specified for this file. */ if ^file_desc.connected | fortran_open_data.specified.mode then do; actual_mode = string (open_mode (file_desc.open_code).direction); /* what file opening supports */ desired_mode = string (fortran_open_data.direction); /* what user wants */ file_desc.allow_reopen = ((desired_mode = "11"b) | implicit_opening) & file_desc.fortran_opened; if file_desc.allow_reopen /* no need to fix now, can do it any time */ then string (file_desc.direction) = actual_mode; else if file_desc.fortran_opened /* reopen if necessary for new mode */ then do; /* At this point it is known that "desired_mode" cannot be "11"b or "00"b. Therefore, the following tests for any incompatibility between the actual and desired opening */ if (actual_mode & desired_mode) = "0"b /* nothing in common, so reopen */ then if fortran_open_data.direction.in then call reopen_for_input; else call reopen_for_output; string (file_desc.direction) = desired_mode; /* limit mode to that requested by user */ end; /* Cannot reopen at all; actual and desired modes must be compatible */ else do; /* test for incompatible (=0), or usemore than there is */ if ((actual_mode & desired_mode) = "0"b) | (((actual_mode & desired_mode) ^= desired_mode) & fortran_open_data.specified.mode) then if ^fortran_open_data.direction.in /* tell him what he can't have */ then call print_error (fortran_io_error_$wrong_mode, me, "Requested mode is ""input""."); else call print_error (fortran_io_error_$wrong_mode, me, "Requested mode is ""output""."); if implicit_opening | ^fortran_open_data.specified.mode then string (file_desc.direction) = actual_mode; else string (file_desc.direction) = desired_mode; end; end; /* code to set mode */ open_index = file_desc.open_code; /* copy for use later on */ /* SET FORM - formatted or unformatted. Note that in '66 mode the default */ /* is always unformatted, while in '77 mode the default is formatted unless */ /* the access is direct. */ if fortran_open_data.specified.form then file_desc.formatted_records = fortran_open_data.formatted_records; else if ^file_desc.connected then if fio_ps.ansi_77 then if fortran_open_data.specified.access then file_desc.formatted_records = ^fortran_open_data.direct_access; else file_desc.formatted_records = TRUE; else file_desc.formatted_records = FALSE; /* SET ACCESS - allow/prohibit positioning, seq access, direct access */ if ^file_desc.connected | fortran_open_data.specified.access then if fortran_open_data.direct_access then do; file_desc.allow.direct_access = "1"b; file_desc.allow.positioning, file_desc.allow.seq_access = file_desc.type_of_io = blocked_file | file_desc.type_of_io = binary_file; /* These file types allow both sequential and direct access. */ end; else do; file_desc.allow.positioning = "1"b; file_desc.allow.direct_access = "0"b; file_desc.allow.seq_access = "1"b; end; /* CHECK FILE TYPE AND FORM */ if file_desc.formatted_records then if file_desc.type_of_io = binary_file then call print_error (fortran_io_error_$incompatible_opening, me, "Formatted opening for a binary file."); else ; else if file_desc.type_of_io = stream_file then call print_error (fortran_io_error_$incompatible_opening, me, "Unformatted opening for a stream file."); /* SET CARRIAGE - whether or not carriage control can be applied to the file */ file_desc.carriage_controllable = ^file_desc.allow.direct_access /* seq access only */ & file_desc.formatted_records /* formatted file */ & file_desc.type_of_io = stream_file; /* terminal or unstructured */ /* SET maximum record length and using_vfile */ if fortran_open_data.specified.recl & using_vfile then call set_max_recl (fortran_open_data.max_rec_len); file_desc.using_vfile = using_vfile; /* SET and CHECK blank attribute and file_status */ file_desc.blank_null = fortran_open_data.blank_null; if fortran_open_data.specified.blank & ^fortran_open_data.formatted_records then call print_error (fortran_io_error_$incompatible_opening, me, "Blank specified for an unformatted file."); file_desc.file_status = fortran_open_data.file_status; if fortran_open_data.file_status = scratch_file & fortran_open_data.specified.attach_desc then call print_error (fortran_io_error_$open_attr_conflict, me, "Attach and status = ""scratch""."); /* SET bit attributes */ if fortran_open_data.specified.prompt then file_desc.prompt = fortran_open_data.prompt; if fortran_open_data.specified.carriage then file_desc.printer_file = fortran_open_data.carriage; if fortran_open_data.specified.defer then file_desc.defer_newline = fortran_open_data.defer; end merge_attributes; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ convert_from_character: proc (fld_no, valid_values, which_one); declare valid_values (*) char (12) varying; dcl (fld_no, i, num_valid_values, which_one) fixed bin; declare error_string char (64) varying; declare given char (12) varying; call get_open_field (fld_no, off, len); given = translate (substr (fortran_open_data.char_str, off + 1, len), lower_letters, capital_letters); num_valid_values = hbound (valid_values, 1); /* scan till a match in the list of valid values */ do i = 1 to num_valid_values; if given = valid_values (i) then do; which_one = i; return; end; end; /* user hasn't given a valid value, tell him which one are valid */ error_string = ""; do i = 1 to num_valid_values - 2; error_string = error_string || valid_values (i) || COMMA; end; error_string = error_string || SP || valid_values (num_valid_values - 1) || " and " || valid_values (num_valid_values); call print_error (field_error (fld_no), me, "Unrecognized value for field. ""^a"". ^3xValues allowed are: ^a ", substr (fortran_open_data.char_str, off + 1, len), error_string); end convert_from_character; end open_statement; inquire_statement: procedure; /* This implements the ansi77 INQUIRE statement. It first distinquishes between the two kinds of such statements, by_file or by_unit. It then checks each of the specified fields to determine which information is required and proceeds to capture that info and store it in the location specified in the remained of the structure fort_inquire_data. Full details in the 1978 version of the standard. */ declare (by_file, in_range, file_connected, file_exists, need_name) bit (1) aligned; declare unit_number fixed binary (18); declare return_string character (168) varying; declare dir_name char (168); declare ent_name char (32); declare based_bit_1 bit (1) aligned based; by_file = fortran_inquire_data.specified.filename; if by_file then do; need_name = FALSE; /* AT THIS POINT WE DEPEND THAT get_associated_unit WILL SET iocb_ptr */ call get_associated_unit (ltrim (fortran_inquire_data.filename), unit_number, dir_name, ent_name, code); if code = 0 then do; file_connected = TRUE; file_exists = TRUE; fio_ps.file_number = unit_number; /* if needed for error message */ fcb_ptr = addr (fortran_buffer_.table (unit_number)); end; else if code = error_table_$no_file then do; file_connected = FALSE; file_exists = FALSE; end; else do; /* file exists, but not connected */ file_connected = FALSE; file_exists = TRUE; end; end /* by_file */; else do; /* by unit */ fio_ps.file_number, unit_number = fortran_inquire_data.unit; need_name = TRUE; if unit_number >= lbound (fortran_buffer_.table, 1) & unit_number <= hbound (fortran_buffer_.table, 1) then do; in_range = TRUE; fcb_ptr = addr (fortran_buffer_.table (unit_number)); iocb_ptr = file_desc.switch_p; file_connected = fortran_buffer_.table (unit_number).connected; end /* unit in range */; else do; file_connected = FALSE; in_range = FALSE; end /* file number out of range */; end; /* The exist and opened fields are always defined */ if fortran_inquire_data.specified.exist then do; if by_file then fortran_inquire_data.exist -> based_bit_1 = file_exists; else fortran_inquire_data.exist -> based_bit_1 = in_range; end /* EXIST */; if fortran_inquire_data.specified.opened then fortran_inquire_data.opened -> based_bit_1 = file_connected; /* If by unit and not connected, then no other fields are defined. If by file, then if not connected, the fields NAMED, NAME, SEQUENTIAL, DIRECT, FORMATTED and UNFORMATTED refer to the file, if it exists. NUMBER is defined iff OPENED is true. The remaining fields (ACCESS, FORM, RECl, NEXTREC, and BLANK) are only defined for connected files/units */ if (by_file & ^file_exists) | (^by_file & ^file_connected) then return; /* the file is named if it is connected, uses vfile_ and not a scratch file, or if not connected, and this is by_file this file must exists and have a name of some sort. */ if fortran_inquire_data.specified.named then do; if ^file_connected then fortran_inquire_data.named -> based_bit_1 = TRUE; else if file_desc.using_vfile then fortran_inquire_data.named -> based_bit_1 = (file_desc.file_status ^= scratch_file); else fortran_inquire_data.named -> based_bit_1 = FALSE; end /* NAMED */; if fortran_inquire_data.specified.name then do; if (file_connected & file_desc.using_vfile & file_desc.file_status ^= scratch_file) | ^file_connected then do; if need_name then call get_name_of_unit; return_string = rtrim (dir_name) || ">" || rtrim (ent_name); call set_return_value (fortran_inquire_data.name.pointer, fortran_inquire_data.name.length, return_string); end /* not a scratch file */; end /* NAME */; if fortran_inquire_data.specified.formatted then do; if file_connected then do; if file_desc.formatted_records then return_string = "YES"; else return_string = "NO"; end; else return_string = "YES"; /* CAN be opened for formatted */ call set_return_value (fortran_inquire_data.formatted.pointer, fortran_inquire_data.formatted.length, return_string); end /* FORMATTED */; if fortran_inquire_data.specified.unformatted then do; if file_connected then do; if file_desc.formatted_records then return_string = "NO"; else return_string = "YES"; end; else return_string = "YES"; /* CAN be opened unformatted */ call set_return_value (fortran_inquire_data.unformatted.pointer, fortran_inquire_data.unformatted.length, return_string); end /* UNFORMATTED */; if fortran_inquire_data.specified.sequential then do; if file_connected then do; if file_desc.allow.seq_access then return_string = "YES"; else return_string = "NO"; end; else return_string = "YES"; /* all CAN be opened sequentially */ call set_return_value (fortran_inquire_data.sequential.pointer, fortran_inquire_data.sequential.length, return_string); end /* SEQUENTIAL */; if fortran_inquire_data.specified.direct then do; if file_connected then do; if file_desc.allow.direct_access then return_string = "YES"; else return_string = "NO"; end; else do; /* by_file & no connected */ uns_info.info_version = 1; /* required for call to vfile_status_ */ call vfile_status_ (dir_name, ent_name, addr (info), code); if code ^= 0 then return_string = "UNKNOWN"; else if uns_info.type = blocked | uns_info.type = indexed then return_string = "YES"; else return_string = "NO"; end /* not connected */; call set_return_value (fortran_inquire_data.direct.pointer, fortran_inquire_data.direct.length, return_string); end /* DIRECT */; /* The following attributes refer only to connected files/units */ if ^file_connected then return; if fortran_inquire_data.specified.blank then do; if file_desc.blank_null then return_string = "NULL"; else return_string = "ZERO"; call set_return_value (fortran_inquire_data.blank.pointer, fortran_inquire_data.blank.length, return_string); end /* BLANK */; if fortran_inquire_data.specified.number then fortran_inquire_data.number -> words (1) = unit_number; if fortran_inquire_data.specified.access then do; if file_desc.allow.direct_access then return_string = "DIRECT"; else return_string = "SEQUENTIAL"; call set_return_value (fortran_inquire_data.access.pointer, fortran_inquire_data.access.length, return_string); end /* ACCESS */; if fortran_inquire_data.specified.form then do; if file_desc.formatted_records then return_string = "FORMATTED"; else return_string = "UNFORMATTED"; call set_return_value (fortran_inquire_data.form.pointer, fortran_inquire_data.form.length, return_string); end /* FORM */; /* RECL is defined only if connected for direct access and this is a blocked file */ if fortran_inquire_data.specified.recl then do; if file_desc.allow.direct_access then do; if file_desc.type_of_io = blocked_file | file_desc.type_of_io = record_file then do; if need_name then call get_name_of_unit; uns_info.info_version = 1; /* must be set before call to vfile_status_ */ call vfile_status_ (dir_name, ent_name, addr (info), code); if code ^= 0 then call print_error (code); else fortran_inquire_data.recl -> words (1) = blk_info.max_rec_len; end /* blocked */; else call print_error (fortran_io_error_$not_blocked); end /* direct access */; end /* RECL */; if fortran_inquire_data.specified.nextrec then do; if file_desc.allow.direct_access then fortran_inquire_data.nextrec -> words (1) = file_desc.last_rec + 1; end /* NEXTREC */; return; get_name_of_unit: procedure; call save_attach_desc (attachment); call expand_pathname_ (attachment, dir_name, ent_name, code); if code ^= 0 then call print_error (code, me, "Can't find filename in an inquire statement."); need_name = FALSE; end get_name_of_unit; get_associated_unit: procedure (filename, unit_number, dir_name, ent_name, code); /* Algorithm: get the unique id of the filename in question. Then proceed through the array of files, stopping at the first with the same unique id. Note that the standard does not allow a file to be connected to more than one unit, so this is OKAY. The value of unit_number is undefined if there is no associated unit or no such file and a number in the range of permissable LUN's otherwise (presently 1 - 99, with 0 reserved for the terminal). code = error_table_$no_file if the file doesn't exist and fortran_io_error_$not_open if it exists and is not open, i.e. connected to a unit. */ declare filename char (*); /* INPUT */ declare dir_name char (*); /* OUTPUT */ declare ent_name char (*); /* OUTPUT */ declare unit_number fixed binary (18); /* OUTPUT */ declare code fixed binary (35); /* OUTPUT */ declare (file_uid, uid) bit (36) aligned; declare dname char (168); declare ename char (32); code = 0; call get_unique_id (filename, file_uid, dir_name, ent_name); if file_uid = no_uid then do; code = error_table_$no_file; return; end; do i = 1 to hbound (fortran_buffer_.table, 1); fcb_ptr = addr (fortran_buffer_.table (i)); iocb_ptr = file_desc.switch_p; if file_desc.connected then do; if file_desc.switch_p ^= null then do; call save_attach_desc (attachment); call get_unique_id (attachment, uid, dname, ename); if uid = file_uid then do; unit_number = i; return; end; end; end /* connected unit */; end /* do loop */; /* if we've got to here, there is no match */ code = fortran_io_error_$not_open; end get_associated_unit; get_unique_id: procedure (filename, uid, dname, ename); /* given a filename, return its unique id (uid), if it exists, otherwise no_uid */ %include branch_status; declare filename character (*); /* INPUT */ declare (dname, ename) character (*); /* OUTPUT */ declare uid bit (36) aligned; /* OUTPUT */ declare 1 my_status like branch_status; declare status_ptr pointer; declare chase_sw fixed bin (1) internal static options (constant) initial (1); call expand_pathname_ (filename, dname, ename, code); if code ^= 0 then do; uid = no_uid; return; end; status_ptr = addr (my_status); call hcs_$status_long (dname, ename, chase_sw, status_ptr, null, code); if code ^= 0 then uid = no_uid; else uid = my_status.unique_id; end get_unique_id; set_return_value: procedure (char_ptr, char_len, char_value); declare char_ptr unaligned pointer; /* INPUT: addr of fortran char variable */ declare char_len fixed binary (18); /* INPUT: length of fortran char variable */ declare char_value char (168) varying;/* INPUT: what to put there */ declare return_len fixed binary (18); declare based_chars char (char_len) based; /* fill into the user's variable, the required value. Truncate the correct character string if user has not provided enough room, and pad with blanks if the user has provided too much room. */ return_len = min (char_len, length (char_value)); if return_len < 1 then return; substr (char_ptr -> based_chars, 1) = char_value; end set_return_value; end inquire_statement; /* * * * * * * * * * */ exists_file: proc (exists_file_code); /* to determine if the file exists already if needed in OPEN statement. */ declare exists_file_code fixed binary; declare my_code fixed binary (35); declare file_type fixed binary (2); declare bit_count fixed binary (24); declare pathname character (168); declare (off, len) fixed binary; call get_open_field (filename_field, off, len); exists_file_code = 0; if len > length (pathname) then exists_file_code = 1; else if len < 1 then exists_file_code = 2; else do; pathname = substr (fortran_open_data.char_str, off + 1, len); call expand_pathname_ (pathname, dirname, entryname, my_code); if my_code ^= 0 then exists_file_code = 3; /* chase links on call to status (3rd arg = 1) */ else do; call hcs_$status_minf (dirname, ltrim (entryname), 1, file_type, bit_count, my_code); if my_code ^= 0 then exists_file_code = 3; end; end; return; end exists_file; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_open_field: proc (field_num, str_off, str_len); dcl field_num fixed bin; dcl str_off fixed bin; dcl str_len fixed bin; dcl 1 field (0:13) aligned based (addr (fortran_open_data)), 2 off fixed bin (17) unaligned, 2 len fixed bin (17) unaligned; str_off = field (field_num).off; str_len = length (rtrim (substr (fortran_open_data.char_str, str_off + 1, field (field_num).len))); end get_open_field; /* THIS PROCEDURE IS USED TO SNAP THE LINK FOR THE APPROPRIATE FIELD MESSAGE */ field_error: proc (field_number) returns (fixed bin (35)); dcl field_number fixed bin; goto get_error_message (field_number); get_error_message (1): return (fortran_io_error_$status_field_error); get_error_message (2): return (fortran_io_error_$io_switch_field_error); get_error_message (3): return (fortran_io_error_$attach_desc_field_error); get_error_message (4): return (fortran_io_error_$filename_field_error); get_error_message (5): return (fortran_io_error_$mode_field_error); get_error_message (6): return (fortran_io_error_$access_field_error); get_error_message (7): return (fortran_io_error_$form_field_error); get_error_message (13): return (fortran_io_error_$blank_field_error); end field_error; reopen_for_input: proc; dcl (new_opening, original_opening) fixed bin; dcl (code, tcode) fixed bin (35); original_opening = file_desc.open_code; /* save in case cannot reopen */ call iox_$close (iocb_ptr, tcode); /* error is irrelevant */ tcode = 1; /* to get into the loop */ new_opening = open_mode (original_opening).for_input; do while (new_opening ^= 0 & tcode ^= 0); call iox_$open (iocb_ptr, new_opening, "0"b, tcode); if tcode ^= 0 then new_opening = open_mode (new_opening).for_input; end; if tcode ^= 0 then do; call iox_$open (iocb_ptr, original_opening, "0"b, tcode); call print_error (fortran_io_error_$cannot_reopen, me, "Cannot open for input."); return; end; file_desc.open_code = new_opening; string (file_desc.direction) = string (open_mode (new_opening).direction); return; reopen_for_output: entry; original_opening = file_desc.open_code; /* save in case cannot reopen */ code = 0; /* For error processing. */ call iox_$close (iocb_ptr, tcode); /* error is irrelevant */ tcode = 1; /* to get into the loop */ new_opening = open_mode (original_opening).for_output; do while (new_opening ^= 0 & tcode ^= 0); if ^(new_opening = Sequential_input_output & file_desc.type_of_io = blocked_file) then call iox_$open (iocb_ptr, new_opening, "0"b, tcode); if tcode ^= 0 then do; if tcode = error_table_$moderr then code = tcode; /* Tells why reopen failed. */ new_opening = open_mode (new_opening).for_output; end; end; if tcode ^= 0 then do; call iox_$open (iocb_ptr, original_opening, "0"b, tcode); if code = 0 then code = fortran_io_error_$cannot_reopen; /* If no interesting msg, use canned one. */ call print_error (code, me, "Cannot open for output."); return; end; if file_desc.rewind_on_open then do; call iox_$position (iocb_ptr, -1, 0, my_code); if my_code ^= 0 then call print_error (my_code); end; file_desc.open_code = new_opening; string (file_desc.direction) = string (open_mode (new_opening).direction); end reopen_for_input; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ close_fortran_file: proc; /* caller must set "fcb_ptr" & "iocb_ptr" */ if iocb_ptr ^= null then do; if iocb_ptr -> iocb.open_descrip_ptr ^= null then do; /* If file is actually connected, flush its output buffer. */ if file_desc.connected then call finish_line; /* Close the I/O switch if fortran_io_ opened it. */ if file_desc.fortran_opened then call iox_$close (iocb_ptr, my_code); else if file_desc.connected /* rewind only if actually connected */ then call iox_$position (iocb_ptr, -1, 0, my_code); end; if file_desc.fortran_attached then call iox_$detach_iocb (iocb_ptr, my_code); end; /* Forget everything we ever knew about the file. */ unspec (file_desc.per_connection) = "0"b; end close_fortran_file; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to write the last newline character if necessary. */ finish_line: proc; my_code = 0; if file_desc.newline_needed then do; call iox_$put_chars (iocb_ptr, addr (NL), 1, my_code); file_desc.newline_needed = "0"b; end; end finish_line; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ close_for_stop: proc; /* if there are files open, this procedure closes them. */ dcl buf_p ptr; dcl ix fixed bin; if ^fast_related_data_$fortran_io_initiated /* not initiated, therefore not open */ then return; buf_p = fast_related_data_$fortran_buffer_p; if buf_p = null then return; /* no segment, therefore not open */ if buf_p -> fortran_buffer_.all_files_closed then return; /* nothing is open */ /* Must always check in case fortran_buffer_.all_files_closed is wrong. */ do ix = 1 to 99; if buf_p -> fortran_buffer_.table (ix).fortran_opened | buf_p -> fortran_buffer_.table (ix).fortran_attached | buf_p -> fortran_buffer_.table (ix).connected then do; call close_all_files ("0"b); buf_p -> fortran_buffer_.terminal_needs_newline = "0"b; /* true regardless of user answer */ return; end; end; end close_for_stop; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* This procedure closes all open FORTRAN files. */ close_all_files: proc (by_stop_statement); dcl by_stop_statement bit (1) aligned; /* ="1"b if this proc should output newline chars */ dcl frn fixed bin, fcode fixed bin (35); dcl p ptr; declare killing_file bit (1) aligned; declare attach_description char (256); /* This procedure must be coded very carefully as it is called as a finish handler to close all files. */ if ^fast_related_data_$fortran_io_initiated then return; /* never been used */ p = fast_related_data_$fortran_buffer_p; /* get buf ptr */ if p = null then return; /* never allocated */ /* output newline to terminal if needed */ if p -> fortran_buffer_.terminal_needs_newline then do; if by_stop_statement then call iox_$put_chars (iox_$user_io, addr (NL), 1, fcode); p -> fortran_buffer_.terminal_needs_newline = "0"b; end; /* output newline to file0 if not the terminal */ if p -> fortran_buffer_.table (0).newline_needed then if iox_$user_output -> iocb.actual_iocb_ptr ^= iox_$user_io then call iox_$put_chars (iox_$user_output, addr (NL), 1, fcode); p -> fortran_buffer_.table (0).newline_needed = "0"b; /* Check entire file table for connected files (and partially connected files) and disconnect them. */ do frn = 1 to 99; iocb_ptr = p -> fortran_buffer_.table (frn).switch_p; if iocb_ptr ^= null then do; killing_file = p -> fortran_buffer_.table (frn).file_status = scratch_file & ^(p -> fortran_buffer_.table (frn).has_been_deleted); if killing_file then call save_attach_desc (attach_description); if iocb_ptr -> iocb.open_descrip_ptr ^= null then do; /* Flush the file's output buffer only if the file is actually connected, needs a newline char, and isn't the terminal. */ if p -> fortran_buffer_.table (frn).connected then if p -> fortran_buffer_.table (frn).newline_needed then if iocb_ptr -> iocb.actual_iocb_ptr ^= iox_$user_io then call iox_$put_chars (iocb_ptr, addr (NL), 1, fcode); /* Close (if opened by fortran_io_) or rewind (if actually connected) */ if p -> fortran_buffer_.table (frn).fortran_opened then call iox_$close (iocb_ptr, fcode); else if p -> fortran_buffer_.table (frn).connected then call iox_$position (iocb_ptr, -1, 0, fcode); end; /* processing for open I/O switch */ if p -> fortran_buffer_.table (frn).fortran_attached then call iox_$detach_iocb (iocb_ptr, fcode); if killing_file then do; call delete_file (attach_description, frn); p -> fortran_buffer_.table (frn).has_been_deleted = TRUE; end; end; /* I/O switch exists */ unspec (p -> fortran_buffer_.table (frn).per_connection) = "0"b; end; /* loop to close all files */ p -> fortran_buffer_.all_files_closed = "1"b; end close_all_files; /* * * * * * * * * * */ delete_file: procedure (saved_attach_desc, file_number); /* deletes a file, either a scratch_file or if so indicated by the CLOSE statement user MUST set iocb_ptr */ declare saved_attach_desc char (*); /* the pathname, saved from the attach desc */ declare file_number fixed binary; /* LUN associated with file */ call expand_pathname_ (substr (saved_attach_desc, 1, attach_desc_len), dirname, entryname, my_code); if my_code ^= 0 then do; call com_err_ (my_code, me, "Cannot delete file associated with unit number ^d.", fio_ps.file_number); return; end; call delete_$path (dirname, entryname, "010111"b, me, my_code); if my_code ^= 0 then do; call com_err_ (my_code, me, "Cannot delete file associated with unit number ^d.", fio_ps.file_number); return; end; end delete_file; /* * * * * * * * * */ save_attach_desc: procedure (attach_desc); declare attach_desc char (*); attach_desc_len = index (substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 8), " ") - 1; if attach_desc_len < 0 /* i.e., no blank follows pathname */ then attach_desc_len = length (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str) - 7; attach_desc = substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 8, attach_desc_len); end save_attach_desc; error_handlers: procedure; call print_error (fortran_io_error_$fio_sys_error, me, "Illegal entry point."); too_much_input: entry; call print_error (fortran_io_error_$short_record); too_much_output: entry; call print_error (fortran_io_error_$long_record, me, "^d", buffer_max_len); internal_file_overflow: entry; call print_error (fortran_io_error_$internal_file_oflow); conversion_error: entry; buffer_index = begin_index; /* Point to beginning of constant for error. */ call print_error (fortran_io_error_$conversion_error); bad_char: entry; call print_error (fortran_io_error_$bad_char, me, """^a""", substr (rest_of_field, 1, 1)); syntax_error: entry; call print_error (fortran_io_error_$syntax_error); end error_handlers; /* Procedure to abort the FORTRAN I/O system. */ print_error: proc options (variable); /* First argument must be valid error code. rest are optional */ dcl comp_name char (32) aligned, dir_name char (168), ent_name char (256), seg_name char (32); dcl std bit (1) aligned, op_name char (32) varying, (start, num, line_no, offset) fixed bin (18), cur_op fixed bin, bit_cnt fixed bin (24), (error_code, tcode) fixed bin (35); dcl (ap, err_point, seg_base, sym_tab, p) ptr; dcl length builtin; declare component_info_$offset entry (ptr, fixed bin (18), ptr, fixed bin (35)), cu_$arg_count entry (fixed bin (18)), cu_$arg_list_ptr entry (ptr), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), cu_$gen_call entry (entry, ptr), get_entry_name_ entry (ptr, char (*), fixed bin (18), char (8) aligned, fixed bin (35)), hcs_$fs_get_path_name entry (ptr, char (*), fixed bin (18), char (*), fixed bin (35)), hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)), object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)), stack_frame_exit_ entry (ptr, ptr, ptr, bit (1), ptr, char (32), ptr), stu_$get_line_no entry (ptr, fixed bin (18), fixed bin (18), fixed bin (18)) returns (fixed bin (18)), stu_$get_runtime_line_no entry (ptr, fixed bin (18), fixed bin (18), fixed bin (18)) returns (fixed bin (18)); %include component_info; %include object_info; %include symbol_header; dcl 1 oi aligned like object_info; /* GET ERROR CODE */ call cu_$arg_ptr (1, p, 0, error_code); /* third arg is char len which is meaningless */ if error_code = 0 then error_code = p -> words (1); /* if call fails, FIOS error, so print why it failed */ /* Save info about last error. */ if my_code ^= 0 then actual_error = my_code; else actual_error = error_code; ps_at_error = PS_ptr; string (PS.job_bits) = string (fio_ps.job_bits); PS.element_p = fio_ps.element_p; PS.file_number = fio_ps.file_number; /* IOSTAT FIELD - return the error code to the user instead of printing an error */ if fio_ps.iostat_var then do; PS.iostat_p -> words (1) = error_code; /* copy into user's variable */ if ^fio_ps.error_label /* If err= specified, it is handled below */ then goto return_error_code; end; /* ERR FIELD - return to the user instead of printing an error */ if fio_ps.error_label /* Return to user if err= specified. */ then call return_to_user (PS.error_p, PS.stack_frame_p); /* OPENFILE ERRORS - print only if the file is subsequently referenced */ if fio_ps.control_type = bit (openfile_opr, 4) then if fast_related_data_$in_dfast then if fio_ps.file_number >= 1 & fio_ps.file_number <= 99 then do; num = fio_ps.file_number; fortran_buffer_.table (num).previous = 0; /* indicates that file is not open */ fortran_buffer_.table (num).open_code = 1; /* how to decode the error message */ unspec (fortran_buffer_.table (num).switch_p) = unspec (error_code); /* a kludge but it works */ goto return_error_code; /* results in a return to the user */ end; /* PRINT AN ERROR MESSAGE */ /* End last output line BEFORE printing error message. */ if fortran_buffer_.terminal_needs_newline then do; call iox_$put_chars (iox_$user_io, addr (NL), 1, tcode); fortran_buffer_.terminal_needs_newline = "0"b; end; /* If caller provides extra info about the error, print caller's info first */ call cu_$arg_count (num); if num > 1 /* Will always have one argument. */ then do; call cu_$arg_list_ptr (ap); call cu_$gen_call (com_err_, ap); error_code = 0; end; /* PRINT LOCATION IN USER PROGRAM. */ /* get return address in user's program */ sp = PS.stack_frame_p; call stack_frame_exit_ (sp, null, null, "0"b, err_point, seg_name, addr (work)); /* Get return address. */ seg_base = ptr (err_point, 0); /* Base pointer. */ num, offset = binary (rel (err_point), 18); /* get entry point name */ call get_entry_name_ (sp -> stack_frame.entry_ptr, ent_name, 0, (8)" ", tcode); if tcode ^= 0 then ent_name = " "; comp_name = substr (ent_name, 1, 32); /* In case not bound segment. */ /* get status of object segment to see if it has a symbol table */ call component_info_$offset (seg_base, offset, addr (ci), tcode); if tcode = 0 /* This is a bound segment. */ then do; sym_tab = ci.symb_start; std = ci.standard; offset = offset - binary (rel (ci.text_start), 18); comp_name = ci.name; end; else do; /* Not bound. */ call hcs_$status_mins (seg_base, 0, bit_cnt, tcode); /* Get bit count. */ if tcode ^= 0 then go to no_line; /* No access. */ oi.version_number = object_info_version_2; call object_info_$brief (seg_base, bit_cnt, addr (oi), tcode); if tcode ^= 0 then go to no_line; sym_tab = oi.symbp; std = oi.format.standard; end; /* if object segment has symbol table, get line number */ start = -1; if std then line_no = stu_$get_runtime_line_no (sym_tab, num, start, 0); else if sym_tab -> symbol_header.root ^= "0"b then line_no = stu_$get_line_no (addrel (sym_tab, sym_tab -> symbol_header.root), num, start, 0); if start > 0 then do; int_pic = line_no; substr (work, verify (work, SP) - 5, 4) = "Line"; end; else no_line: substr (work, 1, length (int_pic)) = SP; /* get full pathname */ call hcs_$fs_get_path_name (seg_base, dir_name, 0, seg_name, tcode); /* PRINT THE ERROR MESSAGE */ if fio_ps.mode = string_io | fio_ps.mode = internal_file then do; if fio_ps.mode = string_io then if fio_ps.read then op_name = "Decode"; else op_name = "Encode"; else if fio_ps.read then op_name = "Internal file read"; else op_name = "Internal file write"; if (ent_name = seg_name) & (comp_name = seg_name) then call com_err_ (error_code, me, "^a statement error by ^a>^a|^o^a", op_name, dir_name, seg_name, offset, int_pic); else call com_err_ (error_code, me, "^a statement error by ^a>^a$^a at ^a|^o^a", op_name, dir_name, seg_name, ent_name, comp_name, offset, int_pic); end /* string_io */; else do; /* Convert request to char str. */ if fio_ps.control_type ^= "0"b then do; cur_op = binary (fio_ps.control_type, 3, 0); op_name = ""; /* No qualifiers for control operations. */ end; else do; if fio_ps.read then cur_op = read_opr; else cur_op = write_opr; op_name = rtrim (format_type (binary (fio_ps.format, 2))); if fio_ps.mode = direct_access then op_name = op_name || " direct access"; else op_name = op_name || " sequential"; end; /* Print message. */ if (ent_name = seg_name) & (comp_name = seg_name) then call com_err_ (error_code, me, "^a^a on file ^d.^/By ^a>^a|^o^a", op_name, operation_name (cur_op), fio_ps.file_number, /* info about request */ dir_name, seg_name, offset, int_pic); /* segment info */ else call com_err_ (error_code, me, "^a^a on file ^d.^/By ^a>^a$^a (^a|^o)^a", op_name, operation_name (cur_op), fio_ps.file_number, /* info about request */ dir_name, seg_name, ent_name, comp_name, offset, int_pic); /* segment info */ if fio_ps.have_input & buffer_length > 0 then do; call ioa_$ioa_switch (iox_$error_output, "Error occurred at character ^d of this record:^/""^a""", buffer_index + 1, io_buf); call ioa_$ioa_switch (iox_$error_output, "^vxI", buffer_index + 1); end; if ^fast_related_data_$in_fast_or_dfast then call close_for_stop; end /* neither string_io nor internal_file */; /* TERMINATE THE RUN */ /* SCP 6315 call another command level if the program was compiled with -debug_io otherwise just die gracefully */ if fio_ps.debug_io then call cu_$cl ("0"b); if fast_related_data_$in_fast_or_dfast then call fast_related_data_$terminate_run; else call stop_run; do while ("1"b); signal illegal_return; end; end print_error; /* Procedure for unformatted I/O. */ unformatted_io: proc; /* get total size of element = element_size * element_count */ call set_size_and_count (char_len, element_count, chars_per_item); char_len = chars_per_item * element_count; /* Perform I/O. */ if fio_ps.read then if file_desc.type_of_io ^= binary_file then do; /* Not binary file. Copy characters from buffer into variable. */ if buffer_index + char_len > buffer_length then call too_much_input; if ^fio_ps.element_desc.VLA then substr (fio_ps.element_p -> chars, 1, char_len) = substr (rest_of_record, 1, char_len); else do; chars_left = 4 * pl1_operators_$VLA_words_per_seg_ - char_pos (fio_ps.element_p) + 1; if char_len <= chars_left then substr (fio_ps.element_p -> chars, 1, char_len) = substr (rest_of_record, 1, char_len); else do; /* Target crosses into next VLA component. */ substr (fio_ps.element_p -> chars, 1, chars_left) = substr (rest_of_record, 1, chars_left); substr (baseptr (fixed (baseno (fio_ps.element_p)) + 1) -> chars, 1, char_len - chars_left) = substr (rest_of_record, chars_left + 1, char_len - chars_left); end; end; buffer_index = buffer_index + char_len; /* Keep track of how many read */ end; /* code to read non binary file */ else do; /* Binary file. Read data directly into the variable */ if file_desc.double_word_file & ^fio_ps.double then call print_error (fortran_io_error_$dnumeric_file); fio_ps.element_count = char_len; /* store length of item */ call read_a_record; /* read directly into the item */ end; /* code to read binary file */ else do; /* Write logic. It is the same for all file types */ if file_desc.double_word_file & ^fio_ps.double then call print_error (fortran_io_error_$dnumeric_file); if buffer_length + char_len > buffer_max_len then call too_much_output; if ^fio_ps.element_desc.VLA then substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len); else do; chars_left = 4 * pl1_operators_$VLA_words_per_seg_ - char_pos (fio_ps.element_p) + 1; if char_len <= chars_left then substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len); else do; /* Source crosses into next VLA component. */ substr (rest_of_output, 1, chars_left) = substr (fio_ps.element_p -> chars, 1, chars_left); substr (rest_of_output, chars_left + 1, char_len - chars_left) = substr (baseptr (fixed (baseno (fio_ps.element_p)) + 1) -> chars, 1, char_len - chars_left); end; end; buffer_length = buffer_length + char_len; end; /* write logic */ end unformatted_io; /* Formatted I/O. */ formatted_io: proc; /* Constants */ dcl fixed_decimal fixed bin init (18) internal static options (constant); dcl ( READ_ init (30), WRITE_ init (0) ) fixed bin int static options (constant); declare MINUS_SIGN char (1) int static options (constant) init ("-"); declare PLUS_SIGN char (1) int static options (constant) init ("+"); /* Automatic declarations. */ dcl op_offset fixed bin; dcl 1 field aligned, 2 spec fixed bin, 2 rep_factor fixed bin, 2 width fixed bin, 2 precision fixed bin, 2 exponent fixed bin; dcl 1 FORMAT aligned, 2 indx fixed bin, 2 scale fixed bin, 2 paren_level fixed bin, 2 restart (5) fixed bin, 2 rep_factor (5) fixed bin; declare blanks_as_null bit (1) aligned; declare leading_sign char (1); dcl infinite_format bit (1) aligned; dcl decimal_len fixed bin (35); dcl decimal_type fixed bin; dcl exponent fixed decimal (3); dcl (exp, negate) fixed bin; dcl add_zero bit (1) aligned; declare effective_digits fixed binary; declare digits_after_E fixed binary; declare x float binary; dcl lied_about_sign bit (1); /* WARNING: This structure is based on the internal representation of extended float decimal data */ dcl 1 x_float aligned structure, 2 char_pad char (11) unaligned, 2 exp fixed bin (8) unaligned; dcl x_flt float decimal (10) based (addr (x_float)); dcl scale fixed bin; dcl element_v float bin (63); dcl bin_int fixed bin (35); dcl min_field_width fixed bin; /* Based variables. */ dcl ( float_bin float bin (27), logical bit (1) ) aligned based (fio_ps.element_p), in_fmt char (1024) aligned based (PS.user_format_p); dcl dec_int_picture char (12) based (addr (dec_int)); /* constant */ declare ten_to_the_power (-38:38) float bin (63) int static options (constant) init (1e-38, 1e-37, 1e-36, 1e-35, 1e-34, 1e-33, 1e-32, 1e-31, 1e-30, 1e-29, 1e-28, 1e-27, 1e-26, 1e-25, 1e-24, 1e-23, 1e-22, 1e-21, 1e-20, 1e-19, 1e-18, 1e-17, 1e-16, 1e-15, 1e-14, 1e-13, 1e-12, 1e-11, 1e-10, 1e-09, 1e-08, 1e-07, 1e-06, 1e-05, 1e-04, 1e-03, 1e-02, 1e-01, 1e+00, 1e+01, 1e+02, 1e+03, 1e+04, 1e+05, 1e+06, 1e+07, 1e+08, 1e+09, 1e+10, 1e+11, 1e+12, 1e+13, 1e+14, 1e+15, 1e+16, 1e+17, 1e+18, 1e+19, 1e+20, 1e+21, 1e+22, 1e+23, 1e+24, 1e+25, 1e+26, 1e+27, 1e+28, 1e+29, 1e+30, 1e+31, 1e+32, 1e+33, 1e+34, 1e+35, 1e+36, 1e+37, 1e+38); /* * * * * * * * * * * */ call set_size_and_count (char_len, element_count, chars_per_item); /* For complex data, we will treat the real and imaginary parts as separate elements. */ if fio_ps.element_desc.complex then do; element_count = element_count * 2; char_len, chars_per_item = CPW; end; goto format_routine (field.spec); /* Unpack format as it is used in hopes of minimizing the cost of using it. */ get_next_format: /* Come here to get next field if fmt is unpacked. */ fmt_ptr = addr (format_p -> runtime_format.fmt (FORMAT.indx)); FORMAT.indx = FORMAT.indx + 1; field.spec = fmt_ptr -> format.spec + op_offset; goto unpack_format (field.spec); unpack_format (0): call unpack_two; goto i_format_common; unpack_format (22): /* output extended_i_format */ call unpack_three; i_format_common: infinite_format = "0"b; format_routine (22): format_routine (0): /* output i-format */ if element_count = 0 then go to fmt_done; last = last + field.width; call expand_buffer; /* Save the binary integer to be printed in 'bin_int', then convert it to */ /* decimal in 'dec_int'. Note that we refer to 'dec_int' through its alias */ /* 'dec_int_picture' because we know that the hardware representation is a */ /* character string consisting of a '+' or '-' followed by the ASCII form */ /* of the digits in the decimal value of the number. */ bin_int = fio_ps.element_p -> words (1); dec_int = bin_int; /* Store the number of digits to be output in 'effective_digits'. */ if bin_int = 0 then if field.spec = extended_i_format then effective_digits = field.precision; else effective_digits = 1; else do; effective_digits = length (dec_int_picture) - verify (dec_int_picture, "+-0") + 1; if field.spec = extended_i_format then if field.precision > effective_digits then effective_digits = field.precision; end; /* Calculate the minimum field width needed to display the number and check */ /* that we actually have that much. */ min_field_width = effective_digits; if effective_digits > 0 /* i.e. if a sign is allowed */ then if bin_int < 0 | must_produce_plus then min_field_width = min_field_width + 1; if field.width - min_field_width < 0 then goto print_stars; /* If we have more field than needed, store enough spaces at the start of */ /* the field to take up the slack. */ if field.width - min_field_width > 0 then do; substr (rest_of_field, 1, field.width - min_field_width) = ""; buffer_index = buffer_index + (field.width - min_field_width); end; /* Store the sign if it's needed. */ if min_field_width > effective_digits then do; substr (rest_of_field, 1, 1) = substr (dec_int_picture, 1, 1); buffer_index = buffer_index + 1; end; /* If more digits are required than we have in 'dec_int_picture', the extra */ /* digits must all be zeroes since 'dec_int' is big enough to hold any */ /* 'fixed bin (35)' value. */ do while (effective_digits >= length (dec_int_picture)); substr (rest_of_field, 1, 1) = "0"; buffer_index = buffer_index + 1; effective_digits = effective_digits - 1; end; /* Store as many digits from the right end of 'dec_int_picture' as are */ /* needed to fill the field. */ substr (rest_of_field, 1, effective_digits) = substr (dec_int_picture, length (dec_int_picture) - effective_digits + 1, effective_digits); goto countdown_element; unpack_format (1): call unpack_three; infinite_format = "0"b; /* Assign_round_ is called to make a scaled fixed decimal according to the user's spec, if the number wont fit, fixedoverflow is signalled. If the relationship between the data precision and the size of the field causes a hardware fault this results in zerodivide being signalled. */ format_routine (1): /* output f-format */ if element_count = 0 then go to fmt_done; last = last + field.width; call expand_buffer; if fio_ps.double then element_v = fio_ps.element_p -> based_dp; else element_v = fio_ps.element_p -> float_bin; /* Set 'negate' equal to the sign bit of the element, except in '77 mode */ /* when the element is between -0.5 and 0, in which case we pretend the */ /* element is positive so that if it underflows the field we will not get */ /* minus zero as the result. */ lied_about_sign = "0"b; if element_v >= 0 then negate = 0; else if element_v > -0.5 & fio_ps.ansi_77 then do; negate = 0; lied_about_sign = "1"b; end; else negate = 1; i = 1; call start_floating; scale = field.precision + FORMAT.scale; prec = field.width - negate - 1; decimal_len = prec + 262144 * scale; decimal_type = fixed_decimal; call create_decimal; /* Create fixed scaled decimal number. */ if lied_about_sign /* If this point is reached and the flag is true, then an underflow did not occur in the create_decimal routine. */ then do; /* Drop the pretense that the element is positive. */ negate = 1; i = 1; call start_floating; if ^must_produce_plus then do; substr (number.digit, 1, prec - 1) = substr (number.digit, 2, prec - 1); /* Remove leftmost digit so the number corresponds to the proper precision. */ prec = prec - 1; /* Precision is one less since the element is negative. */ count = count - 1; end; end; if count >= prec - field.precision /* First non-zero digit is to right of decimal point. */ then if prec - field.precision = 0 then count = 0; /* Print as .0... */ else count = (prec - field.precision) - 1; /* Print as 0.0... */ i = field.width - count; call minus_sign; i = prec - field.precision - count; if i > 0 then do; substr (rest_of_record, 1, i) = substr (number.digit, count + 1, i); buffer_index = buffer_index + i; end; substr (rest_of_record, 1, 1) = "."; if field.precision > 0 then substr (rest_of_record, 2, field.precision) = substr (number.digit, prec - field.precision + 1, field.precision); goto countdown_element; unpack_format (2): unpack_format (4): call unpack_four; infinite_format = "0"b; format_routine (2): /* output e-format */ format_routine (4): /* Output d-format */ /* e- and d-format should not raise any conditions. Conversion is done by assign_round_. */ if element_count = 0 then go to fmt_done; last = last + field.width; call expand_buffer; e_fmt: if fio_ps.element_p -> float_bin >= 0 then negate = 0; else negate = 1; if field.exponent = 0 /* exponent not explict */ then do; digits_after_E = 2; /* ansi standard p 13-11 */ i = 5; /* reserved places, leading "." trailing "E+xx" */ end; else do; digits_after_E = field.exponent; i = field.exponent + 3; /* reserved for leading "." and exponent field */ end; call start_floating; if FORMAT.scale <= 0 then do; prec = field.precision + FORMAT.scale; if prec <= 0 then goto print_stars; end; else do; prec = field.precision + 1; if prec < FORMAT.scale then goto print_stars; if ^add_zero then go to print_stars; end; decimal_len = prec; decimal_type = ext_float_decimal; call create_decimal; exponent = number.exp + prec - FORMAT.scale; if count > 0 then do; number.digit = substr (number.digit, count + 1) || substr (number.digit, 1, count); exponent = exponent - count; end; if field.exponent = 0 & abs (exponent) > 99 then digits_after_E = 3; if abs (exponent) >= ten_to_the_power (digits_after_E) then goto print_stars; /* does exponent fit? */ call minus_sign; if FORMAT.scale > 0 then do; substr (rest_of_record, 1, FORMAT.scale) = substr (number.digit, 1, FORMAT.scale); count = FORMAT.scale; buffer_index = buffer_index + FORMAT.scale; end; else do; count = 0; if add_zero then do; substr (rest_of_record, 1, 1) = "0"; buffer_index = buffer_index + 1; end; end; substr (rest_of_record, 1, 1) = "."; buffer_index = buffer_index + 1; if FORMAT.scale < 0 then do; substr (rest_of_field, 1, -FORMAT.scale) = copy ("0", -FORMAT.scale); buffer_index = buffer_index - FORMAT.scale; end; if prec - count > 0 then substr (rest_of_record, 1, prec - count) = substr (number.digit, count + 1, prec - count); buffer_index = buffer_index + prec - count; /* include the E character if the exponent < 100 or the exponent length is specified */ if abs (exponent) < 100 | field.exponent > 0 then do; if field.spec = d_format then substr (rest_of_record, 1, 1) = "D"; else substr (rest_of_record, 1, 1) = "E"; buffer_index = buffer_index + 1; end; if exponent < 0 then substr (rest_of_record, 1, 1) = MINUS_SIGN; else substr (rest_of_record, 1, 1) = PLUS_SIGN; buffer_index = buffer_index + 1; /* in binary floating point, largest exponent (even with scale factor) is 2 digits long so if exponent field is to be longer, we need to prefix zeros. Finally, put in the exponent as calculated at the end. In hex floating point, an exponent could be larger then 99. */ if abs (exponent) > 99 then do; if digits_after_E > 3 then do; substr (rest_of_record, 1, digits_after_E - 3) = copy ("0", digits_after_E - 3); buffer_index = buffer_index + digits_after_E - 3; end; substr (rest_of_record, 1, 3) = substr (addr (exponent) -> chars, 2, 3); end; else do; if digits_after_E > 2 then do; substr (rest_of_record, 1, digits_after_E - 2) = copy ("0", digits_after_E - 2); buffer_index = buffer_index + digits_after_E - 2; end; effective_digits = min (digits_after_E, 2); substr (io_buf, last - effective_digits + 1, effective_digits) = substr (addr (exponent) -> chars, 5 - effective_digits, effective_digits); end; goto countdown_element; unpack_format (3): call unpack_two; infinite_format = "0"b; format_routine (3): /* output l-format */ if element_count = 0 then go to fmt_done; last = last + field.width; call expand_buffer; if field.width - 1 > 0 then substr (rest_of_record, 1, field.width - 1) = " "; if logical then substr (io_buf, last, 1) = "T"; else substr (io_buf, last, 1) = "F"; goto countdown_element; unpack_format (5): call unpack_two; infinite_format = "0"b; format_routine (5): /* output o-format */ if element_count = 0 then go to fmt_done; last = last + field.width; call expand_buffer; count = chars_per_item * 3; if field.width > count then do; substr (rest_of_record, 1, field.width - count) = " "; buffer_index = buffer_index + (field.width - count); i = 0; end; else i = -3 * (field.width - count); do i = i to count * 3 - 1 by 3; substr (rest_of_record, 1, 1) = substr ("01234567", binary (substr (fio_ps.element_p -> based_bits, i + 1, 3), 3) + 1, 1); buffer_index = buffer_index + 1; end; goto countdown_element; unpack_format (6): call unpack_four; infinite_format = "0"b; format_routine (6): /* output g-format */ if element_count = 0 then go to fmt_done; last = last + field.width; call expand_buffer; prec = field.precision; if prec = 0 | prec > max_float | prec > hbound (ten_to_the_power, 1) then go to e_fmt; else do; if fio_ps.job_bits.hfp then do; call assign_round_ (addr (x_float), ext_float_decimal, 10, fio_ps.element_p, binary_type (3), binary_prec (3)); if x_float.exp > (hbound (ten_to_the_power, 1) - 10) | x_float.exp < (-hbound (ten_to_the_power, 1) - 10) then goto e_fmt; x_float.exp = fixed (x_float.exp, 7); x = abs (x_flt); end; else x = abs (fio_ps.element_p -> float_bin); if x < 1.0e-1 | x >= ten_to_the_power (prec) then goto e_fmt; end; if fio_ps.element_p -> float_bin >= 0 then negate = 0; else negate = 1; if field.exponent = 0 then do; /* not given, use defaults */ effective_digits = 4; i = 5; digits_after_E = 2; end; else do; /* set up user defined widths */ effective_digits = field.exponent + 2; i = field.exponent + 1; digits_after_E = field.exponent; end; call start_floating; decimal_len = prec; decimal_type = ext_float_decimal; call create_decimal; exp = prec - count + number.exp; if exp < 0 | exp > field.precision then go to e_fmt; i = negate + 1 + field.precision - count + effective_digits; call minus_sign; if exp > 0 then do; substr (rest_of_record, 1, exp) = substr (number.digit, count + 1, exp); buffer_index = buffer_index + exp; count = count + exp; end; substr (rest_of_record, 1, 1) = "."; buffer_index = buffer_index + 1; if prec - count > 0 then substr (rest_of_record, 1, prec - count) = substr (number.digit, count + 1, prec - count); substr (io_buf, last - effective_digits + 1, effective_digits) = copy (SP, effective_digits); goto countdown_element; unpack_format (30): unpack_format (52): call unpack_two; infinite_format = "0"b; format_routine (30): /* input i-format */ format_routine (52): /* input extended i format */ if element_count = 0 then go to fmt_done; last = last + field.width; call read_buffer; begin_index = buffer_index; /* For error message. */ i = verify (substr (rest_of_field, 1, field.width), " ") - 1; if i < 0 then do; fixed_zero: fio_ps.element_p -> words (1) = 0; goto countdown_element; end; buffer_index = buffer_index + i; dec_int = 0; if substr (rest_of_field, 1, 1) = "-" then do; substr (work, 1, 4) = "-000"; buffer_index = buffer_index + 1; if buffer_index >= last then goto fixed_zero; end; else if substr (rest_of_field, 1, 1) = "+" then do; buffer_index = buffer_index + 1; if buffer_index >= last then goto fixed_zero; end; if verify (rest_of_field, " 0123456789") - 1 >= 0 then do; buffer_index = buffer_index + (verify (rest_of_field, " 0123456789") - 1); call bad_char; end; /* Leading spaces and zeroes are not significant: Skip them. */ i = verify (rest_of_field, " 0") - 1; if i < 0 then goto fixed_zero; buffer_index = buffer_index + i; call right_justify (addr (rest_of_field), length (rest_of_field), addr (number.digit), max_fixed, prec); /* Store significant digits in 'dec_int'. */ fio_ps.element_p -> words (1) = convert (my_code, dec_int); /* Convert decimal to binary. */ goto countdown_element; unpack_format (31): unpack_format (32): unpack_format (34): unpack_format (36): call unpack_three; infinite_format = "0"b; format_routine (31): /* input f-format */ format_routine (32): /* input e-format */ format_routine (34): /* input d-format */ format_routine (36): /* input g-format */ /* Convert external value to either single or double precision float binary. The precision of the float decimal source is derived from the external field, however a float dec(59) field is used for the conversion. There is no reason to translate blanks to zeros while creating the decimal value because the hardware treats blanks as zeros in decimal numbers. In ansi77, if we want blanks treated as null, we do it ourselves. */ if element_count = 0 then go to fmt_done; last = last + field.width; call read_buffer; begin_index = buffer_index; /* For error message. */ i = verify (substr (rest_of_field, 1, field.width), " ") - 1; if i < 0 then do; store_zero: if fio_ps.double then fio_ps.element_p -> based_dp = 0.0; else fio_ps.element_p -> float_bin = 0.0; goto countdown_element; end; buffer_index = buffer_index + i; dec_flt = 0.0; if substr (rest_of_field, 1, 1) = "-" then do; substr (work, 1, 4) = "-000"; buffer_index = buffer_index + 1; if buffer_index >= last then goto store_zero; end; else if substr (rest_of_field, 1, 1) = "+" then do; buffer_index = buffer_index + 1; if buffer_index >= last then goto store_zero; end; /* Leading spaces and zeroes are not significant: Skip them. */ i = verify (rest_of_field, " 0") - 1; if i < 0 then goto store_zero; buffer_index = buffer_index + i; /* "e" will be reset if there is a decimal point, otherwise, the value of d will be used. "exp" will be reset if there is an exponent, otherwise, the value of the scale will be used. */ e = field.precision; exp = -FORMAT.scale; /* Get any digits which appear before the decimal point. */ l = verify (rest_of_field, " 0123456789") - 1; if l ^= 0 /* Found some digits. */ then do; if l < 0 then l = length (rest_of_field); call left_justify (addr (rest_of_field), (l), addr (number.digit), max_float, prec); buffer_index = buffer_index + l; if last - buffer_index = 0 then go to finish_float; end; else prec = 0; /* No digits yet. */ /* Check for decimal point. If it exists, skip it and concatenate any digits which may follow it. */ ch = substr (rest_of_record, 1, 1); if ch = "." then do; buffer_index = buffer_index + 1; /* Skip over it. */ e = 0; /* The exponent if "." is last char in field. */ if last - buffer_index <= 0 then go to finish_float; /* Set 'l' to the size of the fraction part (i.e. the number of spaces and */ /* digits after the decimal point) and process it. */ l = verify (rest_of_field, " 0123456789") - 1; if l ^= 0 /* Digits after the decimal point. */ then do; if l < 0 then l = last - buffer_index; /* Trailing spaces and zeroes in the fraction part are not significant. If */ /* the fraction part is all zeroes and spaces, ignore it; otherwise set 'j' */ /* to the number of trailing zeroes and spaces and process it. */ j = verify (reverse (substr (rest_of_field, 1, l)), " 0") - 1; if j >= 0 then do; /* There is at least 1 significant digit. */ /* If there were any significant digits before the decimal point, then all */ /* but the last 'j' digits of the fraction part are significant. But if */ /* there were no significant digits before the decimal, leading spaces and */ /* zeroes in the fraction part are not significant. Set 'i' to the number */ /* of insignificant leading digits and spaces in the fraction part. Set */ /* 'e' to the number of decimal places before the first significant digit */ /* of the fraction part. */ if prec = 0 /* There were no digits before the decimal point. */ then do; i = verify (substr (rest_of_record, 1, l - j), " 0") - 1; if i < 0 then i = l - j; e = i; if blanks_as_null then do k = 1 to i; if substr (rest_of_field, k, 1) = " " then e = e - 1; end; end; else i = 0; call left_justify (addr (substr (rest_of_field, i + 1)), l - i - j, addr (substr (number.digit, prec + 1)), max_float - prec, str_len); e = e + str_len; prec = prec + str_len; end; buffer_index = buffer_index + l; if last - buffer_index = 0 then go to finish_float; end; ch = substr (rest_of_record, 1, 1); end; /* Either we have an exponent field or a syntax error. */ exp = 0; /* Wipe out scale factor. */ dexp = 0; /* Zero this field for expon conversion. */ if index (exps, ch) ^= 0 then do; buffer_index = buffer_index + 1; if last - buffer_index = 0 then call syntax_error; /* "e" as last character in field */ i = verify (rest_of_field, " "); if i = 0 then go to finish_float; buffer_index = buffer_index + i - 1; ch = substr (rest_of_record, 1, 1); end; if ch = "+" then do; buffer_index = buffer_index + 1; if buffer_index = last then call syntax_error; /* "+" as last character */ end; else if ch = "-" then do; substr (addr (dexp) -> chars, 1, 4) = "-000"; buffer_index = buffer_index + 1; if buffer_index = last then call syntax_error; /* "-" is the last char */ end; /* At this point we had better have digits or else the end of the field. */ if verify (rest_of_field, " 0123456789") - 1 >= 0 then do; buffer_index = buffer_index + (verify (substr (rest_of_field, 1, prec), " 0123456789") - 1); call bad_char; end; /* Leading spaces and zeroes are not significant: Skip them. */ i = verify (rest_of_field, " 0") - 1; if i < 0 then goto finish_float; buffer_index = buffer_index + i; /* Store the digits of the exponent in 'dexp', then assign it to 'exp'. */ call right_justify (addr (rest_of_field), length (rest_of_field), addr (substr (addr (dexp) -> chars, 2)), 3, str_len); exp = dexp; finish_float: if prec = 0 then go to store_zero; e = exp - e + prec - max_float; if e >= 255 then call conversion_error; else if e <= -256 then call conversion_error; flt_dec.exp = e; if fio_ps.job_bits.hfp then bin_type = 3; else bin_type = 1; if fio_ps.double then bin_type = bin_type + 1; call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), addr (work), ext_float_decimal, (max_float)); goto countdown_element; unpack_format (33): call unpack_two; infinite_format = "0"b; format_routine (33): /* input l-format */ if element_count = 0 then go to fmt_done; last = last + field.width; call read_buffer; i = verify (substr (rest_of_field, 1, field.width), " "); logical = "0"b; if i > 0 then do; if substr (rest_of_field, i, 1) = "t" | substr (rest_of_field, i, 1) = "T" then logical = "1"b; else if substr (rest_of_field, i, min (field.width - i + 1, 2)) = ".t" | substr (rest_of_field, i, min (field.width - i + 1, 2)) = ".T" then logical = "1"b; end; goto countdown_element; unpack_format (35): call unpack_two; infinite_format = "0"b; format_routine (35): /* input o-format */ if element_count = 0 then go to fmt_done; last = last + field.width; call read_buffer; begin_index = buffer_index; /* For error message. */ i = verify (substr (rest_of_field, 1, field.width), " ") - 1; if i < 0 then do; if fio_ps.double then fio_ps.element_p -> double_word = 0; else fio_ps.element_p -> words (1) = 0; goto countdown_element; end; buffer_index = buffer_index + i; if substr (rest_of_field, 1, 1) = "-" then do; buffer_index = buffer_index + 1; negate = -1; end; else if substr (rest_of_field, 1, 1) = "+" then do; buffer_index = buffer_index + 1; negate = 0; end; else negate = 0; addr (work) -> double_word = 0; in = (24 - (last - buffer_index)) * 3; do buffer_index = buffer_index to last - 1; ch = substr (rest_of_record, 1, 1); if ch ^= " " then do; base = index ("01234567", ch) - 1; if base < 0 then call bad_char; if in >= 0 then substr (addr (work) -> based_bits, in + 1, 3) = bit (base, 3); end; in = in + 3; end; if negate < 0 then addr (work) -> double_word = -addr (work) -> double_word; if fio_ps.double then fio_ps.element_p -> double_word = addr (work) -> double_word; else fio_ps.element_p -> words (1) = addr (work) -> words (2); goto countdown_element; unpack_format (7): unpack_format (8): unpack_format (37): unpack_format (38): format_routine (37): format_routine (38): /* Illegal types. */ format_routine (7): format_routine (8): call print_error (fortran_io_error_$fio_sys_error, me, "Invalid format."); unpack_format (39): call unpack_two; infinite_format = "0"b; format_routine (39): /* Input "r" format. */ if element_count = 0 then go to fmt_done; last = last + field.width; call read_buffer; if field.width - char_len >= 0 then do; buffer_index = buffer_index + (field.width - char_len); in = char_len; j = 0; end; else do; in = field.width; unspec (substr (fio_ps.element_p -> chars, 1, char_len)) = "0"b; j = char_len - field.width; end; substr (fio_ps.element_p -> chars, j + 1, in) = substr (rest_of_record, 1, in); go to countdown_element; unpack_format (9): call unpack_two; infinite_format = "0"b; format_routine (9): /* Output "r" format. */ if element_count = 0 then go to fmt_done; last = last + field.width; call expand_buffer; if field.width - char_len > 0 then do; substr (rest_of_record, 1, field.width - char_len) = " "; buffer_index = buffer_index + (field.width - char_len); j = 0; end; else j = char_len - field.width; substr (rest_of_record, 1, char_len - j) = substr (fio_ps.element_p -> chars, j + 1, char_len - j); go to countdown_element; unpack_format (10): call unpack_two; effective_digits = field.width; infinite_format = "0"b; format_routine (10): /* Output "a" format. */ if element_count = 0 then go to fmt_done; /* since width must ALWAYS be positive, a ZERO value means use unspecified a_format, i.e., let the width of the field be the number of characters in the data item */ if field.width = 0 then effective_digits = char_len; last = last + effective_digits; call expand_buffer; if effective_digits - char_len > 0 then do; substr (rest_of_record, 1, effective_digits - char_len) = " "; buffer_index = buffer_index + (effective_digits - char_len); i = char_len; end; else i = effective_digits; substr (rest_of_record, 1, i) = substr (fio_ps.element_p -> chars, 1, i); go to countdown_element; unpack_format (40): call unpack_two; effective_digits = field.width; infinite_format = "0"b; format_routine (40): /* Input "a" format. */ if element_count = 0 then go to fmt_done; if field.width = 0 /* see comment on output for signifigance */ then effective_digits = char_len; last = last + effective_digits; call read_buffer; if effective_digits - char_len > 0 then do; buffer_index = buffer_index + (effective_digits - char_len); in = char_len; end; else in = effective_digits; substr (fio_ps.element_p -> chars, 1, char_len) = substr (rest_of_record, 1, in); go to countdown_element; unpack_format (11): unpack_format (19): call unpack_two; format_routine (11): /* Output hollerith field. */ format_routine (19): last = last + field.rep_factor; call expand_buffer; substr (rest_of_record, 1, field.rep_factor) = substr (in_fmt, field.width, field.rep_factor); buffer_index = last; goto get_next_format; unpack_format (41): unpack_format (49): call unpack_two; format_routine (41): /* Input hollerith field. */ format_routine (49): last = last + field.rep_factor; call read_buffer; substr (in_fmt, field.width, field.rep_factor) = substr (rest_of_record, 1, field.rep_factor); buffer_index = last; goto get_next_format; unpack_format (42): unpack_format (12): call unpack_one; format_routine (42): /* Input X format. */ format_routine (12): /* Output X format. */ last = last + field.rep_factor; if op_offset = WRITE_ & ^fio_ps.ansi_77 then do; /* Transmit specified number of spaces. */ call expand_buffer; substr (rest_of_record, 1, field.rep_factor) = ""; end; buffer_index = last; goto get_next_format; unpack_format (43): unpack_format (51): unpack_format (13): unpack_format (21): call unpack_two; format_routine (43): /* Input T format. */ format_routine (51): /* Input TL or TR formats. */ format_routine (13): /* Output T format. */ format_routine (21): /* Output TL or TR formats. */ if field.spec = t_format | field.spec = t_format + op_offset then last = field.width - 1 + column_one; else last = max (column_one, field.width + last); if op_offset = WRITE_ & ^fio_ps.ansi_77 then call read_buffer; buffer_index = last; goto get_next_format; unpack_format (14): unpack_format (44): call unpack_one; format_routine (44): /* Process scale factor here. */ format_routine (14): FORMAT.scale = field.rep_factor; go to get_next_format; unpack_format (15): unpack_format (45): call unpack_one; format_routine (45): format_routine (15): /* "(" Check maximum level of parentheses. */ FORMAT.paren_level = FORMAT.paren_level + 1; if FORMAT.paren_level > hbound (FORMAT.restart, 1) then call print_error (fortran_io_error_$parens_too_deep, me, "Maximum is ^d.", hbound (FORMAT.restart, 1)); FORMAT.rep_factor (FORMAT.paren_level) = field.rep_factor; FORMAT.restart (FORMAT.paren_level) = FORMAT.indx; go to get_next_format; unpack_format (16): unpack_format (46): format_routine (46): format_routine (16): /* ")" Bump counter and move on if done. */ if FORMAT.paren_level <= 0 then goto get_next_format; FORMAT.rep_factor (FORMAT.paren_level) = FORMAT.rep_factor (FORMAT.paren_level) - 1; if FORMAT.rep_factor (FORMAT.paren_level) <= 0 then FORMAT.paren_level = FORMAT.paren_level - 1; else FORMAT.indx = FORMAT.restart (FORMAT.paren_level); go to get_next_format; countdown_element: element_count = element_count - 1; call advance_element_p; buffer_index = last; field.rep_factor = field.rep_factor - 1; if field.rep_factor <= 0 then goto get_next_format; go to format_routine (field.spec); unpack_format (18): unpack_format (48): format_routine (48): /* :-format */ format_routine (18): if element_count = 0 then go to fmt_done; go to get_next_format; unpack_format (50): format_routine (50): /* End of format statement for input. */ if element_count = 0 then goto fmt_done; if infinite_format then call print_error (fortran_io_error_$format_is_infinite); infinite_format = "1"b; FORMAT.indx = format_p -> runtime_format.last_left_paren; FORMAT.paren_level = 0; unpack_format (47): format_routine (47): /* "/" Start a new input record. */ call read_a_record; buffer_index, last = 0; if skip_line_numbers then call strip_line_no (/* buffer_index, last */); goto get_next_format; unpack_format (20): format_routine (20): /* End of format statement for output. */ if element_count = 0 then do; fmt_done: return; end; if infinite_format then call print_error (fortran_io_error_$format_is_infinite); infinite_format = "1"b; FORMAT.indx = format_p -> runtime_format.last_left_paren; FORMAT.paren_level = 0; if suppress_final_newline then go to get_next_format; unpack_format (17): format_routine (17): /* "/" Start a new output record. */ call write_a_record; buffer_index, last = buffer_length; goto get_next_format; unpack_format (25): unpack_format (55): format_routine (25): format_routine (55): /* BN format - treat blanks as null */ blanks_as_null = "1"b; goto get_next_format; unpack_format (26): unpack_format (56): format_routine (26): format_routine (56): /* BZ format - treat blanks as zero */ blanks_as_null = "0"b; goto get_next_format; unpack_format (27): unpack_format (57): format_routine (27): /* S format (ansi77) */ format_routine (57): /* leading plus sign on output processor dependent */ must_produce_plus = "0"b; goto get_next_format; unpack_format (28): unpack_format (58): format_routine (28): /* SP format (ansi77) */ format_routine (58): /* leading plus sign required on output */ must_produce_plus = "1"b; goto get_next_format; unpack_format (29): unpack_format (59): format_routine (29): /* SS format (ansi77) */ format_routine (59): /* leading plus sign forbidden on output */ must_produce_plus = "0"b; goto get_next_format; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ print_zero: call minus_sign; /* all relevant values are already calculated */ if add_zero /* also calculated */ then do; substr (rest_of_record, 1, 1) = "0"; buffer_index = buffer_index + 1; end; substr (rest_of_record, 1, 1) = "."; if field.precision > 0 then substr (rest_of_record, 2, field.precision) = copy ("0", field.precision); buffer_index = buffer_index + (field.precision + 1); if buffer_index = last then goto countdown_element; /* f-format exits here */ if FORMAT.scale > 0 & field.precision ^= 0 then substr (rest_of_field, 1, 1) = "0"; if field.spec = d_format then substr (io_buf, last - digits_after_E - 1, 2) = "D+"; else substr (io_buf, last - digits_after_E - 1, 2) = "E+"; substr (io_buf, last - digits_after_E + 1, digits_after_E) = copy ("0", digits_after_E); goto countdown_element; print_stars: substr (rest_of_field, 1, field.width) = copy ("*", field.width); go to countdown_element; print_blanks: substr (rest_of_field, 1, field.width) = copy (SP, field.width); go to countdown_element; /* Entry to initialize formatted I/O. */ initialize_formatted_io: entry; if fio_ps.read then buffer_index = 0; /* Must be set before call to print_error */ if PS.user_format_p -> runtime_format.version = fmt_parse_ver1 then format_p = PS.user_format_p; else do; call general_format_parse_$runtime (in_fmt, work_str, (fio_ps.ansi_77), my_code); if my_code ^= 0 then call print_error (fortran_io_error_$format_error, me, "^a^/""^a""", addr (work_str) -> error_message, substr (in_fmt, 1, addr (work_str) -> input_length)); else format_p = addr (work_str); end; have_runtime_format = "1"b; skip_line_numbers = format_p -> runtime_format.skip_line_numbers; if format_p -> runtime_format.suppress_newline then suppress_final_newline = "1"b; must_produce_plus = "0"b; blanks_as_null = file_desc.blank_null; if format_p -> runtime_format.list_directed /* If v-format then this is list-directed I/O */ then do; if fio_ps.read then if skip_line_numbers then call strip_line_no (); go to initiate_routine (0); end; if fio_ps.list & ^format_p -> runtime_format.anyitems /* format would loop forever */ then call print_error (fortran_io_error_$format_is_infinite); /* Initialize local variables. */ buffer_index = 0; /* Must be set before call to strip_line_no */ last = 0; FORMAT.indx = 1; FORMAT.paren_level = 0; FORMAT.scale = 0; element_count = 0; infinite_format = "0"b; if fio_ps.read then do; if skip_line_numbers then call strip_line_no (/* buffer_index, last */); op_offset = READ_; overflow_label = conversion_error_handler; zero_label = no_handler; end; else do; if skip_line_numbers then call print_error (fortran_io_error_$format_error, me, "Line number stripping only allowed during input."); op_offset = WRITE_; overflow_label = print_stars; zero_label = print_stars; end; goto get_next_format; /* Internal procedures to unpack format specifiactions. */ unpack_one: proc; if fmt_ptr -> format.long_format then field.rep_factor = fmt_ptr -> long_format.rep_factor; else field.rep_factor = fmt_ptr -> format.rep_factor; end unpack_one; unpack_two: proc; if fmt_ptr -> format.long_format then do; FORMAT.indx = FORMAT.indx + 1; field.rep_factor = fmt_ptr -> long_format.rep_factor; field.width = fmt_ptr -> long_format.width; end; else do; field.rep_factor = fmt_ptr -> format.rep_factor; field.width = fmt_ptr -> format.width; end; end unpack_two; unpack_three: proc; if fmt_ptr -> format.long_format then do; FORMAT.indx = FORMAT.indx + 1; field.rep_factor = fmt_ptr -> long_format.rep_factor; field.width = fmt_ptr -> long_format.width; field.precision = fmt_ptr -> long_format.precision; end; else do; field.rep_factor = fmt_ptr -> format.rep_factor; field.width = fmt_ptr -> format.width; field.precision = fmt_ptr -> format.precision; end; end unpack_three; unpack_four: proc; if fmt_ptr -> format.long_format then do; FORMAT.indx = FORMAT.indx + 1; field.rep_factor = fmt_ptr -> long_format.rep_factor; field.width = fmt_ptr -> long_format.width; field.precision = fmt_ptr -> long_format.precision; field.exponent = fmt_ptr -> long_format.exponent; end; else do; field.rep_factor = fmt_ptr -> format.rep_factor; field.width = fmt_ptr -> format.width; field.precision = fmt_ptr -> format.precision; field.exponent = 0; end; end unpack_four; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedures to convert from binary to character under format control. */ start_floating: proc; if negate ^= 0 then leading_sign = MINUS_SIGN; else if must_produce_plus then do; negate = 1; leading_sign = PLUS_SIGN; end; /* Check if there is room for a leading zero. */ i = field.precision + i + negate; if i > field.width then go to print_stars; if i < field.width then do; add_zero = "1"b; i = i + 1; end; else add_zero = "0"b; end start_floating; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ create_decimal: proc; if fio_ps.job_bits.hfp then bin_type = 3; else bin_type = 1; if fio_ps.double then bin_type = bin_type + 1; if prec <= 0 | prec > max_float then go to print_stars; call assign_round_ (addr (work), decimal_type, decimal_len, fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type)); count = verify (number.digit, "0") - 1; if count < 0 then go to print_zero; end create_decimal; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ minus_sign: proc; if field.width - i > 0 then do; substr (rest_of_record, 1, field.width - i) = " "; buffer_index = buffer_index + (field.width - i); end; /* Put out leading sign if it is required. */ if negate ^= 0 then do; substr (rest_of_record, 1, 1) = leading_sign; buffer_index = buffer_index + 1; end; end minus_sign; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to maintain output buffer size and incidentally detect some end of file conditions in internal_files */ expand_buffer: proc; if last > buffer_max_len then if fio_ps.mode = internal_file & internal_file_count <= 0 then call internal_file_overflow; else call too_much_output; if last > buffer_length then do; if buffer_index > buffer_length then substr (io_buf, buffer_length + 1, buffer_index - buffer_length) = ""; buffer_length = last; end; end expand_buffer; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to grow a read buffer and blank the grown area. */ read_buffer: proc; if last > buffer_max_len then if op_offset = WRITE_ then call too_much_output; else call too_much_input; if last <= buffer_length then return; substr (io_buf, buffer_length + 1, last - buffer_length) = " "; buffer_length = last; end read_buffer; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to store a given character string left justified in */ /* another string, with spaces optionally deleted. */ left_justify: proc (source_ptr, source_len, result_ptr, result_len, chars_stored); dcl source_ptr ptr, /* Address of source string. */ source_len fixed bin, /* Length of source string. */ result_ptr ptr, /* Address of result string. */ result_len fixed bin, /* Length of result string. */ chars_stored fixed bin; /* Number of chars stored in result. */ dcl piece_len fixed bin, source_idx fixed bin; dcl result char (result_len) based (result_ptr), source char (source_len) based (source_ptr); chars_stored = 0; if blanks_as_null then do source_idx = source_len + 1 - length (ltrim (source)) repeat source_len + 1 - length (ltrim (substr (source, source_idx + piece_len))) while (source_idx <= source_len); piece_len = length (before (substr (source, source_idx), " ")); if chars_stored + piece_len > result_len then call conversion_error; substr (result, chars_stored + 1, piece_len) = substr (source, source_idx, piece_len); chars_stored = chars_stored + piece_len; end; else do; if source_len > result_len then call conversion_error; substr (result, 1, source_len) = source; chars_stored = source_len; end; end left_justify; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to store a given character string right justified in */ /* another string, optionally deleting spaces. */ right_justify: proc (source_ptr, source_len, result_ptr, result_len, chars_stored); dcl source_ptr ptr, /* Address of source string. */ source_len fixed bin, /* Length of source string. */ result_ptr ptr, /* Address of result string. */ result_len fixed bin, /* Length of result string. */ chars_stored fixed bin; /* Number of chars stored in result. */ dcl piece_len fixed bin, source_limit fixed bin; dcl result char (result_len) based (result_ptr), source char (source_len) based (source_ptr); chars_stored = 0; if blanks_as_null then do source_limit = length (rtrim (source)) repeat length (rtrim (substr (source, 1, source_limit - piece_len))) while (source_limit > 0); piece_len = length (before (reverse (substr (source, 1, source_limit)), " ")); if chars_stored + piece_len > result_len then call conversion_error; chars_stored = chars_stored + piece_len; substr (result, result_len + 1 - chars_stored, piece_len) = substr (source, source_limit + 1 - piece_len, piece_len); end; else do; if chars_stored > result_len then call conversion_error; substr (result, result_len + 1 - source_len, source_len) = source; chars_stored = source_len; end; end right_justify; end formatted_io; /* Namelist and list-directed I/O */ namelist_io: proc; dcl string builtin; /* To override some structure declarations. */ dcl 1 ok_list aligned based (ok_pt), 2 number fixed bin, 2 list (100) fixed bin (17) unal, 1 acc aligned based, 2 name_size unal bit (9), 2 name_string char (name_ln) unal, (headings, rep_factor, namelist, comma_encountered, comma_required, legal_end, null_value) bit (1) aligned, (name_ln, dims) fixed bin (18); dcl temp fixed bin (21); dcl c_temp (2) float bin (27); dcl factor fixed bin (18); dcl stu_$get_runtime_address ext entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr), stu_$find_runtime_symbol ext entry (ptr, char (*) aligned, ptr, fixed bin) returns (ptr), stu_$decode_runtime_value entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr, fixed bin (35)) returns (fixed bin (35)); dcl namelist_name_len fixed bin, namelist_name char (namelist_name_len) based (namelist_name_ptr); dcl integer fixed bin (35) aligned based, /* for integer variables */ logical bit (1) aligned based, /* for logical variables */ 1 complex_value aligned based, 2 real float bin (27), 2 imag_part float bin (27); dcl (data_type, constant_type) fixed bin (6), ( integer_type fixed bin (6) init (1), real_type fixed bin (6) init (2), double_type fixed bin (6) init (3), complex_type fixed bin (6) init (4), logical_type fixed bin (6) init (5), character_type fixed bin (6) init (6), headers char (2) init ("$&"), delims char (5) init (" ,/;"), /* SP TAB , / ; */ alphameric char (64) init ("0123456789$_ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), digits char (10) init ("0123456789"), numerics char (13) init ("+-0123456789."), log char (4) init ("tfTF") ) aligned int static options (constant), runtime_table (48) aligned fixed bin (6) internal static options (constant) init (1, 0, 2, 3, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3); dcl (n, subscripts) fixed bin (18); dcl subscript_array (7) fixed bin (18); dcl repetition_count fixed bin (18); %include runtime_symbol; /* Put useful information into automatic storage. */ ok_pt = PS.namelist_p; /* Pointer to namelist list of variables. */ sp = PS.stack_frame_p; /* Stack frame pointer. */ table_pt = PS.symbol_table_top_p; /* Symbol table pointer. */ text_pt, link_pt = null; buffer_index = 0; /* Index for substr. */ namelist = "1"b; /* Tell the utilities who we are. */ /* Pick up namelist name. */ symbol_pt, block_pt = addrel (table_pt, ok_list.list (1)); /* Pick up block pointer from namelist symbol. Otherwise block is possibly incorrect. bug 372. Scan entries until we get the right level. */ if fixed (block_pt -> runtime_symbol.level, 6, 0) <= 1 then block_pt = addrel (block_pt, block_pt -> runtime_symbol.father); else do while (fixed (block_pt -> runtime_symbol.level, 6, 0) > 1); block_pt = addrel (block_pt, block_pt -> runtime_symbol.father); end; /* Decide on direction of transmission. */ if fio_ps.read then go to read; /* Set format control switches for output. */ headings = ^(file_desc.printer_file & file_desc.carriage_controllable); /* Create and output a header record if this is not a print file. */ if headings then do; name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name); name_ln = fixed (name_pt -> acc.name_size, 9); if buffer_length + (name_ln + 2) > buffer_max_len then call too_much_output; substr (rest_of_output, 1, name_ln + 2) = "$" || name_pt -> acc.name_string || SP; buffer_length = buffer_length + (name_ln + 2); end; else do; if buffer_length = buffer_max_len then call too_much_output; substr (rest_of_output, 1, 1) = SP; buffer_length = buffer_length + 1; end; /* Go through and print everybody. */ do count = 2 to ok_pt -> ok_list.number; /* Pick up variable name and print it. */ symbol_pt = addrel (table_pt, ok_list.list (count)); subs_pt = null; /* May have been set by last variable. */ call decode_runtime; if buffer_length + (name_ln + 3) > buffer_max_len then call too_much_output; substr (rest_of_output, 1, name_ln + 3) = name_pt -> acc.name_string || " = "; buffer_length = buffer_length + (name_ln + 3); /* Print out all the elements. */ do n = 1 to element_count; if fio_ps.ansi_77 then call ansi77_output; /* Use '77 style of output. */ else call ansi66_output; /* Use '66 style of output. */ if count ^= ok_pt -> ok_list.number | n ^= element_count then do; if buffer_length >= buffer_max_len - 1 then call too_much_output; if headings then substr (rest_of_output, 1, 2) = ","; else substr (rest_of_output, 1, 2) = " "; if fio_ps.ansi_77 then buffer_length = buffer_length + 2; else buffer_length = buffer_length + 1; end; end; end; /*Loop through namelist. */ /* Output trailer if necessary. */ if headings then do; if buffer_length = buffer_max_len then call too_much_output; substr (rest_of_output, 1, 1) = "$"; buffer_length = buffer_length + 1; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Namelist input. */ read: constant_ptr = addr (work_str); count_pt = null; name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name); namelist_name_len = fixed (name_pt -> acc.name_size, 9); namelist_name_ptr = addr (name_pt -> acc.name_string); /* Find header record. */ find_header: call get_field; if index (headers, substr (rest_of_record, 1, 1)) = 0 then go to missing_header; else buffer_index = buffer_index + 1; if buffer_length - buffer_index < namelist_name_len then do; missing_header: call print_error (fortran_io_error_$missing_header, me, """$^a""", namelist_name); call buffer_read; go to find_header; end; if substr (rest_of_record, 1, namelist_name_len) ^= namelist_name then do; if ^fio_ps.fold then go to missing_header; /* Must match exactly */ if translate (substr (rest_of_record, 1, namelist_name_len), lower_letters, capital_letters) ^= namelist_name then go to missing_header; end; buffer_index = buffer_index + namelist_name_len; /* Insure we don't have a substr of something else. */ call check_end; if ^legal_end then go to missing_header; /* Get the next variable or return. */ get_name: call get_field; /* check for end of namelist input. */ if index (headers, substr (rest_of_record, 1, 1)) ^= 0 then if count_pt = null then do; fio_ps.have_input = "0"b; /* no longer relevant */ return; end; else call print_error (fortran_io_error_$syntax_error, me, "No variable follows ""/""."); i = verify (rest_of_record, alphameric) - 1; if i < 0 then i = buffer_length - buffer_index; else if i = 0 then call print_error (fortran_io_error_$syntax_error, me, "Variable name is missing."); /* Look it up in the runtime symbol tables. */ symbol_pt = stu_$find_runtime_symbol (block_pt, substr (rest_of_record, 1, i), null, 0); if symbol_pt = null then do; if ^fio_ps.fold /* If symbols not folded */ then symbol_abort: call print_error (fortran_io_error_$namelist_error, me, "^a is not a member of $^a.", substr (rest_of_record, 1, i), namelist_name); symbol_pt = stu_$find_runtime_symbol (block_pt, translate (substr (rest_of_record, 1, i), lower_letters, capital_letters), null (), 0); if symbol_pt = null () then go to symbol_abort; /* Couldn't find it folded, either */ end; do k = 2 to ok_pt -> ok_list.number; if addrel (table_pt, ok_list.list (k)) = symbol_pt then go to legal_symbol; end; go to symbol_abort; legal_symbol: buffer_index = buffer_index + i; call get_field; /* Process "count variable" and save for later. */ if count_pt = null then if ch = "/" then do; count_pt = symbol_pt; buffer_index = buffer_index + 1; call get_field; go to get_name; end; /* Process subscripts. */ if ch = "(" then do; subs_pt = addr (subscript_array); buffer_index = buffer_index + 1; do subscripts = 1 to 7; call get_field; call input_float; if constant_type ^= integer_type then go to bad_subs; if constant_ptr -> integer = 0 then go to bad_subs; subscript_array (subscripts) = constant_ptr -> integer; call check_end; if ^comma_encountered then goto check_paren; end; check_paren: if substr (rest_of_record, 1, 1) ^= ")" then call print_error (fortran_io_error_$syntax_error, me, "Missing "")""."); buffer_index = buffer_index + 1; call get_field; end; else subscripts = 0; /* Must have "=" here. */ if ch ^= "=" then call print_error (fortran_io_error_$syntax_error, me, "Missing ""=""."); buffer_index = buffer_index + 1; /* Validate subscripts. Also supply subscripts the user may have omitted. */ name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name); name_ln = fixed (name_pt -> acc.name_size, 9); i = fixed (symbol_pt -> runtime_symbol.ndims, 6); if subscripts > i then call print_error (fortran_io_error_$syntax_error, me, "More subscripts than dimensions for ^a.", name_pt -> acc.name_string); if subscripts > 0 then do; do k = subscripts + 1 to i; /* Fill in dimensions not specified. */ subscript_array (k) = 1; end; do k = 1 to divide (i, 2, 17, 0); /* Reverse order for stu_. */ j = subscript_array (i - k + 1); subscript_array (i - k + 1) = subscript_array (k); subscript_array (k) = j; end; do k = 1 to subscripts; l = stu_$decode_runtime_value (symbol_pt -> runtime_symbol.bounds (k).upper, block_pt, sp, link_pt, text_pt, null, my_code); if my_code ^= 0 then bound_error: call print_error (fortran_io_error_$syntax_error, me, "Cannot get bounds information for ^a.", name_pt -> acc.name_string); if subscript_array (k) > l then bad_subs: call print_error (fortran_io_error_$syntax_error, me, "Subscript is out of range or invalid."); end; end; else subs_pt = null; /* Get symbol information. */ call decode_runtime; /* Read in and store values. */ count = 0; /* Input loop. */ do while (element_count > 0); factor = 1; rep_factor = "0"b; get_value: call get_field; if ch = "," then do n = 1 to factor; call store_null; end; else do; if index ("""'", ch) ^= 0 then call input_charstr; else if ch = "(" then do; call input_complex; end; else if ch = "." then do; if buffer_index + 1 >= buffer_length then call syntax_error; if index (digits, substr (rest_of_record, 2, 1)) = 0 then call input_logical; else call input_float; end; else if index (log, ch) ^= 0 then do; temp = buffer_index; /* Check for end is just a heuristic... */ buffer_index = buffer_index + 1; /* must determine if "t" or "f" is value or variable */ call check_end; buffer_index = temp; /* restore to previous position */ if ^legal_end then go to store_count; call input_logical; end; else if index (numerics, ch) ^= 0 then do; call input_float; if constant_type = integer_type then if buffer_index < buffer_length then if substr (rest_of_record, 1, 1) = "*" then do; if rep_factor then call bad_char; rep_factor = "1"b; factor = constant_ptr -> integer; if factor <= 0 then call print_error (fortran_io_error_$syntax_error, me, "Repetition count is less than one."); if factor > element_count then call print_error (fortran_io_error_$namelist_error, me, "Repetition factor is greater than remaining elements.(^d > ^d).", factor, element_count); buffer_index = buffer_index + 1; go to get_value; end; else if index ("hH", substr (rest_of_record, 1, 1)) ^= 0 then do; i = constant_ptr -> integer; if i <= 0 then call print_error (fortran_io_error_$syntax_error, me, "Hollerith constant length must be positive."); str_len = 0; buffer_index = buffer_index + 1; /* Skip "h". */ call build_string (i); end; end; else if rep_factor then call print_error (fortran_io_error_$syntax_error, me, "No value follows a repetition factor."); else go to store_count; /* Store the constant. */ do n = 1 to factor; call store; end; end; /* Non-null constant. */ /* Common for all constants. Update various counts. */ call check_end; if ^legal_end then call bad_char; element_count = element_count - factor; count = count + factor; end; /* Input loop. */ store_count: if count_pt ^= null then do; subs_pt = null; symbol_pt = count_pt; call decode_runtime; constant_ptr -> integer = count; dec_int = count; constant_type = integer_type; call store; count_pt = null; end; go to get_name; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* List directed I/O entry points. */ list_io: entry; namelist = "0"b; /* Tell utilities who we're not.*/ data_type = fio_data_type_index (fixed (substr (unspec (fio_ps.element_desc.data_type), 1, 6), 6, 0)); call set_size_and_count (char_len, element_count, chars_per_item); if fio_ps.read then do; constant_ptr = addr (work_str); legal_end = "1"b; /* First field is always ok. */ do while (element_count > 0); if repetition_count <= 0 then do; call list_input (); /* Read a value */ end; if null_value then call store_null (); else call store (); element_count = element_count - 1; repetition_count = repetition_count - 1; end; fio_ps.have_input = "0"b; end; /* List-directed output */ else if fio_ps.ansi_77 then do; /* Use '77 style of output. */ do n = 1 to element_count; if data_type_of_prev_item ^= character_type & data_type ^= character_type then do; /* Output a space for a separator. */ if buffer_length >= buffer_max_len then call too_much_output; substr (rest_of_output, 1, 1) = " "; buffer_length = buffer_length + 1; end; call ansi77_output; data_type_of_prev_item = data_type; end; end; else do; /* Use '66 style of output. */ do n = 1 to element_count; call ansi66_output; end; end; return; initialize_list_input: entry (); repetition_count = 0; null_value = "0"b; comma_required = "0"b; return; /* Internal procedure to read list directed values. */ list_input: procedure (); list_input_retry: call get_field; /* check of end of list-directed input. */ if ch = ";" | ch = "/" then do; fio_ps.have_input = "0"b; /* no longer relevant */ if fio_ps.ansi_77 then do; fio_ps.end_of_input = "1"b; goto element_list_abort; /* user has signalled end of input */ end; null_value = "1"b; /* ensure 0 or blanks are assigned to the list element in ansi 66 mode */ return; end; if comma_required then if ch = "," then do; buffer_index = buffer_index + 1; comma_required = "0"b; go to list_input_retry; end; else call print_error (fortran_io_error_$syntax_error, me, "A non-blank delimiter is required after a repeated null value."); if ch = "," then do; buffer_index = buffer_index + 1; /* Skip comma */ null_value = "1"b; return; end; null_value = "0"b; call check_repetition (); /* Check for r*c or r* */ if null_value then return; /* r* form */ go to free_input (data_type); free_input (1): free_input (2): free_input (3): call input_float; goto free_delim; free_input (4): /* complex */ if substr (rest_of_record, 1, 1) = "(" then do; /* complex constant */ call input_complex; end; else do; /* or two integers or reals */ do i = 1 to 2; if buffer_index >= buffer_length then call syntax_error; if substr (rest_of_record, 1, 1) = "," then do; c_temp (i) = 0.0; /* user omitted value */ buffer_index = buffer_index + 1; /* skip comma */ call check_end; /* gets nexts no white */ if ^legal_end then call bad_char; end; else call input_piece_of_complex (c_temp (i), "0"b); if comma_encountered then buffer_index = buffer_index - 1; end; unspec (constant_ptr -> complex_value) = unspec (c_temp); end; constant_type = complex_type; goto free_delim; free_input (5): call input_logical; go to free_delim; free_input (6): ch = substr (rest_of_record, 1, 1); if index ("""'", ch) ^= 0 then call input_charstr; else do; i = search (rest_of_record, delims) - 1; if i < 0 then i = buffer_length - buffer_index; str_len = 0; call build_string (i); end; free_delim: call check_end; if ^legal_end then call bad_char; /* Insure previous field ended ok. */ return; end list_input; check_repetition: procedure (); repetition_count = 1; if index (digits, ch) = 0 then return; i = verify (rest_of_record, digits); if i = 0 then return; if substr (rest_of_record, i, 1) ^= "*" then return; call input_float (); repetition_count = constant_ptr -> integer; if repetition_count <= 0 then call print_error (fortran_io_error_$syntax_error, me, "A repetition count in a list-directed input field must be greater than zero."); buffer_index = buffer_index + 1; /* Skip * */ call check_end (); if legal_end then do; null_value = "1"b; /* r* form */ comma_required = ^comma_encountered; end; end check_repetition; /* Internal procedure to output values in 'ansi66' mode. */ ansi66_output: proc; /* ansi66 output is formatted as "bb-.v(18)9es99" for double precision and "bb-.v(8)9es99" for single precision numbers. */ dcl dp_pic_len fixed bin int static options (constant) init (26), flt_pic_len fixed bin int static options (constant) init (16); dcl single_precision bit (1) int static options (constant) init ("1"b), double_precision bit (1) int static options (constant) init ("0"b); dcl number_string char (26); go to output_format (data_type); output_format (1): /* Integers. */ if buffer_length + length (int_pic) > buffer_max_len then call too_much_output; int_pic = fio_ps.element_p -> integer; substr (rest_of_output, 1, length (int_pic)) = int_pic; buffer_length = buffer_length + length (int_pic); go to output_return; output_format (2): /* Single precision real. */ j = 3; if buffer_length + flt_pic_len > buffer_max_len then call too_much_output; fake_complex: call ansi66_format (single_precision, fio_ps.element_p, number_string); substr (rest_of_output, 1, flt_pic_len) = substr (number_string, 1, flt_pic_len); buffer_length = buffer_length + flt_pic_len; go to real_part (j); output_format (3): /* Double precision real. */ if buffer_length + dp_pic_len > buffer_max_len then call too_much_output; call ansi66_format (double_precision, fio_ps.element_p, number_string); substr (rest_of_output, 1, dp_pic_len) = number_string; buffer_length = buffer_length + dp_pic_len; go to output_return; output_format (4): /* Complex. */ j = 1; if buffer_length + 2 * flt_pic_len + 5 > buffer_max_len then call too_much_output; substr (rest_of_output, 1, 2) = " ("; buffer_length = buffer_length + 2; go to fake_complex; real_part (1): /* Append comma after real part for namelist. */ substr (rest_of_output, 1, 2) = ", "; buffer_length = buffer_length + 2; fio_ps.element_p = addrel (fio_ps.element_p, 1); /* Point to imaginary part.*/ j = j + 1; /*Next set of functions.*/ go to fake_complex; real_part (2): /*Right paren for namelist.*/ substr (rest_of_output, 1, 1) = ")"; buffer_length = buffer_length + 1; fio_ps.element_p = addrel (fio_ps.element_p, -1); /* point to beginning of constant */ go to output_return; output_format (5): /* Logical */ if buffer_length + 2 > buffer_max_len then call too_much_output; if fio_ps.element_p -> logical then substr (rest_of_output, 1, 2) = " T"; else substr (rest_of_output, 1, 2) = " F"; buffer_length = buffer_length + 2; go to output_return; output_format (6): /* Character */ if buffer_length + char_len > buffer_max_len then call too_much_output; substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len); buffer_length = buffer_length + char_len; real_part (3): /*Kludge for real and DP.*/ output_return: call advance_element_p; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to format free format real and dp numbers in ansi66 mode. */ ansi66_format: proc (single_precision, binary_no_ptr, no_string); dcl single_precision bit (1); dcl binary_no_ptr pointer; dcl no_string char (26); dcl (first_digit, no_of_digits, trailing_zeros, precision) fixed bin; dcl exponent pic "s999"; dcl exp_char char (1); dcl dec_num float decimal (18); /* WARNING the following structure is based upon the internal representation of ext float decimal data. */ dcl 1 decimal_number structure aligned based (addr (dec_num)), 2 sign char (1) unaligned, 2 digits char (precision) unaligned, 2 exp fixed bin (8) unaligned; if fio_ps.job_bits.hfp then bin_type = 3; else bin_type = 1; if single_precision then do; precision = 8; exp_char = "E"; end; else do; precision = 18; bin_type = bin_type + 1; exp_char = "D"; end; call assign_round_ (addr (dec_num), ext_float_decimal, (precision), binary_no_ptr, binary_type (bin_type), binary_prec (bin_type)); first_digit = verify (decimal_number.digits, "0"); if first_digit = 0 /* special case if number is zero */ then do; first_digit = precision; exponent = 0; end; else exponent = decimal_number.exp + (precision - (first_digit - 1)); no_of_digits = precision - first_digit + 1; trailing_zeros = precision - no_of_digits; if decimal_number.sign = "+" then decimal_number.sign = " "; /* suppress leading "+" sign. */ substr (no_string, 1, 2) = " "; substr (no_string, 3, 2) = decimal_number.sign || "."; substr (no_string, 5, precision) = substr (decimal_number.digits, first_digit, no_of_digits) || copy ("0", trailing_zeros); if abs (exponent) > 99 /* drop the "E" */ then substr (no_string, precision + 5, 4) = exponent; else substr (no_string, precision + 5, 4) = exp_char || substr (exponent, 1, 1) || substr (exponent, 3, 2); end ansi66_format; end ansi66_output; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to output values in 'ansi77' mode. */ ansi77_output: proc; dcl more_pieces bit, num_sig_chars fixed bin, piece_idx fixed bin, piece_len fixed bin, piece_max_len fixed bin; dcl single_precision bit (1) int static options (constant) init ("1"b); dcl double_precision bit (1) int static options (constant) init ("0"b); dcl number_string char (30); dcl number_length fixed bin; go to output_format (data_type); output_format (1): /* Integers. */ int_pic = fio_ps.element_p -> integer; piece_idx = verify (int_pic, " "); /* Find first nonblank char. */ piece_len = length (int_pic) - piece_idx + 1; /* Find length of value. */ if buffer_length + piece_len > buffer_max_len then call too_much_output; substr (rest_of_output, 1, piece_len) = substr (int_pic, piece_idx, piece_len); buffer_length = buffer_length + piece_len; go to output_return; output_format (2): /* Single precision real. */ j = 3; convert_real_value: call ansi77_format (single_precision, fio_ps.element_p, number_string, number_length); if buffer_length + number_length > buffer_max_len then call too_much_output; substr (rest_of_output, 1, number_length) = substr (number_string, 1, number_length); buffer_length = buffer_length + number_length; go to real_part (j); output_format (3): /* Double precision real. */ call ansi77_format (double_precision, fio_ps.element_p, number_string, number_length); if buffer_length + number_length > buffer_max_len then call too_much_output; substr (rest_of_output, 1, number_length) = substr (number_string, 1, number_length); buffer_length = buffer_length + number_length; go to output_return; output_format (4): /* Complex. */ j = 1; if buffer_length >= buffer_max_len then call too_much_output; substr (rest_of_output, 1, 1) = "("; buffer_length = buffer_length + 1; go to convert_real_value; real_part (1): /* Append comma after real part for namelist. */ if buffer_length >= buffer_max_len then call too_much_output; substr (rest_of_output, 1, 1) = ","; buffer_length = buffer_length + 1; fio_ps.element_p = addrel (fio_ps.element_p, 1); /* Point to imaginary part.*/ j = j + 1; /*Next set of functions.*/ go to convert_real_value; real_part (2): /*Right paren for namelist.*/ if buffer_length >= buffer_max_len then call too_much_output; substr (rest_of_output, 1, 1) = ")"; buffer_length = buffer_length + 1; fio_ps.element_p = addrel (fio_ps.element_p, -1); /* point to beginning of constant */ go to output_return; output_format (5): /* Logical */ if buffer_length >= buffer_max_len then call too_much_output; if fio_ps.element_p -> logical then substr (rest_of_output, 1, 1) = "T"; else substr (rest_of_output, 1, 1) = "F"; buffer_length = buffer_length + 1; go to output_return; output_format (6): /* Character */ if namelist then do; /* Store quoted character value in buffer. */ if buffer_length >= buffer_max_len then call too_much_output; substr (rest_of_output, 1, 1) = "'"; buffer_length = buffer_length + 1; num_sig_chars = length (rtrim (substr (fio_ps.element_p -> chars, 1, char_len))); piece_idx = 1; more_pieces = TRUE; do while (more_pieces); piece_max_len = num_sig_chars - piece_idx + 1; piece_len = index (substr (fio_ps.element_p -> chars, piece_idx, piece_max_len), "'"); if piece_len = 0 then do; piece_len = piece_max_len; more_pieces = FALSE; end; if buffer_length + piece_len + 1 > buffer_max_len then call too_much_output; substr (rest_of_output, 1, piece_len) = substr (fio_ps.element_p -> chars, piece_idx, piece_len); substr (rest_of_output, piece_len + 1, 1) = "'"; buffer_length = buffer_length + piece_len + 1; piece_idx = piece_idx + piece_len; end; end; else do; /* Store raw character value in buffer. */ if buffer_length + char_len > buffer_max_len then call too_much_output; substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len); buffer_length = buffer_length + char_len; end; real_part (3): /*Kludge for real and DP.*/ output_return: call advance_element_p; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to format free format real and dp numbers in ansi77 mode. */ ansi77_format: proc (single_precision, binary_no_ptr, no_string, no_length); dcl single_precision bit (1); dcl binary_no_ptr ptr; dcl no_string char (30); dcl no_length fixed bin; dcl 1 output_number aligned structure based (addr (no_string)), 2 pad char (no_length) unaligned, 2 rest_of_number char (30) unaligned; dcl (precision, first_digit, no_of_digits, no_of_zeros, dpt, chars_in_exp) fixed bin; dcl exponent pic "s999"; dcl dec_num float decimal (18); /* WARNING the following structure is based upon the internal representation of ext float decimal data */ dcl 1 decimal_number structure aligned based (addr (dec_num)), 2 sign char (1) unaligned, 2 digits char (precision) unaligned, 2 exp fixed bin (8) unaligned; no_length = 0; if fio_ps.job_bits.hfp then bin_type = 3; else bin_type = 1; if ^single_precision then do; precision = 18; bin_type = bin_type + 1; end; else if fio_ps.job_bits.hfp then precision = 7; /* hex real numbers have only 7 dec digits */ else precision = 8; call assign_round_ (addr (dec_num), ext_float_decimal, (precision), binary_no_ptr, binary_type (bin_type), binary_prec (bin_type)); first_digit = verify (decimal_number.digits, "0"); if first_digit = 0 /* special case if the number is zero */ then do; first_digit = precision; no_of_digits = 1; exponent = 0; end; else do; no_of_digits = length (rtrim (substr (decimal_number.digits, first_digit), "0")); exponent = decimal_number.exp + (precision - first_digit); if decimal_number.sign = "-" then do; substr (rest_of_number, 1, 1) = "-"; no_length = no_length + 1; end; end; if exponent < -4 | exponent >= precision then do; /* E format */ if abs (exponent) < 100 then chars_in_exp = 4; else chars_in_exp = 5; if no_of_digits = 1 then dpt = 2; /* if no digits after the decimal point, we need */ else dpt = 1; /* a trailing zero. */ substr (rest_of_number, 1, 2) = substr (decimal_number.digits, first_digit, 1) || "."; if dpt = 2 then substr (rest_of_number, 3, 1) = "0"; else substr (rest_of_number, 3, no_of_digits - 1) = substr (decimal_number.digits, first_digit + 1, no_of_digits - 1); if chars_in_exp = 4 then substr (rest_of_number, no_of_digits + dpt + 1, 4) = "E" || substr (exponent, 1, 1) || substr (exponent, 3, 2); else substr (rest_of_number, no_of_digits + dpt + 1, 5) = "E" || exponent; no_length = no_length + no_of_digits + dpt + chars_in_exp; end; else do; /* F format */ if exponent < 0 then do; /* leading zeros needed */ no_of_zeros = abs (exponent) - 1; substr (rest_of_number, 1, no_of_zeros + 2) = "0." || copy ("0", no_of_zeros); substr (rest_of_number, no_of_zeros + 3, no_of_digits) = substr (decimal_number.digits, first_digit, no_of_digits); no_length = no_length + no_of_digits + no_of_zeros + 2; end; else if exponent >= (no_of_digits - 1) then do; /* trailing zeros may be needed */ no_of_zeros = exponent - no_of_digits + 1; substr (rest_of_number, 1, no_of_digits) = substr (decimal_number.digits, first_digit, no_of_digits); substr (rest_of_number, no_of_digits + 1, no_of_zeros + 2) = copy ("0", no_of_zeros) || ".0"; no_length = no_length + no_of_zeros + no_of_digits + 2; end; else do; /* decimal inside digits */ dpt = exponent + 1; substr (rest_of_number, 1, dpt + 1) = substr (decimal_number.digits, first_digit, dpt) || "."; substr (rest_of_number, dpt + 2, no_of_digits - dpt) = substr (decimal_number.digits, first_digit + dpt, no_of_digits - dpt); no_length = no_length + no_of_digits + 1; end; end; end ansi77_format; end ansi77_output; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to input a line from the file system. */ buffer_read: proc; call read_a_record (); buffer_index = 0; if have_runtime_format then if skip_line_numbers then call strip_line_no (); end buffer_read; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_field: proc; /* Finds first non-blank of field or the comma */ i = 0; /* get us into the loop */ do while (i = 0); do while (buffer_index >= buffer_length); /* get non blank line */ call buffer_read; end; i = verify (rest_of_record, white_space); if i = 0 then call buffer_read; /* rest of line is white; get another */ end; buffer_index = buffer_index + i - 1; ch = substr (rest_of_record, 1, 1); end get_field; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_end: proc; /* insure field ended neatly */ dcl ii fixed bin; legal_end = "1"b; comma_encountered = "0"b; if buffer_index >= buffer_length then return; ii = verify (rest_of_record, white_space) - 1; if ii < 0 /* rest of the line is white */ then do; buffer_index = buffer_length; return; end; buffer_index = buffer_index + ii; /* skip over white space */ ch = substr (rest_of_record, 1, 1); if ch = "," then do; comma_encountered = "1"b; buffer_index = buffer_index + 1; return; end; if namelist then if index (headers, ch) ^= 0 then return; else ; else if ch = ";" | ch = "/" then return; if ii = 0 then legal_end = "0"b; /* messy ending only if no white space */ end check_end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Internal procedure to handle runtime symbols. */ decode_runtime: proc; dcl VLA_based bit (4) static options (constant) init ("1010"b); /* Get symbol name. */ name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name); name_ln = fixed (name_pt -> acc.name_size, 9); /* Get symbol location. Note, pointer may not be to first element because of subs_pt. */ fio_ps.element_p = stu_$get_runtime_address (block_pt, symbol_pt, sp, link_pt, text_pt, null, subs_pt); /* Get number of dimensions and pointer to end of variable's storage. */ dims = fixed (symbol_pt -> runtime_symbol.ndims, 6); if dims > 0 then do; do j = 1 to dims; subscript_array (j) = stu_$decode_runtime_value (symbol_pt -> runtime_symbol.bounds (j).upper, block_pt, sp, link_pt, text_pt, null, my_code); if my_code ^= 0 then go to bound_error; end; end_pt = stu_$get_runtime_address (block_pt, symbol_pt, sp, link_pt, text_pt, null, addr (subscript_array)); end; else end_pt = fio_ps.element_p; /* Get data type. */ j = fixed (symbol_pt -> runtime_symbol.type, 6); if j <= 0 | j > hbound (runtime_table, 1) then go to unknown_type; data_type = runtime_table (j); if data_type = 0 then unknown_type: call print_error (fortran_io_error_$namelist_error, me, "Invalid data type ^d for ^a.", j, name_pt -> acc.name_string); /* Get character length, word length, and number of elements. */ if data_type = character_type then char_len = symbol_pt -> runtime_symbol.size; else if data_type = double_type | data_type = complex_type then char_len = CPDW; else char_len = CPW; /* for ansi66 character arrays are padded out, round up to the nearest whole word, otherwise the chars_per_item is the char_len */ if data_type = character_type & ^fio_ps.ansi_77 then chars_per_item = char_len - mod (char_len, -CPW); else chars_per_item = char_len; /* Check if the symbol is a VLA and calculate 'element_count' accordingly. */ if symbol_pt -> runtime_symbol.class = VLA_based then do; fio_ps.element_desc.VLA = TRUE; element_count = divide ((fixed (baseno (end_pt)) - fixed (baseno (fio_ps.element_p))) * 4 * pl1_operators_$VLA_words_per_seg_ + char_pos (end_pt) - char_pos (fio_ps.element_p), chars_per_item, 24, 0) + 1; end; else do; fio_ps.element_desc.VLA = FALSE; element_count = divide (char_pos (end_pt) - char_pos (fio_ps.element_p), chars_per_item, 24, 0) + 1; end; end decode_runtime; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Procedure to store a null value. */ store_null: proc; if fio_ps.ansi_77 then go to null_bump; /* Do nothing */ go to make_null (data_type); make_null (1): fio_ps.element_p -> integer = 0; go to null_bump; make_null (4): fio_ps.element_p -> complex_value.imag_part = 0.0; make_null (2): fio_ps.element_p -> real = 0.0; go to null_bump; make_null (3): fio_ps.element_p -> based_dp = 0.0; go to null_bump; make_null (5): fio_ps.element_p -> logical = "0"b; go to null_bump; make_null (6): substr (fio_ps.element_p -> chars, 1, char_len) = SP; null_bump: call advance_element_p; end store_null; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Procedure to store constant into variable, depending on data types. */ store: proc; if fio_ps.job_bits.hfp then bin_type = 3; else bin_type = 1; go to validate_store (data_type * 6 + constant_type - 7); validate_store (0): /* integer - integer */ validate_store (7): /* real - real */ validate_store (28): /* logical - logical */ fio_ps.element_p -> words (1) = constant_ptr -> words (1); /* copy without conversion */ goto store_bump; validate_store (14): /* double precision - double precision */ validate_store (21): /* complex - complex */ fio_ps.element_p -> based_bits = constant_ptr -> based_bits; /* copy without conversion */ go to store_bump; validate_store (1): /* integer - real */ call assign_round_ (fio_ps.element_p, integer_dtype, integer_prec, constant_ptr, binary_type (bin_type), binary_prec (bin_type)); go to store_bump; validate_store (2): /* integer - double precision */ bin_type = bin_type + 1; /* double precision binary type */ call assign_round_ (fio_ps.element_p, integer_dtype, integer_prec, constant_ptr, binary_type (bin_type), binary_prec (bin_type)); go to store_bump; validate_store (3): /* integer - complex */ validate_store (9): /* real - complex */ validate_store (15): /* double precision - complex */ call print_error (fortran_io_error_$syntax_error, me, "Complex constants can only be used as input for complex variables."); validate_store (4): /* integer - logical */ validate_store (10): /* real - logical */ validate_store (16): /* double precision - logical */ validate_store (22): /* complex - logical */ call print_error (fortran_io_error_$syntax_error, me, "Numeric variables may not be assigned logical values."); validate_store (5): /* integer - character */ validate_store (11): /* real - character */ validate_store (17): /* double precision - character */ validate_store (23): /* complex - character */ validate_store (35): /* character - character */ substr (fio_ps.element_p -> chars, 1, char_len) = substr (work_str, 1, str_len); go to store_bump; validate_store (18): /* complex - integer */ fio_ps.element_p -> complex_value.imag_part = 0.0; validate_store (6): /* real - integer */ call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), constant_ptr, integer_dtype, integer_prec); go to store_bump; validate_store (20): /* complex - double precision */ fio_ps.element_p -> complex_value.imag_part = 0.0; validate_store (8): /* real - double precision */ call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), constant_ptr, binary_type (bin_type + 1), binary_prec (bin_type + 1)); go to store_bump; validate_store (19): /* complex - real */ fio_ps.element_p -> complex_value.imag_part = 0.0; fio_ps.element_p -> real = constant_ptr -> real; go to store_bump; validate_store (12): /* double precision - integer */ bin_type = bin_type + 1; call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), constant_ptr, integer_dtype, integer_prec); go to store_bump; validate_store (13): /* double precision - real */ bin_type = bin_type + 1; call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), addr (work), ext_float_decimal, (max_float)); go to store_bump; validate_store (24): /* logical - integer */ validate_store (25): /* logical - real */ validate_store (26): /* logical - double precision */ validate_store (27): /* logical - complex */ validate_store (29): /* logical - character */ call print_error (fortran_io_error_$syntax_error, me, "Logical variables must be assigned logical values."); validate_store (30): /* character - integer */ validate_store (31): /* character - real */ validate_store (32): /* character - double precision */ validate_store (33): /* character - complex */ validate_store (34): /* character - logical */ call print_error (fortran_io_error_$syntax_error, me, "Character variables must be assigned character values."); store_bump: call advance_element_p; end store; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Procedure to input any type of number. */ input_float: proc; begin_index = buffer_index; legal_end = "0"b; constant_type = integer_type; dec_flt = 0.0; if substr (rest_of_record, 1, 1) = "+" | substr (rest_of_record, 1, 1) = "-" then do; number.sign = substr (rest_of_record, 1, 1); buffer_index = buffer_index + 1; if buffer_index = buffer_length then call syntax_error; end; i = verify (rest_of_record, "0") - 1; if i ^= 0 then do; if i < 0 then do; buffer_index = buffer_length; zero_field: constant_ptr -> integer = 0; constant_type = integer_type; return; end; buffer_index = buffer_index + i; legal_end = "1"b; end; prec = verify (rest_of_record, digits) - 1; if prec ^= 0 then do; if prec < 0 then prec = buffer_length - buffer_index; if prec > max_float then call conversion_error; number.digit = substr (rest_of_record, 1, prec); buffer_index = buffer_index + prec; if buffer_index = buffer_length then go to build_integer; legal_end = "1"b; end; e = 0; dexp = 0; ch = substr (rest_of_record, 1, 1); if ch = "." then do; constant_type = real_type; buffer_index = buffer_index + 1; if buffer_index = buffer_length then if ^legal_end then call syntax_error; else go to build_binary; e = verify (rest_of_record, digits) - 1; if e ^= 0 then do; if e < 0 then e = buffer_length - buffer_index; if prec = 0 then do; i = verify (substr (rest_of_record, 1, e), "0") - 1; if i < 0 then i = e; end; else i = 0; if prec + (e - i) > max_float then call conversion_error; if (e - i) > 0 then substr (number.digit, prec + 1, e - i) = substr (rest_of_record, i + 1, e - i); prec = prec + (e - i); buffer_index = buffer_index + e; if buffer_index = buffer_length then go to build_binary; legal_end = "1"b; end; ch = substr (rest_of_record, 1, 1); end; if ^legal_end then call syntax_error; /* Must have some digits. */ if index (exps, ch) ^= 0 then do; legal_end = "0"b; /* Indicate need for exponent field. */ constant_type = real_type; if index ("eE", ch) = 0 then constant_type = double_type; buffer_index = buffer_index + 1; if buffer_index = buffer_length then call syntax_error; i = verify (rest_of_record, white_space); if i = 0 then call syntax_error; buffer_index = buffer_index + i - 1; ch = substr (rest_of_record, 1, 1); end; j = buffer_index; /* Lets us remember the sign. */ if index ("+-", ch) ^= 0 then do; legal_end = "0"b; /* Indicate need for exponent field. */ if constant_type = integer_type then constant_type = real_type; buffer_index = buffer_index + 1; if buffer_index = buffer_length then call syntax_error; end; if constant_type = integer_type then do; build_integer: if prec = 0 then go to zero_field; if prec > max_fixed then call conversion_error; substr (work_str, 1, prec + 1) = substr (work, 1, prec + 1); dec_int = 0; substr (work, 1, 1) = substr (work_str, 1, 1); substr (number.digit, max_fixed - prec + 1, prec) = substr (work_str, 2, prec); constant_ptr -> integer = convert (integer, dec_int); return; end; if ^legal_end /* Get an exponent field only if there was an "e" or sign. */ then do; i = verify (rest_of_record, digits) - 1; if i < 0 then i = buffer_length - buffer_index; if i = 0 then call syntax_error; /* Must have some digits. */ dexp = convert (dexp, substr (io_buf, j + 1, i + buffer_index - j)); buffer_index = buffer_index + i; end; build_binary: if prec = 0 then go to zero_field; e = dexp - e + prec - max_float; if e > 255 | e < -256 then call conversion_error; flt_dec.exp = e; if fio_ps.job_bits.hfp then bin_type = 3; else bin_type = 1; if constant_type = double_type then bin_type = bin_type + 1; call assign_round_ (constant_ptr, binary_type (bin_type), binary_prec (bin_type), addr (work), ext_float_decimal, (max_float)); end input_float; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ input_complex: proc; buffer_index = buffer_index + 1; /* skip "(" */ call get_field; call input_piece_of_complex (c_temp (1), "0"b); if ^comma_encountered then call syntax_error; /* comma must be used */ call get_field; call input_piece_of_complex (c_temp (2), "1"b); if comma_encountered then call syntax_error; if substr (rest_of_record, 1, 1) ^= ")" then call syntax_error; buffer_index = buffer_index + 1; /* Skip ")" */ unspec (constant_ptr -> complex_value) = unspec (c_temp); constant_type = complex_type; end input_complex; input_piece_of_complex: proc (x, paren_ok); dcl x float bin (27); dcl paren_ok bit (1) aligned; call input_float; /* get integer or real */ if constant_type = integer_type then do; if fio_ps.job_bits.hfp then bin_type = 3; else bin_type = 1; call assign_round_ (addr (x), binary_type (bin_type), binary_prec (bin_type), constant_ptr, integer_dtype, integer_prec); end; else if constant_type = real_type then x = constant_ptr -> real; else call print_error (fortran_io_error_$syntax_error, me, "Double precision constant cannot be used as input for complex variables."); call check_end; if ^(legal_end | (paren_ok & ch = ")")) then call bad_char; end input_piece_of_complex; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Procedure to input a logical constant. */ input_logical: proc; dcl delims char (4) static options (constant) initial (" ,/"); /* space tab , / */ constant_type = logical_type; if substr (rest_of_record, 1, 1) = "." then if length (rest_of_record) < 2 then call syntax_error; /* Logical value must follow period. */ else ch = substr (rest_of_record, 2, 1); /* 2nd char determines logical value. */ else ch = substr (rest_of_record, 1, 1); /* 1st char determines logical value. */ if ch = "t" | ch = "T" then constant_ptr -> logical = TRUE; else if ch = "f" | ch = "F" then constant_ptr -> logical = FALSE; else call syntax_error; j = search (rest_of_record, delims) - 1; if j < 0 then j = length (rest_of_record); buffer_index = buffer_index + j; end input_logical; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Procedure to input quoted character strings. */ input_charstr: proc; str_len = 0; buffer_index = buffer_index + 1; /* Skip initial delimiter */ do while ("1"b); i = index (rest_of_record, ch) - 1; /* If data is not all on this record, then do multiple buffer reads to find terminator. */ if i < 0 then do; call build_string (length (rest_of_record)); call buffer_read; end; else do; call build_string (i); buffer_index = buffer_index + 1; if buffer_index >= buffer_length then return; if substr (rest_of_record, 1, 1) ^= ch then return; call build_string (1); end; end; end input_charstr; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ build_string: proc (len1); dcl (len1, len2) fixed bin (18); len2 = len1; if str_len + len1 > 256 then do; call com_err_ (0, me, "Character string truncated to 256 characters."); len2 = 256 - str_len; end; if len2 > 0 then substr (work_str, str_len + 1, len2) = substr (rest_of_record, 1, min (len2, buffer_length - buffer_index)); str_len = str_len + len2; buffer_index = buffer_index + len1; constant_type = character_type; end build_string; end namelist_io; set_size_and_count: procedure (element_size, element_count, pointer_bump); /* Returns size and count information about the data being transmitted. element_size is the number of interesting bytes in one element, element_count is the number of elements, and pointer_bump is the number of bytes of storage allocated to one element. */ declare data_type fixed bin, element_count fixed bin (24); declare (element_size, pointer_bump) fixed binary (21); data_type = fio_data_type_index (fixed (substr (unspec (fio_ps.element_desc.data_type), 1, 6), 6, 0)); goto set_size (data_type); set_size (1): /* integer */ set_size (2): /* real */ set_size (5): /* logical */ pointer_bump, element_size = CPW; goto set_count; set_size (3): /* double */ set_size (4): /* complex */ pointer_bump, element_size = CPDW; goto set_count; set_size (6): /* character */ if fio_ps.ansi_77 then pointer_bump, element_size = fio_ps.length; else do; element_size = fio_ps.length; pointer_bump = divide (fio_ps.length + CPW - 1, CPW, 17, 0) * CPW; end; go to set_count; /* fio_ps.element_count is the total number of WORDS in the array, except for character arrays in ansi_77 format, where it is the total number of BYTES in the array. We map this number into the actual number of ELEMENTS to be transmitted. */ set_count: if fio_ps.array_ref & fio_ps.element_count > 0 then do; if data_type = 6 /* character array */ then if fio_ps.ansi_77 then element_count = divide (fio_ps.element_count, pointer_bump, 17, 0); else element_count = divide (fio_ps.element_count * CPW, pointer_bump, 17, 0); else if fio_ps.double | fio_ps.complex then element_count = divide (fio_ps.element_count, 2, 17, 0); else element_count = fio_ps.element_count; end; else element_count = 1; end set_size_and_count; char_pos: procedure (P_character_ptr) returns (fixed binary (21)); /* Calculate the character position in a segment of a character pointer. Written 6-Nov-79 by M. N. Davidoff. Altered for use with fortran_io_ by MEP August 1980 */ declare P_character_ptr pointer; /* (Input) pointer to a character in a segment */ /* automatic */ declare source_position fixed binary (21); declare source_ptr pointer; /* based */ declare character_array (4 * sys_info$max_seg_size) char (1) based (source_ptr); /* program */ source_ptr = baseptr (baseno (P_character_ptr)); /* Calculate the character position of the character pointer. */ source_position = 4 * binary (rel (P_character_ptr), 18) + 1; do while (addr (character_array (source_position)) ^= P_character_ptr); source_position = source_position + 1; end; return (source_position); end char_pos; advance_element_p: proc; /* Advance 'fio_ps.element_p' by 'chars_per_item' characters. */ dcl error_table_$boundviol fixed bin (35) ext; dcl 01 element_p aligned based (addr (fio_ps.element_p)) like its_unsigned; dcl 01 segment aligned based (baseptr (element_p.segno)), 02 pad bit (bits_before_element) unaligned, 02 element bit (bits_in_element) unaligned; dcl bits_before_element fixed bin (24), bits_in_element fixed bin (24); bits_in_element = 9 * chars_per_item; bits_before_element = 36 * element_p.offset + element_p.bit_offset + bits_in_element; if fio_ps.element_desc.VLA then if bits_before_element >= 36 * pl1_operators_$VLA_words_per_seg_ then do; /* Cross over to next VLA component. */ bits_before_element = bits_before_element - 36 * pl1_operators_$VLA_words_per_seg_; if bits_before_element >= 36 * pl1_operators_$VLA_words_per_seg_ then call print_error (error_table_$boundviol); element_p.segno = element_p.segno + 1; end; fio_ps.element_p = addr (element); return; %include its; end advance_element_p; end fortran_io_;  fortran_io_error_.alm 11/05/86 1557.9r w 11/04/86 1038.6 51561 " ****************************************************** " * * " * Copyright, (C) Honeywell Limited, 1983 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " ****************************************************** " Written: June 1977, David Levin. " Modified: " 8 September 1977, David Levin - add not_scratch_file. " 11 August 1977, David Levin - add cannot_reopen, not_blocked, wrong_mode. " 26 Apr 82, HH - correct 'invalid_scale_factor' message. " 19 Apr 82, HH - add 'read_after_eof' and 'write_after_eof'. " add descriptive comments and fix existing error text. " 15 July 83, MM - 406: change not_scratch_file to leave out the word 'created'. include et_macros et fortran_io_error_ " Errors in access field such as: value too long, value all blank. " ec access_field_error,accferr, (Error in access field.) " " An attribute is specified that cannot be specified for a connected file. " Accompanying text identifies the attribute. " ec already_connected,connectd, (This open attribute cannot be supplied if the file is already connected.) " " An attribute is specified that cannot be specified for a file not opened by fortran. " Accompanying text identifies the attribute. " ec already_opened,opened, (This open attribute cannot be supplied if the file is already opened.) " " Errors such as: value too long, value all blank. " ec attach_desc_field_error,attferr, (Error in the attach description field.) ec bad_char,bad_char,(Invalid or unexpected character in external data field.) " " Not a sequential file or I/O module does not support rewind or backspace. " ec blank_field_error,blnkferr,(Error in the blank field.) ec cannot_position,no_pos, (This file cannot be backspaced or rewound.) " " Not open for input. " ec cannot_read,no_read, (This file cannot be read.) " " Attempt to reopen fails, probably because I/O switch does not support requested opening mode. " Possibly user does not have access to write. " ec cannot_reopen,noreopen, (This file cannot be opened with the requested mode.) ec cannot_truncate,no_trunc,(This file opening does not permit file truncation.) ec cannot_write,no_write,(This file opening does not permit output operations.) ec close_attr_error,clse_err,(Error in the close statement attributes.) ec conversion_error,conv_err,(External data field cannot be converted.) ec dnumeric_file,dnumeric,(Double word binary files are limited to double precision data.) ec filename_field_error,flnmferr,(Error in the filename field.) ec fio_sys_error,fioerror,(FORTRAN I/O Error. Contact FORTRAN maintenance personnel.) ec form_field_error,formferr,(Error in the form field.) ec format_error,fmt_err,(Error in format specification.) ec format_is_infinite,infi_fmt,(Infinite loop in format. There is a list item but the format has no field descriptors.) ec formatted_file,fmt_file,(Formatted files are limited to formatted records.) ec incompatible_opening,inc_open,(The file opening is not compatible with the existing file.) ec internal_file_oflow,int_oflo,(An attempt has been made to access a record beyond the end of an internal file.) ec invalid_file0_attr,file0err,(Only prompt, defer, and carriage attributes are allowed for file 0.) ec invalid_file0_type,file0err,(Only the print or terminal file type can be specified for file 0.) ec invalid_for_file0,file0err,(This operation is not allowed for file 0.) ec invalid_max_recl,bad_recl,(Invalid value for the maximum record length.) ec invalid_scale_factor,badscale,(The scale factor for Dw.d and Ew.d edit descriptors must be between -d and d+2.) ec io_switch_field_error,ioswferr,(Error in the I/O switch field.) ec long_record,long_rec,(Maximum record length exceeded.) ec missing_header,no_nlhdr,(Namelist input must begin with a header.) ec mode_field_error,modeferr,(Error in the mode field.) ec must_be_empty,notempty,(File must be empty in order to set maximum record length.) ec namelist_error,nl_error,(Error in namelist I/O.) " " Operation requires file to be blocked file. " ec not_blocked,not_blk, (This file is not a blocked file.) ec not_direct,not_dir,(This file opening does not permit direct access I/O.) ec not_open,not_open,(File must be open before being used.) ec not_scratch_file,notscrch,(This file was not opened and attached by FORTRAN I/O.) ec not_sequential,not_seq,(This file opening does not permit sequential access I/O.) ec open_attr_conflict,openconf,(These two open attributes are mutually exclusive.) ec open_attr_incomplete,openinc,(The open attributes are incomplete.) ec parens_too_deep,manyparn,(Maximum format parenthesis level exceeded.) ec read_after_eof,eofread,(Attempt to read past EOF record.) ec short_record,shortrec,(Attempt to read more data than the record contains.) ec status_field_error,staferr,(Error in status field.) ec syntax_error,syntxerr,(Syntax error in the external data field.) ec unformatted_file,unf_file,(Unformatted files are limited to unformatted records.) " " Probably an error with vfile_status_. " ec unknown_filetype,unknfile, (The file type of the external file is not recognized.) ec write_after_eof,eofwrite,(Attempt to write past EOF record.) " " I/O switch is not opened by FORTRAN I/O, however, it is necessary to reopen the I/O switch " in order to satisfy the mode attribute specified by the user. " ec wrong_mode,bad_mode, (The I/O switch was not opened by FORTRAN and it does not support the requested mode.) end  fortran_pause_.pl1 12/27/84 0853.8rew 12/27/84 0838.7 19395 /* ****************************************************** * * * Copyright, (C) Honeywell Limited, 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* format: style3,^delnl,linecom */ fortran_pause_: procedure (string) options (support); /* This procedure is called to perform the function of the Fortran PAUSE statement. */ /* Modification History: 83-05-16 HH - 117: Implement a pause by signalling 'fortran_pause' rather than printing a message and entering a new command level. 83-06-16 TO - Implement options (support) and only force signal catching if interactive. Also add "PAUSE" to output string. */ dcl string char (*); dcl fast_related_data_$in_fast_or_dfast bit (1) aligned ext static; dcl INTERACTIVE fixed bin (17) static options (constant) initial (1); dcl process_type fixed bin (17); dcl ioa_ external entry options (variable), signal_ entry options (variable), user_info_$process_type entry (fixed bin (17)); dcl length builtin, null builtin; %include condition_info_header; dcl 01 condition_info aligned like condition_info_header; if fast_related_data_$in_fast_or_dfast then call ioa_ ("^/PAUSE ^a", string); else do; /* Signal 'fortran_pause' condition. */ condition_info.length = size (condition_info); condition_info.version = 1; unspec (condition_info.action_flags) = ""b; /* If we are not interactive then permit a default restart to let an absentee continue. */ call user_info_$process_type (process_type); if process_type ^= INTERACTIVE then condition_info.default_restart = "1"b; condition_info.info_string = "PAUSE " || substr (string, 1, min (length (string), maxlength (condition_info.info_string))); condition_info.status_code = 0; call signal_ ("fortran_pause", null, addr (condition_info)); end; end fortran_pause_;  fortran_stop_.pl1 12/27/84 0853.8rew 12/27/84 0838.7 14886 /* ****************************************************** * * * Copyright, (C) Honeywell Limited, 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* format: style3,^delnl,linecom */ fortran_stop_: procedure (str); /* This version of fortran_stop_ is intended to replace the installed and contains logic agreed upon by members of the fortran user community. August 2, 1972 Modified: 09 Jul 79, CRD - to add fortran_end entry. 07 Aug 78, PES - to interface to run unit facility. 08 Jun 77, DSL - New fortran I/O system interface. 26 Feb 76, GDC - to interface with fast subsystem. 12 Sep 73, DSL - to interface with new I/O system. */ dcl str char (*); dcl ioa_ entry options (variable), fortran_io_$stop entry; dcl stop_run external entry; dcl (string, addr) builtin; dcl illegal_return condition; dcl fast_related_data_$in_fast_or_dfast bit (1) aligned ext static; dcl fast_related_data_$terminate_run entry variable ext static; call ioa_ ("^/STOP ^a", str); go to common; exit: entry; call ioa_ ("^/STOP via call exit"); go to common; fortran_end: entry; common: call fortran_io_$stop; if fast_related_data_$in_fast_or_dfast then call fast_related_data_$terminate_run (); else do; call stop_run; do while ("1"b); signal illegal_return; end; end; end;  fortran_storage_.pl1 11/20/86 1412.9rew 11/20/86 1142.5 151110 /****^ ****************************************** * * * Copyright, (C) Honeywell Limited, 1983 * * * ****************************************** */ /****^ HISTORY COMMENTS: 1) change(86-09-18,DGHowe), approve(86-09-18,MCR7420), audit(86-09-19,Schroth), install(86-11-20,MR12.0-1222): changed the calling sequence of list_init_. END HISTORY COMMENTS */ /* format: style3,^delnl,linecom */ fortran_storage_: proc (sp, lp, tp) options (support); create: entry (sp, lp, tp); /* This driver receives control from pl1_operators_ when a call is received from a fortran program to create and/or initialize external data storage, such as Large and Very Large Arrays. Entry Conditions: sp This is the stack pointer to the stack frame of the fortran program making the request. lp This is the linkage pointer to the linkage section of the program making the request. tp This is a pointer to the text section parameter word. This word is in the format: vfd 18/create_relative_offset,18/initialize_relative_offset These pointers are offsets from the base of the segment of tp. */ /* Create 82-09-07 by T. Oke (UNCA) */ /* Modification History: Modified: 27 June 1986, DH & BW - Use new interface to list_init_ and set_external_variable_. Modified: 16 June 1983, TO- Use condition_info_header, have options (support). Modified: 29 May 1983, MW - To call sub_err_ if find perprocess static Modified: 16 February 1983, TO- Set stack_header.have_static_vlas for use of run_. Modified: 15 February 1983, TO- Set linkage_header_flags.static_vlas for use of run_. Modified: 26 January 1983, HH - Replaced 'fill_VLA_addressors' routine. Modified: 18 January 1983, TO - Match with CISL implementation of link snapping to VLA COMMON from the linker. */ dcl lp ptr; /* Pointer to base of linkage section */ dcl sp ptr; /* Pointer to stack frame of caller */ dcl tp ptr; /* Pointer to parameter word */ dcl (alp, asp, atp) ptr; /* actual running pointers */ dcl 1 parm based (tp), 2 create_relp bit (18) unaligned, /* relative offset from tp to creation data */ 2 init_relp bit (18) unaligned; /* relative offfset from tp to initialization data */ %include fortran_storage; /* Based Variables */ dcl based_ptr ptr based; dcl LA_base_addressor ptr based (base_addressor_ptr); dcl VLA_base_addressor ptr unaligned based (base_addressor_ptr); /* Automatic Storage */ dcl base_addressor_ptr ptr; dcl code fixed bin (35); dcl cp ptr; /* pointer to create entry */ dcl defp ptr; /* pointer to definition section */ dcl found_sw bit (1) aligned; /* external was found */ dcl length fixed bin (24); /* number of words needed */ dcl linkp ptr; /* pointer to link */ dcl looping bit (1); /* true while doing lists */ dcl namep ptr; /* pointer to block name from link */ dcl num_segs_needed fixed bin; /* number of segments needed */ dcl storage_ptr ptr; dcl textp ptr; /* pointer to text section */ dcl type_ptr ptr; /* pointer to type_pair */ dcl variablep ptr; /* pointer to variable_node */ dcl pl1_operators_$VLA_words_per_seg_ fixed bin (19) external; dcl fortran_storage_manager_$alloc entry (fixed bin, ptr, ptr); dcl list_init_ entry (ptr, ptr, fixed bin (35), ptr, ptr, fixed bin (35)); dcl set_ext_variable_ entry (char (*), ptr, ptr, bit (1) aligned, ptr, fixed bin (35)); dcl sub_err_ entry options (variable); dcl (addr, addrel, baseno, currentsize, divide, fixed, null, ptr, rel, rtrim, stackbaseptr, string, substr, unspec) builtin; textp = ptr (tp, "000000"b3); /* get pointer to text section */ atp = tp; alp = lp; asp = sp; code = 0; /* process Storage creation. */ looping = "1"b; if parm.create_relp ^= "777777"b3 /* list exists */ then do cp = ptr (atp, parm.create_relp) repeat ptr (atp, unspec (cp -> create_entry.next)) while (looping); length = cp -> create_entry.length; /* pl1_operators_$VLA_words_per_seg_ determines the actual addressing which will occur in this execution. It is used to determine the number of segments required. */ num_segs_needed = divide (length + pl1_operators_$VLA_words_per_seg_ - 1, pl1_operators_$VLA_words_per_seg_, 17); if cp -> create_entry.flags.auto then do; /* Automatic storage */ call fortran_storage_manager_$alloc (num_segs_needed, asp, storage_ptr); if cp -> create_entry.init then call list_init_ (storage_ptr, addrel (cp, currentsize (cp -> create_entry)), (cp -> create_entry.length), stackbaseptr (), null (), code); base_addressor_ptr = addrel (asp, cp -> create_entry.location); if cp -> create_entry.flags.LA then LA_base_addressor = storage_ptr; else call fill_VLA_addressors; end; else if cp -> create_entry.flags.static then do; /* Static if not init */ base_addressor_ptr = addrel (alp, cp -> create_entry.location); if cp -> create_entry.flags.LA then do; if LA_base_addressor = null () then do; if alp -> linkage_header_flags.perprocess_static then call signal_sub_error; call fortran_storage_manager_$alloc (num_segs_needed, alp, storage_ptr); if cp -> create_entry.init then call list_init_ (storage_ptr, addrel (cp, currentsize (cp -> create_entry)), (cp -> create_entry.length), stackbaseptr (), null (), code); LA_base_addressor = storage_ptr; end; end; else do; if VLA_base_addressor = null () then do; if alp -> linkage_header_flags.perprocess_static then call signal_sub_error; call fortran_storage_manager_$alloc (num_segs_needed, alp, storage_ptr); if cp -> create_entry.init then call list_init_ (storage_ptr, addrel (cp, currentsize (cp -> create_entry)), (cp -> create_entry.length), stackbaseptr (), null (), code); call fill_VLA_addressors; end; end; /* Set stack_header.have_statis_vlas and linkage_header_flags.static_vlas to inform run_ that there will be external segments to preserve. */ ptr (asp, "0"b) -> stack_header.have_static_vlas = "1"b; alp -> linkage_header_flags.static_vlas = "1"b; end; else if cp -> create_entry.flags.common then do; /* Find pointer to addressor (base_addressor_ptr -> VLA_base_addressor), and pointer to true full link (linkp -> link). */ base_addressor_ptr = addrel (alp, cp -> create_entry.location); linkp = addrel (alp, cp -> create_entry.common_link); /* If link is unsnapped, or disagrees with 'VLA_base_addressor' then update 'VLA_base_addressor' */ if linkp -> link.ft2 ^= "46"b3/* snapped */ then if linkp -> based_ptr ^= VLA_base_addressor /* wrong VLA_base_addressor */ then do; /* take link */ storage_ptr = linkp -> based_ptr; call fill_VLA_addressors; end; else ; else do; /* snap link and fill pointers */ re_try_snap: call snap_link (code); if code ^= 0 then do; call signal_fortran_storage_error (code, " COMMON block " || cp -> create_entry.block_name); goto re_try_snap; end; call fill_VLA_addressors; end; end; if code ^= 0 then do; call sub_err_ (code, "fortran_storage_", ACTION_CANT_RESTART, null, 0, "An error has occurred while initializing ^a.", cp -> create_entry.block_name); return; end; if cp -> create_entry.next = 0 then looping = "0"b; end; return; /* Resolve a linkage error for VLA COMMON. */ resolve_VLA_COMMON_link: entry (a_link_ptr, a_def_ptr, a_type_ptr, a_code); dcl a_code fixed bin (35); /* error code */ dcl a_def_ptr ptr; /* definition ptr, also text section ptr */ dcl a_link_ptr ptr; /* pointer to link to snap */ dcl a_type_ptr ptr; /* pointer to type_word */ /* When the linker finds a link to VLA COMMON 'link_trap_caller_' will call us to resolve the link and initialize it. We in turn simply call our local 'snap_link' procedure. */ linkp = a_link_ptr; /* setup for snapping the link and creation of the COMMON. text pointer is taken from a_def_ptr, which should be into the text segment and therefore usable in our case. */ atp = ptr (a_def_ptr, "0"b); alp = addrel (linkp, linkp -> link.head_ptr); call snap_link (a_code); return; fill_VLA_addressors: proc; /* Function: to calculate and store the addressors of the base and various */ /* offsets of a VLA. The logical address of the VLA is stored in the */ /* base addressor and the packed pointer to the offset is stored in each */ /* offset addressor. (The logical address of a storage location is just */ /* its segment number times the maximum length in words of its segment */ /* plus its word offset in the segment. For 256K segments, it is just */ /* the packed pointer to the location, considered as an integer.) */ /* Global Arguments: */ /* */ /* base_addressor_ptr (Input) */ /* is the address where the value of the base addressor of the VLA is to */ /* be stored. The addressors of any offsets into the VLA are stored in */ /* successive locations. */ /* */ /* cp (Input) */ /* is the address of the 'creation_entry' structure which specifies any */ /* offsets into the VLA and whether the calling program can operate with */ /* other than 256K segments. */ /* */ /* storage_ptr (Input) */ /* is the address of the storage that has been assigned to the VLA. */ dcl error_table_$resource_unavailable fixed bin (35) ext; dcl 01 VLA_addressors aligned based (base_addressor_ptr), 02 addressor_of_base fixed bin (30), 02 addressor_of_offset (offset_cnt) fixed bin (30); dcl offset (offset_cnt) fixed bin (24) based (offset_ptr); dcl i fixed bin, logical_address_of_base fixed bin (30), logical_address_of_offset fixed bin (30), offset_cnt fixed bin, offset_ptr ptr, VLA_base_ptr ptr unaligned; /* Copy various input values to local storage so we can get faster access. */ offset_cnt = cp -> create_entry.pointer_count; if offset_cnt > 0 then offset_ptr = addr (cp -> create_entry.pointer_offsets); VLA_base_ptr = storage_ptr; /* If the 256K flag is set, we must ensure that storage is being allocated */ /* in 256K segments, since otherwise the calling program will not operate */ /* correctly. */ if cp -> create_entry.K256 then do while (pl1_operators_$VLA_words_per_seg_ ^= 262144); call signal_fortran_storage_error (error_table_$resource_unavailable, "Program requires storage to be allocated in 256K segments."); end; /* Fill in the addressors of the base and offsets into the VLA. If storage */ /* is allocated in 256K segments, logical addresses are also packed ptrs */ /* and so we can use simpler code which runs much faster. */ if pl1_operators_$VLA_words_per_seg_ = 262144 then do; /* Logical addresses are also packed pointers. */ unspec (logical_address_of_base) = unspec (VLA_base_ptr); VLA_addressors.addressor_of_base = logical_address_of_base; do i = 1 to offset_cnt; VLA_addressors.addressor_of_offset (i) = logical_address_of_base + offset (i); end; end; else do; /* Logical addresses are different than packed pointers. */ logical_address_of_base = fixed (baseno (VLA_base_ptr), 12) * pl1_operators_$VLA_words_per_seg_ + fixed (rel (VLA_base_ptr), 18); VLA_addressors.addressor_of_base = logical_address_of_base; do i = 1 to offset_cnt; logical_address_of_offset = logical_address_of_base + offset (i); VLA_addressors.addressor_of_offset (i) = logical_address_of_offset + fixed (262144 - pl1_operators_$VLA_words_per_seg_, 18) * divide (logical_address_of_offset, pl1_operators_$VLA_words_per_seg_, 12); end; end; end fill_VLA_addressors; signal_fortran_storage_error: proc (status, details); /* Function: to signal the restartable condition 'fortran_storage_error'. */ /* Arguments: */ /* */ /* status (Input) */ /* is a standard system status code describing why the condition is */ /* being signalled. */ /* */ /* details (Input) */ /* is supplementary information regarding why the condition is being */ /* signalled. */ dcl status fixed bin (35), details char (*); dcl signal_ entry options (variable); dcl size builtin; %include condition_info_header; dcl 01 condition_info aligned like condition_info_header; condition_info.length = size (condition_info); condition_info.version = 1; unspec (condition_info.action_flags) = ""b; condition_info.info_string = rtrim (details); condition_info.status_code = status; call signal_ ("fortran_storage_error", null, addr (condition_info)); end signal_fortran_storage_error; /* Snap a VLA Common link. */ snap_link: proc (code); dcl code fixed bin (35); /* Routine to snap a link, if it is unsnapped, and create the VLA common. */ /* Global Inputs: atp Text pointer. Pointer to some point in the text section. alp Linkage ptr. Pointer to start of linkage section in area.linker. linkp Link pointer. Pointer to the link ptr to be snapped. Local Inputs code return error code. Outputs: storage_ptr Has pointer to start of variable, whether created or not. */ dcl block_name char (32) varying; /* if link is unsnapped, then snap it and create the common if necessary. */ /* set_ext_variable_ will also initialize the common. */ if linkp -> link.ft2 = "46"b3 /* unsnapped */ then do; /* defp is pointer to definition section. */ /* type_pair points to type_pair word. */ /* init_info_ptr is initialization block. */ defp = ptr (atp, alp -> virgin_linkage_header.def_offset); type_ptr = addrel (defp, (addrel (defp, linkp -> link.exp_ptr) -> exp_word.type_ptr)); namep = addrel (defp, type_ptr -> type_pair.ext_ptr); block_name = substr (namep -> name.char_string, 1, fixed (namep -> name.nchars, 9)); init_info_ptr = addrel (defp, type_ptr -> type_pair.trap_ptr); call set_ext_variable_ ((block_name), init_info_ptr, stackbaseptr (), found_sw, variablep, code); if code ^= 0 then if ^found_sw then return; storage_ptr = variablep -> variable_node.vbl_ptr; linkp -> based_ptr = storage_ptr; /* snap link too */ end; /* accept the previously snapped link. */ else storage_ptr = linkp -> based_ptr; return; end snap_link; %page; signal_sub_error: proc; /* Subroutine to call sub_err_ if the program has both perprocess static and static LA/VLAs. For now we specify action_cant_restart because there is no easy way to reset the active perprocess static flag. */ dcl retval fixed bin (35); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl dirname char (168); dcl entryname char (32); dcl dirname_length fixed bin; retval = 0; call hcs_$fs_get_path_name (textp, dirname, dirname_length, entryname, code); call sub_err_ (0, "fortran_storage_", ACTION_CANT_RESTART, null, retval, "Attempt by perprocess static segment ^a>^a^/to use static (very) large arrays. This combination is illegal." , dirname, entryname); return; /* should never get here */ end signal_sub_error; %page; %include system_link_init_info; %include linkdcl; %include system_link_names; %include stack_header; %include sub_err_flags; end fortran_storage_;  fortran_storage_manager_.pl1 11/20/86 1412.9rew 11/20/86 1142.5 433710 /****^ ****************************************** * * * Copyright, (C) Honeywell Limited, 1983 * * * ****************************************** */ /****^ HISTORY COMMENTS: 1) change(86-08-20,DGHowe), approve(86-08-20,MCR7391), audit(86-08-01,Schroth), install(86-11-20,MR12.0-1222): removed unrequired declarations. END HISTORY COMMENTS */ /* format: style3,^delnl,linecom */ fortran_storage_manager_: fsm_: proc options (support); /* Author: H. Hoover, University of Calgary, 82-08-12. */ /* */ /* Modified: */ /* 84-10-10 by MM - 442: Set 256K switch once per process. Do not set */ /* it prior to creating a segment. */ /* 83-07-10 by TO: Set 256K switch prior to creating a 256K segment */ /* 83-06-16 by TO: Use condition_info_header, have options (support). */ /* 83-02-15 by TO: Create get_vla_segnos entry to return information to */ /* run_ as to the segment numbers created for storage. */ /* 83-01-19 by TO: Allow storage directory per-ring. */ /* 83-01-19 by TO: Set maximum length of segments from */ /* pl1_operators_$VLA_words_per_seg_ for general runtime use. */ /* 83-01-19 by TO: Set safety switch for fsm_dir, fsm_info and fsm_segs.*/ /* 82-10-14 by HH: Allow storage to be allocated from anywhere in the */ /* storage heirarchy (rather than just the process directory) and */ /* allow multiple processes to share the same pool of free segments. */ /* Function: to allocate, free and list storage in connection with large */ /* and very large 'fortran' arrays. */ /* Error processing: */ /* */ /* The entry points in this procedure do not return a status code if an */ /* error occurs. Instead, the condition 'fortran_storage_manager_error' is */ /* signalled with a description of what the error is. If the user chooses */ /* to restart, we assume he has done something to fix the problem and we */ /* retry the operation that detected the error. If the problem is not */ /* fixed, we again signal the condition 'fortran_storage_manager_error'. */ /* This continues ad nauseum until either the user fixes the problem or */ /* gives up and releases. */ dcl get_lock_id_ entry returns (bit (36) aligned); dcl False bit (1) static options (constant) init ("0"b), True bit (1) static options (constant) init ("1"b), fsm_dir_name_master char (8) static options (constant) init ("fsm_dir_"), fsm_info_name char (13) static options (constant) init ("fsm_info.fsm_"); dcl 01 fsm_info aligned based (fsm_info_ptr), 02 lock bit (36), /* Lock word. */ 02 seg_cnt fixed bin, /* Total number of allocated and free segments. */ 02 seg (fsm_info.seg_cnt), 03 owning_process bit (36), /* Lock ID for owning process. ""b => Free. */ 03 owner ptr unal, /* Pointer to owner of this segment. */ 03 first_seg_in_group fixed bin, /* Index of first seg in this group. */ 03 next_seg_in_group fixed bin, /* Index of next seg in this group. */ 03 seg_num fixed bin; /* Number under which segment is initiated. */ dcl fsm_dir_path char (168) static init (""), fsm_info_path char (168) static init (""), fsm_info_ptr ptr static init (null), fsm_info_ptr_valid bit (1) static init ("0"b); dcl me ptr init (codeptr (fsm_)), my_process bit (36) aligned init (get_lock_id_ ()); return; /* Just ignore calls to the main entry point. */ alloc: entry (num_segs_desired, owner, first_seg_ptr); /* Function: to allocate a specified number of segments with consecutive */ /* segment numbers. The segments are created as needed. */ /* Arguments: */ /* */ /* num_segs_desired (Input) */ /* is the number of segments to be allocated. */ /* */ /* owner (Input) */ /* is the address of a location which is considered to own the segments */ /* to be allocated. It is used to identify the segments which are to be */ /* deallocated by a call to the 'free' routine. */ /* */ /* first_seg_ptr (Output) */ /* is the address of the base of the first segment allocated. (The */ /* addresses of the other segments are obtained by incrementing the */ /* segment number portion of the address of the first segment.) The */ /* value 'null' is returned if 'num_segs_desired' is less than 1 or if */ /* 'owner' is 'null' or the 'fortran_storage_manager_' entry point. */ /* Error handling: */ /* */ /* If an error occurs during allocation, the 'fortran_storage_manager_error' */ /* condition is signalled. If the user does not handle the condition, the */ /* system will display a diagnostic describing the error that caused the */ /* condition to be signalled and establish a new command level. The */ /* 'start' command will cause the code that failed to be retried. If the */ /* problem which caused the failure has been fixed, allocation will proceed */ /* as though the error had never occurred; otherwise, the condition */ /* 'fortran_storage_manager_error' will be signalled again. */ /* */ /* There is one error that can occur which the user need only restart the */ /* allocation in order to correct: 'The segment number is in use.' This */ /* should only occur if the user suspends the allocation process with a */ /* 'quit' signal, does something that requires a new segment to be made */ /* known, then restarts the allocation. If the new segment is made known */ /* under a segment number that was to be used for one of the segments being */ /* allocated, the above error occurs. Restarting after such an error will */ /* cause a new set of sequential segment numbers to be chosen. */ dcl num_segs_desired fixed bin, owner ptr, first_seg_ptr ptr; dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_file entry (char (*), char (*), fixed bin (1), fixed bin (35)), pathname_ entry (char (*), char (*)) returns (char (168)); /* builtins */ dcl (addr, addrel, baseno, baseptr, before, bin, char, codeptr, fixed, hbound, index, lbound, length, ltrim, ptr, rel, rtrim, size, substr, sum, unspec, verify, null) builtin; dcl cleanup condition; dcl first_seg_in_group fixed bin, first_seg_num fixed bin, prev_seg_in_group fixed bin, seg_idx fixed bin, seg_num fixed bin, status fixed bin (35), try_again bit (1); /* Verify that the input arguments are valid. */ first_seg_ptr = null; if num_segs_desired <= 0 | owner = null | owner = me then return; on cleanup call release_fsm_info; call appropriate_fsm_info; /* Allocate the requested segments, specifying this object segment as the */ /* owner, so that if we have to do a clean up, we will know which segments */ /* we must deallocate. */ try_again = True; do while (try_again); try_again = False; call pick_first_seg_num (num_segs_desired, first_seg_num); do seg_num = first_seg_num to first_seg_num + num_segs_desired - 1 while (^try_again); call pick_seg (seg_idx); if seg_num = first_seg_num then first_seg_in_group = seg_idx; else fsm_info.seg (prev_seg_in_group).next_seg_in_group = seg_idx; fsm_info.seg (seg_idx).owning_process = my_process; fsm_info.seg (seg_idx).owner = me; fsm_info.seg (seg_idx).first_seg_in_group = first_seg_in_group; fsm_info.seg (seg_idx).next_seg_in_group = 0; fsm_info.seg (seg_idx).seg_num = seg_num; call hcs_$initiate (fsm_dir_path, seg_name (seg_idx), "", 1, 0, baseptr (seg_num), status); if status ^= 0 then do; call signal_fsm_error (status, "(Trying to initiate " || pathname_ (fsm_dir_path, seg_name (seg_idx)) || " as segment " || octal_representation (seg_num) || ")"); do seg_idx = first_seg_in_group repeat fsm_info.seg (seg_idx).next_seg_in_group while (seg_idx ^= 0); call hcs_$terminate_file (fsm_dir_path, seg_name (seg_idx), 0, status); end; try_again = True; end; prev_seg_in_group = seg_idx; end; end; /* Transfer ownership of the allocated segments to the caller. */ do seg_idx = 1 to fsm_info.seg_cnt; if fsm_info.seg (seg_idx).owning_process = my_process & fsm_info.seg (seg_idx).owner = me then fsm_info.seg (seg_idx).owner = owner; end; first_seg_ptr = baseptr (first_seg_num); call release_fsm_info; return; free: entry (owner); /* Function: to free all segments previously allocated to a specified */ /* owner. */ /* Arguments: */ /* */ /* owner (Input) */ /* is the address of the location that was specified (at allocation) to */ /* be the owner of the segments that are now desired to be deallocated. */ /* If there are no allocated segments with the specified owner, the */ /* routine just returns, without comment. */ dcl hcs_$truncate_file entry (char (*), char (*), fixed bin (19), fixed bin (35)); on cleanup call release_fsm_info; call appropriate_fsm_info; do seg_idx = 1 to fsm_info.seg_cnt; if fsm_info.seg (seg_idx).owning_process = my_process & fsm_info.seg (seg_idx).owner = owner then do; call hcs_$terminate_file (fsm_dir_path, seg_name (seg_idx), 0, status); call hcs_$truncate_file (fsm_dir_path, seg_name (seg_idx), 0, status); unspec (fsm_info.seg (seg_idx)) = ""b; end; end; call release_fsm_info; return; get_owner: entry (seg_ptr, owner); /* Function: to return the owner of a specified managed segment. If the */ /* specified segment is free or is not one of those managed by 'fsm_', */ /* 'null' is returned. */ /* Arguments: */ /* */ /* seg_ptr (Input) */ /* is a pointer to any location in the segment whose owner is desired. */ dcl seg_ptr ptr; on cleanup call release_fsm_info; call appropriate_fsm_info; do seg_idx = 1 to fsm_info.seg_cnt while (fsm_info.seg (seg_idx).owning_process ^= my_process | fsm_info.seg (seg_idx).seg_num ^= bin (baseno (seg_ptr))); end; if seg_idx <= fsm_info.seg_cnt then owner = fsm_info.seg (seg_idx).owner; else owner = null; call release_fsm_info; return; get_vla_segnos: entry (segment_map_bits); /* Function: to return a bit array with bits set for each segment created */ /* by fortran_storage_manager_ in this process. */ /* Arguments: */ /* */ /* segment_map_bits (Input/Output) */ /* is an array (*) of bits which is passed in. This routine will set */ /* bits corresponding to the segment numbers of external storage segments*/ dcl segment_map_bits (*) bit (1); on cleanup call release_fsm_info; call appropriate_fsm_info; /* Scan the groups of segments allocated to this process. */ do seg_idx = 1 to fsm_info.seg_cnt; if fsm_info.owning_process (seg_idx) = my_process then segment_map_bits (seg_idx) = "1"b; end; call release_fsm_info; return; list_fortran_storage: lfs: entry; /* Function: to list (on the 'user_output' switch) the segments which are */ /* currently allocated to this process. */ dcl ioa_ entry options (variable); dcl group_cnt fixed bin; on cleanup call release_fsm_info; call appropriate_fsm_info; /* Count the number of groups of segments that are allocated to this */ /* process. */ group_cnt = 0; do seg_idx = 1 to fsm_info.seg_cnt; if fsm_info.owning_process (seg_idx) = my_process & fsm_info.first_seg_in_group (seg_idx) = seg_idx then group_cnt = group_cnt + 1; end; /* If there are any segments allocated to this process, list them by owner */ /* and group. */ if group_cnt = 0 then call ioa_ ("No segments in ^a allocated to this process.", fsm_dir_path); else do; call ioa_ ("Segments in ^a allocated to this process:", fsm_dir_path); call list_groups (group_cnt, my_process); end; call release_fsm_info; return; appropriate_fsm_info: proc; /* Function: to find and lock for this process 'fsm_info'. 'fsm_info' and */ /* its containing directory will be created if necessary. */ /* Global arguments: */ /* */ /* fsm_dir_name_master (Input) */ /* is the name of the directory where the segment on which 'fsm_info' is */ /* based resides. (Ring number will be added later to create the dir.) */ /* */ /* fsm_dir_path (Output) */ /* is the absolute pathname of the directory where the segment on which */ /* 'fsm_info' is based resides. */ /* */ /* fsm_info_name (Input) */ /* is the name of the segment on which 'fsm_info' is based. */ /* */ /* fsm_info_ptr (Output) */ /* is the address of the base of the segment on which 'fsm_info' is */ /* based. */ dcl error_table_$bad_segment fixed bin (35) ext, error_table_$invalid_lock_reset fixed bin (35) ext, error_table_$moderr fixed bin (35) ext, error_table_$noentry fixed bin (35) ext, error_table_$notadir fixed bin (35) ext, error_table_$nomatch fixed bin (35) ext; dcl cu_$level_get entry returns (fixed bin (3)), get_group_id_$tag_star entry returns (char (32)), get_system_free_area_ entry returns (ptr), hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)), hcs_$append_branchx entry (char (*), char (*), fixed bin (5), (3) fixed bin (6), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_safety_sw entry (char (*), char (*), bit (1), fixed bin (35)), hcs_$set_256K_switch entry (bit (2) aligned, bit (2) aligned, fixed bin (35)), hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)), hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)), pl1_operators_$VLA_words_per_seg_ fixed bin (19) external, set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)), sys_info$max_seg_size fixed bin (35) ext; dcl cleanup condition; dcl Chase_links fixed bin (1) static options (constant) init (1), Max_wait_time fixed bin static options (constant) init (120); dcl 01 acl aligned, 02 access_name char (32), 02 modes bit (36), 02 xmodes bit (36), 02 status fixed bin (35); dcl bit_count fixed bin (24), fsm_dir_dir_path char (168), fsm_dir_name char (32), i fixed bin, max_seg_idx fixed bin, primary_name char (32), seg_cnt fixed bin, seg_idx fixed bin, status fixed bin (35), system_free_area_ptr ptr init (null), type fixed bin (2); dcl system_free_area area based (system_free_area_ptr); dcl get_ring_ entry () returns (fixed bin (3)); /* If the flag 'fsm_info_ptr_valid' is false, we must find 'fsm_info' and */ /* store the address of its base in 'fsm_info_ptr'. If 'fsm_info' doesn't */ /* exist, we must create it (and possibly its containing directory). If we */ /* are unable to do this, we signal the 'fortran_storage_manager_error' */ /* condition with a description of the problem. If the user restarts us, */ /* we assume he has done something to correct the problem, and we try */ /* again. */ if ^fsm_info_ptr_valid then do; if pl1_operators_$VLA_words_per_seg_ > sys_info$max_seg_size then do; call hcs_$set_256K_switch ("11"b, (""b), status); if status ^= 0 then call signal_fsm_error (status, "Cannot set 256K switch"); end; fsm_info_ptr = null; fsm_dir_name = fsm_dir_name_master || ltrim (char (get_ring_ ())); do while (fsm_info_ptr = null); call get_fsm_dir_dir_path (fsm_dir_dir_path); fsm_dir_path = pathname_ (fsm_dir_dir_path, fsm_dir_name); fsm_info_path = pathname_ (fsm_dir_path, fsm_info_name); call hcs_$status_minf (fsm_dir_dir_path, fsm_dir_name, Chase_links, type, bit_count, status); if status = 0 then if type = star_DIRECTORY & bit_count = 0 then do; /* Find 'fsm_info', creating it if necessary. */ call hcs_$make_seg (fsm_dir_path, fsm_info_name, "", RW_ACCESS_BIN, fsm_info_ptr, status); if status = error_table_$moderr then do; /* Segment exists, but we don't have access. */ acl.access_name = get_group_id_$tag_star (); acl.modes = RW_ACCESS; acl.xmodes = ""b; call hcs_$add_acl_entries (fsm_dir_path, fsm_info_name, addr (acl), 1, status); if status = 0 then call hcs_$initiate (fsm_dir_path, fsm_info_name, "", 0, 0, fsm_info_ptr, status); end; if fsm_info_ptr = null then call signal_fsm_error (status, fsm_info_path); end; else call signal_fsm_error (error_table_$notadir, fsm_dir_path); else if status = error_table_$noentry then do; /* Create 'fsm_dir' and 'fsm_info'. */ call hcs_$append_branchx (fsm_dir_dir_path, fsm_dir_name, SMA_ACCESS_BIN, cu_$level_get (), get_group_id_$tag_star (), 1, 0, 0, status); if status = 0 then do; /* Create 'fsm_info'. */ call hcs_$set_safety_sw (fsm_dir_dir_path, fsm_dir_name, "1"b, status); call hcs_$make_seg (fsm_dir_path, fsm_info_name, "", RW_ACCESS_BIN, fsm_info_ptr, status); if fsm_info_ptr = null then call signal_fsm_error (status, fsm_info_path); call hcs_$set_safety_sw (fsm_dir_dir_path, fsm_info_name, "1"b, status); end; else call signal_fsm_error (status, fsm_dir_path); end; else call signal_fsm_error (status, fsm_dir_path); end; end; /* We now have a pointer to 'fsm_info'. However, we cannot use 'fsm_info' */ /* until we lock it so that we are safe from some other process altering it */ /* while we use it. If some other process is currently using it, we must */ /* wait for that process to unlock it. If that process doesn't unlock it */ /* in a reasonable time, we signal the 'fortran_storage_manager_error' */ /* condition, indicating that this has occurred. If the user restarts us, */ /* we try again. */ status = 1; do while (status ^= 0); call set_lock_$lock (fsm_info.lock, Max_wait_time, status); if status = error_table_$invalid_lock_reset then status = 0; else if status ^= 0 then call signal_fsm_error (status, fsm_info_path); end; /* We now have 'fsm_info' all to ourselves. However, it may not be valid. */ /* It is fairly expensive to check for validity, so we only do it the first */ /* time we access 'fsm_info'. This is reasonable, since serious problems */ /* with the information in 'fsm_info' are rare and will be diagnosed later */ /* anyway. */ /* */ /* There are two ways in which 'fsm_info' could be invalid. First, it may */ /* not be consistent in that it knows about more or fewer managed segments */ /* than actually exist in the directory. Second, it may be out of date in */ /* that it has some segments allocated to processes that no longer exist. */ /* */ /* It is easy to tell if 'fsm_info' is inconsistent: We need only count */ /* number of managed segments (i.e. segments whose first component is a */ /* positive integer and whose second component is 'fsm_') and find the */ /* managed segment whose first component is numerically largest. We have */ /* consistency if and only if both these numbers equal 'fsm_info.seg_cnt'. */ /* If 'fsm_info' is inconsistent, the 'fortran_storage_manager_error' */ /* condition is signalled with a description of the problem. The user */ /* probably cannot do anything about this, but if he chooses to restart, we */ /* repeat the validity test. */ /* */ /* If 'fsm_info' is found to be consistent, we examine all allocated */ /* segments and free any found to be allocated to nonexistent processes. */ do while (^fsm_info_ptr_valid); system_free_area_ptr = get_system_free_area_ (); star_entry_ptr, star_names_ptr = null; on cleanup begin; /* Free anything that was allocated. */ if star_names_ptr ^= null then free star_names in (system_free_area); if star_entry_ptr ^= null then free star_entries in (system_free_area); end; call hcs_$star_ (fsm_dir_path, "*.fsm_", star_BRANCHES_ONLY, system_free_area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, status); if status ^= 0 & status ^= error_table_$nomatch then call signal_fsm_error (status, fsm_info_path); else do; /* Check validity of 'fsm_info_'. */ seg_cnt, max_seg_idx = 0; do i = 1 to star_entry_count; primary_name = star_names (star_entries (i).nindex); if verify (before (primary_name, "."), "0123456789") = 0 & substr (primary_name, 1, 1) ^= "0" then do; /* This is a managed segment. */ seg_cnt = seg_cnt + 1; seg_idx = bin (before (primary_name, ".")); if seg_idx > max_seg_idx then max_seg_idx = seg_idx; end; end; if star_names_ptr ^= null then free star_names in (system_free_area); if star_entry_ptr ^= null then free star_entries in (system_free_area); if max_seg_idx ^= seg_cnt | seg_cnt ^= fsm_info.seg_cnt then call signal_fsm_error (error_table_$bad_segment, fsm_info_path); else do; /* 'fsm_info' is consistent. */ do seg_idx = 1 to fsm_info.seg_cnt; if fsm_info.seg (seg_idx).owning_process ^= ""b then do; call set_lock_$lock ((fsm_info.seg (seg_idx).owning_process), 0, status) ; if status = error_table_$invalid_lock_reset then do; /* The owner is dead. */ call hcs_$truncate_file (fsm_dir_path, seg_name (seg_idx), 0, status); unspec (fsm_info.seg (seg_idx)) = ""b; end; end; end; fsm_info_ptr_valid = True; end; end; end; return; %include star_structures; end appropriate_fsm_info; description_of_location: proc (location) returns (char (256) varying) recursive; /* Function: to return a meaningful description of the location addressed */ /* by a pointer variable. If the segment number of the location is not */ /* valid, the description is just the ASCII representation of a pointer */ /* and a comment indicating the segment number is invalid. Otherwise, */ /* the segment number portion is replaced by the pathname of the segment */ /* and the offset potion is dropped if it is zero, or replaced by the */ /* entry name if the location is an entry point. If the location is in */ /* an active stack frame or an external variable, the description will */ /* include a comment indicating that. */ /* Arguments: */ /* */ /* location (Input) */ /* contains the address of the location whose description is desired. */ dcl location ptr; dcl get_entry_name_ entry (ptr, char (*), fixed bin (18), char (8) aligned, fixed bin (35)), get_pdir_ entry returns (char (168)), hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl null builtin, stackbaseptr builtin, stackframeptr builtin; dcl False bit (1) static options (constant) init ("0"b), True bit (1) static options (constant) init ("1"b); dcl bit_offset char (4) varying, checking_external_variables bit (1), description char (256) varying, dir_name char (168), dir_name_len fixed bin, entry_name char (32), hash_table_idx fixed bin, language char (8) aligned, seg_name char (32), seg_num fixed bin (18), status fixed bin (35), vnp ptr, vthp ptr, word_offset char (8) varying; if location = null then return ("null"); /* Create character representations of the word and bit offsets. */ if substr (unspec (location), 58, 6) = ""b /* Unfortunately, there is no builtin to get the bit offset. */ then bit_offset = ""; else do; bit_offset = "("; bit_offset = bit_offset || ltrim (char (fixed (substr (unspec (location), 58, 6)))); bit_offset = bit_offset || ")"; end; if rel (location) = ""b & bit_offset = "" then word_offset = ""; else do; word_offset = "|"; word_offset = word_offset || octal_representation (fixed (rel (location))); end; /* Generate a meaningful description of the location, if possible. */ call hcs_$fs_get_path_name (location, dir_name, dir_name_len, seg_name, status); if status ^= 0 then do; /* Can't do much as the segment number is invalid. */ description = octal_representation (fixed (baseno (location))); description = description || word_offset; description = description || bit_offset; description = description || " (Segment number invalid)"; end; else do; /* We can at least give a pathname instead of a segment number. */ if dir_name = ">" then description = ""; else if dir_name = get_pdir_ () then description = "[pd]"; else description = substr (dir_name, 1, dir_name_len); description = description || ">"; description = description || rtrim (seg_name); call get_entry_name_ (location, entry_name, seg_num, language, status); if status = 0 then do; /* Give the entry name instead of a word and bit offset. */ description = description || "$"; description = description || rtrim (entry_name); end; else do; /* Give the word and bit offset, if nonzero. */ description = description || word_offset; description = description || bit_offset; end; if ptr (location, 0) = stackbaseptr then do; /* See if it's in an active stack frame. */ sp = stackframeptr; do while (rel (sp) > rel (location) & stack_frame.prev_sp ^= null); sp = stack_frame.prev_sp; end; if rel (sp) <= rel (location) & rel (stack_frame.next_sp) > rel (location) then do; /* Indicate who owns the stack frame. */ description = description || " (stack_frame"; if location ^= sp then do; description = description || "|"; description = description || octal_representation (fixed (rel (location)) - fixed (rel (sp))); description = description || bit_offset; end; description = description || " of "; description = description || description_of_location (stack_frame.entry_ptr); description = description || ")"; end; end; else if index (seg_name, ".area.linker") > 0 then do; /* See if the location is in an external variable. */ sb = stackbaseptr; vthp = stack_header.sys_link_info_ptr; if vthp ^= null then do; checking_external_variables = True; do hash_table_idx = lbound (vthp -> variable_table_header.hash_table, 1) to hbound (vthp -> variable_table_header.hash_table, 1) while (checking_external_variables); do vnp = vthp -> variable_table_header.hash_table (hash_table_idx) repeat vnp -> variable_node.forward_thread while (vnp ^= null & checking_external_variables); if baseno (vnp -> variable_node.vbl_ptr) = baseno (location) then if rel (vnp -> variable_node.vbl_ptr) <= rel (location) & rel ( addrel (vnp -> variable_node.vbl_ptr, vnp -> variable_node.vbl_size)) > rel (location) then do; /* Indicate the name of the external variable. */ checking_external_variables = False; description = description || " (External Variable "; description = description || vnp -> variable_node.name; if vnp -> variable_node.vbl_ptr ^= location then do; description = description || "|"; description = description || octal_representation ( fixed (rel (location)) - fixed (rel (vnp -> variable_node.vbl_ptr)) ); description = description || bit_offset; end; description = description || ")"; end; end; end; end; end; end; return (description); %include stack_frame; %include stack_header; %include system_link_names; end description_of_location; get_fsm_dir_dir_path: proc (fsm_dir_dir_path); /* Function: to return the pathname of the directory which will contain */ /* the directory of segments managed by 'fsm_'. This pathname is */ /* obtained from the variable 'fsm_dir_dir_path' in the user's per- */ /* process value segment or default permanent value segment (with the */ /* value in the perprocess value segment taking precedent if it is */ /* defined differently in the two value segments). If neither of these */ /* value segments define the variable, or if the value is "", then the */ /* pathname of the process directory is returned. If the defined value */ /* is not an absolute pathname (i.e. does not start with ">"), the */ /* condition 'fortran_storage_manager_error' is signalled with a */ /* description of the problem. If this occurs, the user should fixed the */ /* value segment and restart. */ /* Arguments: */ /* */ /* fsm_dir_dir_path (Output) */ /* is the absolute pathname of the directory which will contain the */ /* directory of segments managed by 'fsm_'. */ dcl fsm_dir_dir_path char (*); dcl error_table_$not_abs_path fixed bin (35) ext; dcl get_pdir_ entry returns (char (168)), value_$get entry (ptr, bit (36) aligned, char (*), char (*), fixed bin (35)); dcl status fixed bin (35); fsm_dir_dir_path = ""; do while (fsm_dir_dir_path = ""); call value_$get (null, "11"b, "fsm_dir_dir_path", fsm_dir_dir_path, status); if fsm_dir_dir_path = "" then fsm_dir_dir_path = get_pdir_ (); else if substr (fsm_dir_dir_path, 1, 1) ^= ">" then do; call signal_fsm_error (error_table_$not_abs_path, "Value segment specifies 'fsm_dir_dir_path' = " || fsm_dir_dir_path); fsm_dir_dir_path = ""; end; end; end get_fsm_dir_dir_path; list_groups: proc (max_group_cnt, desired_process); /* Function: to list (on the 'user_output' switch) the groups of segments */ /* which are allocated to a specified process. The groups are listed by */ /* owner. */ /* Arguments: */ /* */ /* max_group_cnt (Input) */ /* is the maximum number of groups to be listed. If there are more */ /* groups than this, the excess are ignored without comment. */ /* */ /* desired_process (Input) */ /* is the ID of the process whose groups are to be listed. */ /* */ dcl max_group_cnt fixed bin, desired_process bit (36) aligned; dcl get_line_length_$stream entry (char (*), fixed bin (35)) returns (fixed bin), ioa_$nnl entry options (variable); dcl 01 expected_group aligned like group; dcl 01 group (max_group_cnt) aligned, 02 owner ptr unaligned, 02 first_seg_in_group fixed bin; dcl expected_group_idx fixed bin, group_cnt fixed bin, group_idx fixed bin, line_len fixed bin, max_line_len fixed bin, name char (32) varying, prev_group_owner ptr unaligned, seg_idx fixed bin, status fixed bin (35), trial_group_idx fixed bin; /* Store in 'group' the owner and number of the first segment of each group */ /* allocated to this process. */ group_cnt = 0; do seg_idx = 1 to fsm_info.seg_cnt while (group_cnt < max_group_cnt); if fsm_info.seg (seg_idx).owning_process = desired_process & fsm_info.seg (seg_idx).first_seg_in_group = seg_idx then do; group_cnt = group_cnt + 1; group (group_cnt).owner = fsm_info.owner (seg_idx); group (group_cnt).first_seg_in_group = fsm_info.first_seg_in_group (seg_idx); end; end; /* Sort groups into ascending order of owner and number of first segment in */ /* the group. */ do group_idx = 1 to group_cnt - 1; expected_group = group (group_idx); expected_group_idx = group_idx; do trial_group_idx = group_idx + 1 to group_cnt; if unspec (group (trial_group_idx)) < unspec (expected_group) then do; expected_group = group (trial_group_idx); expected_group_idx = trial_group_idx; end; end; if group_idx ^= expected_group_idx then do; group (expected_group_idx) = group (group_idx); group (group_idx) = expected_group; end; end; /* List the groups. */ max_line_len = get_line_length_$stream ("user_output", status); unspec (prev_group_owner) = ""b; /* Start with an impossible owner. */ do group_idx = 1 to group_cnt; if group (group_idx).owner ^= prev_group_owner then do; /* Describe new owner. */ prev_group_owner = group (group_idx).owner; call ioa_$nnl ("^/^a owns:^/", description_of_location ((prev_group_owner))); end; call ioa_$nnl ("^4x"); line_len = 4; do seg_idx = group (group_idx).first_seg_in_group repeat fsm_info.next_seg_in_group (seg_idx) while (seg_idx ^= 0); name = rtrim (seg_name (seg_idx)); if line_len + 1 + length (name) <= max_line_len then do; line_len = line_len + 1 + length (name); call ioa_$nnl (" ^a", name); end; else do; line_len = 10 + length (name); call ioa_$nnl ("^/^-^a", name); end; end; call ioa_$nnl ("^/"); end; end list_groups; octal_representation: proc (value) returns (char (12) varying); /* Function: to return the octal representation of an integer value. */ /* Arguments: */ /* */ /* value (Input) */ /* is the integer value whose octal representation is desired. */ dcl value fixed bin; dcl cv_bin_$oct entry (fixed bin, char (12) aligned); dcl string char (12) aligned; call cv_bin_$oct (value, string); return (ltrim (string)); end octal_representation; pick_first_seg_num: proc (num_segs_desired, first_seg_num); /* Function: to find a set of a specified size of free, consecutive */ /* segment numbers and return the first segment number of the set. */ /* Arguments: */ /* */ /* num_segs_desired (Input) */ /* is the number of consecutive segment numbers needed. */ /* */ /* first_seg_num (Output) */ /* is the first segment number of the chosen set of consecutive segment */ /* numbers. */ dcl num_segs_desired fixed bin, first_seg_num fixed bin; dcl hcs_$high_low_seg_count entry (fixed bin, fixed bin); dcl best_hole_size fixed bin, best_hole_start fixed bin, cur_hole_size fixed bin, found_highest_seg_num_in_use bit (1), high_seg_num fixed bin, high_seg_num_minus_low_seg_num fixed bin, low_seg_num fixed bin, seg_num fixed bin; /* Find the lowest segment number allowed to be used and the highest that */ /* is currently in use. */ call hcs_$high_low_seg_count (high_seg_num_minus_low_seg_num, low_seg_num); high_seg_num = high_seg_num_minus_low_seg_num + low_seg_num; low_seg_num = low_seg_num + 8; /* First 8 reserved for stacks. */ found_highest_seg_num_in_use = False; do while (^found_highest_seg_num_in_use); if seg_num_free (high_seg_num) then high_seg_num = high_seg_num - 1; else found_highest_seg_num_in_use = True; end; /* Search from the lowest segment number allowed to be used to the highest */ /* in use for the smallest set of consecutive segment numbers that is at */ /* least as big as needed. */ best_hole_size, cur_hole_size = 0; do seg_num = low_seg_num to high_seg_num while (best_hole_size ^= num_segs_desired); if seg_num_free (seg_num) then cur_hole_size = cur_hole_size + 1; else do; if cur_hole_size >= num_segs_desired then if best_hole_size = 0 | best_hole_size > cur_hole_size then do; /* Latest hole is best fit so far. */ best_hole_size = cur_hole_size; best_hole_start = seg_num - best_hole_size; end; cur_hole_size = 0; end; end; /* If we found a hole large enough, choose the first segment number in it */ /* as the start of the desired set; otherwise, start the set immediately */ /* following the highest segment number currently in use. */ if best_hole_size < num_segs_desired then first_seg_num = high_seg_num + 1; else first_seg_num = best_hole_start; end pick_first_seg_num; pick_seg: proc (seg_idx); /* Function: to choose a free segment to be allocated. If there are none, */ /* one is created. */ /* Arguments: */ /* */ /* seg_idx (Output) */ /* is the index of the element in 'fsm_info.seg' which corresponds to */ /* the segment which has been chosen. */ dcl seg_idx fixed bin; dcl get_group_id_ entry returns (char (32)), hcs_$append_branch entry (char (*), char (*), fixed bin (5), fixed bin (35)), hcs_$replace_acl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35)), hcs_$set_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35)), hcs_$set_safety_sw entry (char (*), char (*), bit (1), fixed bin (35)), pl1_operators_$VLA_words_per_seg_ fixed bin (19) external; dcl 01 acl aligned, 02 access_name char (32), 02 modes bit (36), 02 xmodes bit (36), 02 status fixed bin (35); dcl status fixed bin (35); do seg_idx = 1 to fsm_info.seg_cnt while (fsm_info.seg (seg_idx).owning_process ^= ""b); end; if seg_idx <= fsm_info.seg_cnt then do; /* Reuse free segment. */ acl.access_name = get_group_id_ (); acl.modes = RW_ACCESS; acl.xmodes = ""b; status = 1; do while (status ^= 0); call hcs_$replace_acl (fsm_dir_path, seg_name (seg_idx), addr (acl), 1, "0"b, status); if status ^= 0 then call signal_fsm_error (status, pathname_ (fsm_dir_path, seg_name (seg_idx))); end; end; else do while (seg_idx > fsm_info.seg_cnt); /* Create a segment. */ call hcs_$append_branch (fsm_dir_path, seg_name (seg_idx), RW_ACCESS_BIN, status); if status = 0 then do; fsm_info.seg_cnt = seg_idx; fsm_info.seg (seg_idx).owner = null; call hcs_$set_max_length (fsm_dir_path, seg_name (seg_idx), pl1_operators_$VLA_words_per_seg_, status); if status ^= 0 then call signal_fsm_error (status, pathname_ (fsm_dir_path, seg_name (seg_idx))); call hcs_$set_safety_sw (fsm_dir_path, seg_name (seg_idx), "1"b, status); end; else call signal_fsm_error (status, pathname_ (fsm_dir_path, seg_name (seg_idx))); end; end pick_seg; release_fsm_info: proc; /* Function: to free any segments that have been allocated to 'fsm_', then */ /* to unlock 'fsm_info' so it can be used by other processes. */ dcl hcs_$terminate_file entry (char (*), char (*), fixed bin (1), fixed bin (35)), set_lock_$unlock entry (bit (36) aligned, fixed bin (35)); dcl seg_idx fixed bin, status fixed bin (35); /* This routine may be called in response to a 'cleanup' condition before */ /* 'fsm_info' has been locked for this process, or possibly even found. */ /* Thus, we must be careful to check for these possibilities. */ if fsm_info_ptr ^= null then if fsm_info.lock = my_process then do; /* 'fsm_info' is locked for this process. */ do seg_idx = 1 to fsm_info.seg_cnt; if fsm_info.seg (seg_idx).owning_process = my_process & fsm_info.seg (seg_idx).owner = me then do; call hcs_$terminate_file (fsm_dir_path, seg_name (seg_idx), 0, status); unspec (fsm_info.seg (seg_idx)) = ""b; end; end; status = 1; do while (status ^= 0); call set_lock_$unlock (fsm_info.lock, status); if status ^= 0 then call signal_fsm_error (status, "Trying to unlock 'fsm_info'."); end; end; end release_fsm_info; seg_name: proc (seg_idx) returns (char (32)); /* Function: to return the name of the segment associated with a specified */ /* element of 'fsm_info.seg'. The name is 'N.fsm_', where 'N' is the */ /* decimal representation of the index of the specified element. */ /* Arguments: */ /* */ /* seg_idx (Input) */ /* is the index of the element of 'fsm_info.seg' with which the segment */ /* is associated. */ dcl seg_idx fixed bin; return (ltrim (char (seg_idx)) || ".fsm_"); end seg_name; seg_num_free: proc (seg_num) returns (bit (1)); /* Function: to indicate whether a given segment number is currently in */ /* use. (Since there is no system function to do this, we fake it by */ /* asking for the unique-id of the segment corresponding to the segment */ /* number. If the return code is 'error_table_$invalidsegno', then the */ /* segment number is free.) */ /* Arguments: */ /* */ /* seg_num (Input) */ /* is the segment number to be tested. */ dcl seg_num fixed bin; dcl error_table_$invalidsegno fixed bin (35) ext; dcl hcs_$get_uid_seg entry (ptr, bit (36) aligned, fixed bin (35)); dcl status fixed bin (35), uid bit (36) aligned; call hcs_$get_uid_seg (baseptr (seg_num), uid, status); if status = error_table_$invalidsegno then return (True); else return (False); end seg_num_free; signal_fsm_error: proc (status, details); /* Function: to signal the restartable condition */ /* 'fortran_storage_manager_error'. */ /* Arguments: */ /* */ /* status (Input) */ /* is a standard system status code describing why the condition is */ /* being signalled. */ /* */ /* details (Input) */ /* is supplementary information regarding why the condition is being */ /* signalled. */ dcl status fixed bin (35), details char (*); dcl signal_ entry options (variable); %include condition_info_header; dcl 01 condition_info aligned like condition_info_header; condition_info.length = size (condition_info); condition_info.version = 1; unspec (condition_info.action_flags) = ""b; condition_info.info_string = rtrim (details); condition_info.status_code = status; call signal_ ("fortran_storage_manager_error", null, addr (condition_info)); end signal_fsm_error; %include access_mode_values; end fortran_storage_manager_;  general_format_parse_.pl1 07/30/86 0917.6rew 07/28/86 1458.5 287352 /****^ ****************************************************** * * * Copyright, (C) Honeywell Limited, 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105): Fix fortran bug 462. 2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105): Fix fortran bug 122. END HISTORY COMMENTS */ /* Modified: 25 Nov 85, RW - 122: Raised the max number of items in a format statement to 1023, up from 510 18 Jul 85, BW - 462: Detect implementation restriction that 131071 (2**17 - 1) is the maximum value that an r, w, or d field can be. 01 Nov 84, BW - 445: Allow use of * to indicate list-directed I/0. 30 Oct 82, HH - 115: Conform to the FORTRAN/77 Standard for D, E, F and G formats by removing restrictions that d <= w and w - d >= size of exponent field. 09 Sep 82, HH - 114: Allow unary plus sign wherever unary minus is allowed. 27 Apr 82, HH - Defer range check on scale factor to runtime. 26 Apr 82, HH - Ignore NUL's outside of Hollerith's. 24 July,1981 MEP - add new features for FORTRAN77, comment the code better, slightly alter the layout of the code 23 May, 1978, DSL - fix code that zeros unused portion of last word. March, April 1978, DSL - To implement new format. modified March 1973 by A. Downing to be used at compile time and run time. modified June, 1976 by D.S.Levin to clean up and to implement s- and :-formats. modified April 7, 1977 David Levin - improve error messages. */ /* format: style2 */ general_format_parse_: proc (source_chars, encoded_format, ansi77, error_code); /* parameter */ dcl source_chars char (1320) aligned; /* INPUT */ dcl encoded_format char (4096) aligned; /* OUTPUT */ declare ansi77 bit (1) aligned; /* INPUT */ dcl error_code fixed bin (35); /* OUTPUT */ /* automatic */ dcl V_format_location fixed bin; /* if a v_format, where it is */ dcl asterisk_format_location fixed bin; /* if an asterisk_format, where it is */ dcl ch char (1) aligned; /* quote char */ dcl char_type fixed bin; /* ascii value of character */ dcl d fixed bin; /* precision field */ dcl digit_encountered bit (1) aligned; dcl dollar_format_location fixed bin; /* if a dollar-format, where it is */ declare expon_field fixed bin; /* width in g and e formats */ dcl field_count fixed bin; /* number of fields in encoded format */ dcl first_string fixed bin; /* location of first Hollerith in encoded fmt */ dcl fmt_spec fixed bin; /* coded format specifier as understood by interpreter */ dcl from_runtime bit (1) aligned; /* if called at runtime */ dcl i fixed bin; dcl in fixed bin; /* index in source_chars */ dcl input_ptr ptr; dcl j fixed bin; dcl last_string fixed bin; /* like first string */ dcl minus_encountered bit (1) aligned; /* if a minus before digits */ dcl new_state fixed bin; /* NEXT state of finite state machine */ dcl out fixed bin; /* index into encoded fomt */ dcl output_ptr ptr; dcl p ptr; dcl paren_count fixed bin; /* nested paren level */ dcl paren_stored (100) bit (1) aligned; /* for rep count of paren fields */ dcl prev_delim fixed bin; /* value of last delimiter */ dcl r fixed bin; /* repition count */ dcl state fixed bin; /* PRESENT state */ dcl w fixed bin; /* width field */ dcl 1 fields aligned structure, 2 spec fixed bin (17) unal, 2 rep_factor fixed bin (17) unal, 2 width fixed bin (17) unal, 2 precision fixed bin (17) unal; /* constants */ declare ALLOWED char (42) internal static options (constant) init ("-format allowed in a format specification."); declare FALSE bit (1) aligned internal static options (constant) initial ("0"b); declare LIST_DIRECTED_ERROR char (63) internal static options (constant) initial ("V-format can only appear with line number skipping or $-format."); declare LIST_DIRECTED_ERROR2 char (74) internal static options (constant) initial ( "*-format can only appear with line number skipping, $-format, or a-format."); declare ONLY1 char (9) internal static options (constant) initial ("Only one "); declare TRUE bit (1) aligned internal static options (constant) initial ("1"b); declare WHITE char (3) aligned int static options (constant) initial (" "); /* SP, TAB and NUL */ declare WITH_CONTEXT bit (1) aligned internal static options (constant) initial ("1"b); declare NO_CONTEXT bit (1) aligned internal static options (constant) initial ("0"b); declare ascii_for_zero fixed binary internal static options (constant) initial (48); dcl char_mask (3) bit (36) aligned int static options (constant) init ("777000000000"b3, "777777000000"b3, "777777777000"b3); declare comma fixed bin internal static options (constant) initial (2); dcl delimiter (2) char (16) varying int static options (constant) init ("Left parenthesis", "Comma"); declare illegal_char fixed binary internal static options (constant) init (22); dcl left_parn fixed bin int static options (constant) init (1); declare ( v_format init (28), dollar_format init (29), caret init (26), tl_format init (99), b_format init (25), asterisk_format init (21) ) fixed bin int static options (constant); /* based */ dcl 1 based_fields like fields unaligned based structure; dcl in_fmt char (1320) aligned based (input_ptr); dcl 1 neat_source_text aligned based (input_ptr), 2 pad1 char (in) unaligned, 2 this_char char (1) unaligned, 2 next_char char (1) unaligned, 2 pad2 char (1320 - in - 2) unaligned; declare 1 overlay_for_strings aligned based (input_ptr), 2 pad1 char (in) unaligned, 2 rest_of_format char (1320 - i) unaligned; dcl 1 output_format aligned like runtime_format based (output_ptr); dcl word (1024) bit (36) aligned based (output_ptr); /* builtin */ declare (addr, binary, divide, hbound, index, length, substr, string, unspec, verify) builtin; /* general format parse is implemented as a finite state machine of sorts. The states are defined by action_matrix.state_table. This is a two dimension array, the columns defining the character just seen, and the rows the "state" of the format being parsed. The entry in the table is the row of the table to use as the next "state". There is also action_matrix.action_list, which is used as the index of a label array of actions to take when encountering the input character in the given state. The array table_column converts the character just seen to the proper column in the table to use,so reducing the size of the table needed, and additional information is kept in the variables type_char and format_spec. For this reason, and for the fact that we do a little special casing and one character look-ahead, this is not really a TRUE finite state machine. */ /* A FEW TABLES TO HELP FUTURE MAINTAINERS, basically inverted lists char_type versus letter (type 22 is illegal characters) 0 i 1 f 2 e 3 l 4 d 5 o 6 g 7 0..9 8 +- 9 r 10 a 11 h 12 x 13 t 14 p 15 ( 16 ) 17 / 18 : 19 '" 20 21 * 22 23 , 24 . 25 ^ 26 b 27 s 28 v 29 $ there is an almost one-to-one relation ship between char_type and the fmt_spec as understood by fortran_io_. The differences are that 20 is used for end_of_format, 21 for TL/TR, 22 for extended I format (Iw.m), 25 for BN, 26 for BN, 27 for S, 28 for SP, and 29 for SS. actions 1 slash or colon: terminate and create current format 2 left paren: implied iteration is 1 3 right paren: terminate format is necessary 4 left paren: iteration explicitly given 5 x-format: implied iteration is 1 6 plus or minus sign: signed scale factor 7 build replication factor 8 a,d,e,f,g,h,i,l,o,r: implied iteration is 1 9 failure - can't translate 10 create hollerith from " or ' 11 white space -skip to next character 12 a,d,e,f,g,h,i,l,o,r: iteration explicitly given 13 field width is * 14 create formats with a w,but no d field (a,o,l,r,t,i?) 15 build width field 16 hollerith from h-format 17 x-format iteration explicitly given 18 failure - out of place 19 p-format terminate 20 create d and f formats 21 build precision field 22 build width field, expect precision field 23 comma as separator 24 recognize new Iw.m format 25 failure - no precision field 26 build specs with neither width nor replication: s, b, v, $, and ^ 27 build exponent field 28 complete e and g fileds with expon 29 begin t field 30 recognize Ef.dEe and Gf.dEe formats */ /* format: off */ /* Table to convert character to format type. */ dcl type_char(0:127) fixed bin internal static options(constant) init( /* 0 1 2 3 4 5 6 7 */ /* 000 */ 20, 22, 22, 22, 22, 22, 22, 22, /* \000 - \007 */ /* 010 */ 22, 20, 22, 22, 22, 22, 22, 22, /* \010 TAB \012 - \017 */ /* 020 */ 22, 22, 22, 22, 22, 22, 22, 22, /* \020 - \027 */ /* 030 */ 22, 22, 22, 22, 22, 22, 22, 22, /* \030 - \037 */ /* 040 */ 20, 22, 19, 22, 29, 22, 22, 19, /* SP ! " # $ % & ' */ /* 050 */ 15, 16, 21, 8, 23, 8, 24, 17, /* ( ) * + , - . / */ /* 060 */ 7, 7, 7, 7, 7, 7, 7, 7, /* 0 1 2 3 4 5 6 7 */ /* 070 */ 7, 7, 18, 22, 22, 22, 22, 22, /* 8 9 : ; < = > ? */ /* 100 */ 22, 10, 25, 22, 4, 2, 1, 6, /* @ A B C D E F G */ /* 110 */ 11, 0, 22, 22, 3, 22, 22, 5, /* H I J K L M N O */ /* 120 */ 14, 22, 9, 27, 13, 22, 28, 22, /* P Q R S T U V W */ /* 130 */ 12, 22, 22, 22, 22, 22, 26, 22, /* X Y Z [ \ ] ^ _ */ /* 140 */ 22, 10, 25, 22, 4, 2, 1, 6, /* ` a b c d e f g */ /* 150 */ 11, 0, 22, 22, 3, 22, 22, 5, /* h i j k l m n o */ /* 160 */ 14, 22, 9, 27, 13, 22, 28, 22, /* p q r s t u v w */ /* 170 */ 12, 22, 22, 22, 22, 22, 22, 22); /* x y z */ /* table to convert format spec type (or character type) to proper COLUMN for lex action table */ dcl table_column (0:29) fixed bin internal static options(constant) init( 1, 2, 2, 1, 2, 1, 2, 3, 4, 1, 1, 6, 7, 8, 9, 10, 11, 12, 12, 14, 15, 16, 18, 5, 13, 17, 17, 17, 17, 17); /* the use of this table eliminates the need for a multiplication */ dcl offset(6) fixed bin options(constant) internal static init( 0, 18, 36, 54, 72, 90); /* The table of actions and new states for each lexical form */ dcl 1 action_matrix(108) aligned internal static structure, /* the NEXT state table */ 2 state_table unaligned fixed bin(17) init( /* iloa defg 0..9 +- , h x t p ( ) /: . "' SP * sbv Others r ^$ */ /* Start */ 2, 3, 5, 5, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* Build w, no d */ 1, 1, 2, 5, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1, 2, 1, 1, 1, /* Build w, w/ d */ 1, 1, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 4, 1, 3, 1, 1, 1, /* Build d */ 1, 1, 4, 5, 1, 1, 1, 2, 1, 1, 1, 1, 6, 1, 4, 1, 1, 1, /* Build r or p */ 2, 3, 5, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 5, 1, 1, 1, /* Build e */ 1, 1, 6, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 6, 1, 1, 1), /* actions for all occasions */ 2 action_list unaligned fixed bin(17) init( /* iloa defg 0..9 +- , h x t p ( ) /: . "' SP * svb Others r ^$ */ /* Start */ 8, 8, 7, 6, 23, 18, 5, 29, 18, 2, 3, 1, 18, 10, 11, 26, 26, 9, /* Build w, no d */ 18, 18, 15, 14, 14, 18, 18, 14, 18, 18, 14, 14, 24, 14, 11, 13, 18, 9, /* Build w, w/ d */ 25, 25, 15, 25, 25, 25, 25, 25, 25, 25, 25, 25, 22, 25, 11, 25, 25, 9, /* Build d */ 18, 30, 21, 20, 20, 18, 18, 20, 18, 18, 20, 20, 18, 20, 11, 18, 18, 9, /* Build r or p */ 12, 12, 7, 18, 18, 16, 17, 18, 19, 4, 18, 18, 18, 18, 11, 18, 18, 9, /* Build e */ 18, 18, 27, 18, 28, 18, 18, 18, 18, 18, 28, 28, 18, 18, 11, 18, 18, 9); /* format: on */ %include format_tables; from_runtime = FALSE; goto common; runtime: entry (source_chars, encoded_format, ansi77, error_code); from_runtime = TRUE; common: /* copy input argument */ input_ptr = addr (source_chars); output_ptr = addr (encoded_format); /* Initialize */ unspec (output_format.header_word) = "0"b; output_format.version = fmt_parse_ver1; output_format.last_left_paren = 1; /* default is containing paren */ paren_count = 0; first_string = 0; last_string = 0; dollar_format_location = 0; V_format_location = 0; asterisk_format_location = 0; field_count = 0; new_state = 1; out = 0; digit_encountered = FALSE; prev_delim = 0; minus_encountered = FALSE; r, w, d, expon_field = 0; /* Convert old style format to new format. */ if input_ptr -> runtime_format.version = "0"b & input_ptr -> old_format.fmt (1) = 15 & from_runtime then do; string (output_format.format_desc_bits) = string (input_ptr -> old_format.format_desc_bits); if output_format.list_directed then do; out = chars_per_word; goto list_directed_return; end; i = 1; /* to get into loop */ do in = 3 repeat in + i while (i ^= 0); if in = input_ptr -> old_format.last_left_paren then output_format.last_left_paren = out + 1; unspec (fields) = unspec (addr (input_ptr -> old_format.fmt (in)) -> based_fields); i = increment_table (fields.spec); goto unpack_fields (i); unpack_fields (4): d = fields.precision; unpack_fields (3): w = fields.width; unpack_fields (2): r = fields.rep_factor; unpack_fields (1): if fields.spec = end_of_format then i = 0; call store_specification ((fields.spec)); end; goto successful_return; end; /* find the beginning of the format specifications */ in = verify (in_fmt, WHITE) - 1; if in < 0 /* entire spec is blank */ then call parse_failure ("Format must start with a left parenthesis.", NO_CONTEXT); if this_char ^= "(" /* must start with left paren */ then call parse_failure ("Format must start with a left parenthesis.", NO_CONTEXT); in = in - 1; /* the loop to parse the format specifications begins here */ new_action (11): /* action=11 No operation, get next char. */ main_loop: /* get the next character */ in = in + 1; if in >= length (in_fmt) then call parse_failure ("Final right parenthesis not found.", NO_CONTEXT); j = binary (unspec (this_char), 9, 0); /* determine format type, if any, and lex type */ if j > hbound (type_char, 1) then char_type = illegal_char; else char_type = type_char (j); /* get new state and do new action */ state = new_state; i = offset (state) + table_column (char_type); new_state = state_table (i); go to new_action (action_list (i)); /* end of the loop */ new_action (1): /* Character is a "/" or ":". */ field_count = field_count + 1; call store_specification (char_type); go to main_loop; new_action (2): /* Character is "(", Implied repetition is 1. */ r = 1; goto left_paren_common; new_action (4): /* Character is "(", Explicit repetition given. */ if r = 0 | minus_encountered then call parse_failure ("Repetition count must be greater than zero.", WITH_CONTEXT); left_paren_common: field_count = field_count + 1; paren_count = paren_count + 1; if paren_count > hbound (paren_stored, 1) then call parse_failure ("Too many parenthesis.", WITH_CONTEXT); /* if this is a level 1 left paren, format starts here when it is repeated. */ if paren_count = 2 then output_format.last_left_paren = out + 1; /* Parens are stored only if repetition count is greater than 1. */ if r = 1 then do; paren_stored (paren_count) = FALSE; r = 0; /* reset this field. */ end; else do; call store_specification (char_type); paren_stored (paren_count) = TRUE; end; prev_delim = left_parn; /* Prohibit delimiter after "(". */ goto main_loop; new_action (3): /* Character is a ")". */ field_count = field_count + 1; paren_count = paren_count - 1; /* the format "()" is valid only if that is the entire specification */ if prev_delim ^= 0 & field_count ^= 2 then call parse_failure (delimiter (prev_delim) || " immediately precedes a right parenthesis.", WITH_CONTEXT); if paren_stored (paren_count + 1) then call store_specification (char_type); if paren_count ^= 0 then goto main_loop; /* continue if not last paren */ call store_specification (end_of_format); goto successful_return; new_action (5): /* Now have 1x. */ r = 1; goto x_format_common; new_action (17): /* Come here if x is preceded by an integer. */ if r = 0 | minus_encountered then call parse_failure ("Field width for x-format must be greater than zero.", WITH_CONTEXT); x_format_common: field_count = field_count + 1; call store_specification (char_type); go to main_loop; new_action (6): /* Plus or minus sign encountered. */ digit_encountered = FALSE; if this_char = "-" then minus_encountered = TRUE; go to main_loop; new_action (7): /* Build repetition factor or scale factor. */ digit_encountered = TRUE; r = r * 10 + j - ascii_for_zero; go to main_loop; new_action (8): /* Repetition factor = 1. a,d,e,f,g,i,l,o fields. */ r = 1; goto width_only_common; new_action (12): /* Repetition factor given. a,d,e,f,g,i,l,o fields. */ if r = 0 | minus_encountered then call parse_failure ("Repetition count must be greater than zero.", WITH_CONTEXT); width_only_common: digit_encountered = FALSE; fmt_spec = char_type; go to main_loop; new_action (9): call parse_failure ("The character """ || this_char || """ cannot be translated.", WITH_CONTEXT); new_action (10): /* Create a character string. */ field_count = field_count + 1; output_format.contains_hollerith = TRUE; w = in + 2; ch = this_char; /* pick up delimiting character */ if first_string = 0 then first_string = out + 1; else addr (output_format.fmt (last_string)) -> long_format.precision = out + 1; last_string = out + 1; /* loop until the terminating delimit character is found */ do while (TRUE); in = in + 1; /* skip the delimiter */ i = index (rest_of_format, ch) - 1; /* find the next one */ if i < 0 then call parse_failure ("Missing string delimiter.", NO_CONTEXT); in = in + i; /* move up to the delimiter */ r = r + i; /* update length, without delimit char */ if next_char ^= ch /* this delimit char is really the end of the string */ then do; call store_specification (char_type); goto main_loop; end; in = in + 1; /* skip first of the pair of delimiters */ r = r + 2; /* length includes both delimiters */ end; go to main_loop; new_action (13): /* Field width is "*". */ field_count = field_count + 1; if digit_encountered | fmt_spec ^= a_format then call parse_failure ("Invalid use of ""*"".", WITH_CONTEXT); w = 4; call store_specification (fmt_spec); output_format.anyitems = TRUE; goto main_loop; new_action (14): /* Formats i, l, o, a, h, and t terminate here. */ field_count = field_count + 1; /* width must be positive or not_specified (a_format ONLY) in unspecified a_format, fortran_io_ should use the char_len of the variable as the width of the field */ if w = 0 then if fmt_spec ^= a_format | fmt_spec = a_format & digit_encountered then call parse_failure ("Field width must be greater than zero.", WITH_CONTEXT); if fmt_spec = tl_format then do; /* tl format is tr_format, but in a "negative" direction */ w = -w; fmt_spec = tr_format; end; else if fmt_spec ^= tr_format & fmt_spec ^= t_format then output_format.anyitems = TRUE; call store_specification (fmt_spec); goto new_action (action_list (table_column (char_type))); new_action (15): /* Build field width. */ digit_encountered = TRUE; w = w * 10 + j - ascii_for_zero; goto main_loop; new_action (16): /* Encode hollerith string. */ output_format.contains_hollerith = TRUE; field_count = field_count + 1; if r = 0 | minus_encountered then call parse_failure ("Length of hollerith constant must be greater than zero.", WITH_CONTEXT); w = in + 2; in = in + r; if first_string = 0 then first_string = out + 1; else addr (output_format.fmt (last_string)) -> long_format.precision = out + 1; last_string = out + 1; call store_specification (char_type); goto main_loop; MISPLACED: new_action (18): /* missing delimiter. */ call parse_failure ("The character """ || this_char || """ is out of place.", WITH_CONTEXT); new_action (19): /* End of 'p' specification. */ field_count = field_count + 1; if ^digit_encountered then call parse_failure ("Sign must be followed by a digit.", WITH_CONTEXT); if minus_encountered then r = -r; prev_delim = 0; call store_specification (char_type); goto main_loop; process_d_field: new_action (20): /* Formats f, e, d, and g are defined here. */ if ^digit_encountered then call parse_failure ("Missing precision field.", WITH_CONTEXT); output_format.anyitems = TRUE; if new_state = 6 /* building expon field */ then do; digit_encountered = FALSE; goto main_loop; end; else do; /* no expon field, store it */ field_count = field_count + 1; call store_specification (fmt_spec); go to new_action (action_list (table_column (char_type))); end; new_action (21): /* Create decimal position. */ digit_encountered = TRUE; d = d * 10 + j - ascii_for_zero; go to main_loop; process_w_field: new_action (22): /* Make sure there was a legal numeric field. */ if w = 0 then call parse_failure ("Width of field must be greater than zero.", WITH_CONTEXT); digit_encountered = FALSE; go to main_loop; new_action (23): /* Test for legal appearance of a comma. */ if prev_delim ^= 0 then call parse_failure (delimiter (prev_delim) || " immediately precedes a comma.", WITH_CONTEXT); prev_delim = comma; go to main_loop; new_action (24): /* possibly unexpected "." */ if fmt_spec = i_format /* new Iw.m format indicated */ then do; fmt_spec = extended_i_format; new_state = 4; /* build "precision" field */ goto process_w_field; end; else goto MISPLACED; new_action (25): call parse_failure ("Precision field is omitted.", WITH_CONTEXT); new_action (26): /* If char = v and this the only field, list directed */ if char_type = v_format then do; if field_count ^= 1 | dollar_format_location ^= 0 then call parse_failure (LIST_DIRECTED_ERROR, NO_CONTEXT); if V_format_location ^= 0 then call parse_failure (ONLY1 || this_char || ALLOWED, NO_CONTEXT); field_count = field_count + 1; V_format_location = field_count + 1; prev_delim = 0; end; else if char_type = asterisk_format then do; if field_count ^= 1 | dollar_format_location ^= 0 then call parse_failure (LIST_DIRECTED_ERROR2, NO_CONTEXT); if asterisk_format_location ^= 0 then call parse_failure (ONLY1 || this_char || ALLOWED, NO_CONTEXT); field_count = field_count + 1; asterisk_format_location = field_count + 1; prev_delim = 0; end; /* sadly, in ansi 66 mode, s-format meant skip line numbers, now it refers to the processing of leading plus signs. so, it is hung on the ansi77 switch input argument. To get the same effect in ansi77, use ^N (the two characters,caret and N ). */ else if char_type = s_format then do; if next_char = "s" | next_char = "S" then do; in = in + 1; call store_specification (ss_format); end; else if next_char = "p" | next_char = "P" then do; in = in + 1; call store_specification (sp_format); end; else if ansi77 then call store_specification (s_format); else call skip_line_numbers; end; else if char_type = caret then do; if next_char = "l" | next_char = "L" then do; in = in + 1; call skip_line_numbers; end; else goto MISPLACED; end; /* $-format */ else if char_type = dollar_format then do; if dollar_format_location ^= 0 then call parse_failure (ONLY1 || this_char || ALLOWED, NO_CONTEXT); dollar_format_location = field_count + 1; prev_delim = 0; end; else if char_type = b_format then do; if next_char = "z" | next_char = "Z" then fmt_spec = bz_format; else if next_char = "n" | next_char = "N" then fmt_spec = bn_format; else goto MISPLACED; in = in + 1; field_count = field_count + 1; call store_specification (fmt_spec); end; goto main_loop; new_action (27): /* build exponent field */ digit_encountered = TRUE; expon_field = expon_field * 10 + j - ascii_for_zero; goto main_loop; new_action (28): /* complete e and g formats with expon */ field_count = field_count + 1; if ^digit_encountered then call parse_failure ("Missing exponent field.", WITH_CONTEXT); if expon_field > max_value then call parse_failure ("Exponent field too large.", WITH_CONTEXT); call store_specification (fmt_spec); goto new_action (action_list (table_column (char_type))); new_action (29): if next_char = "l" | next_char = "L" then do; in = in + 1; fmt_spec = tl_format; end; else if next_char = "r" | next_char = "R" then do; in = in + 1; fmt_spec = tr_format; end; else fmt_spec = t_format; digit_encountered = FALSE; r = 1; goto main_loop; new_action (30): /* prepare for expon field in Ew.dEe formats */ if char_type = e_format & (fmt_spec = e_format | fmt_spec = g_format) then do; new_state = 6; /* build expon field */ goto process_d_field; end; else goto MISPLACED; successful_return: out = out * chars_per_word + 1; /* Length of spec in chars. Only the first char of the */ /* final word is included in length. */ /* If called by compiler and hollerith fields exist, copy them into spec. */ if ^from_runtime then do i = first_string repeat p -> long_format.precision while (i ^= 0); p = addr (output_format.fmt (i)); if out + p -> long_format.rep_factor > length (encoded_format) - chars_per_halfword then call parse_failure ("Format specification is too long.", WITH_CONTEXT); substr (encoded_format, out + 1, p -> long_format.rep_factor) = substr (source_chars, p -> long_format.width, p -> long_format.rep_factor); p -> long_format.width = out + 1; out = out + p -> long_format.rep_factor; end; /* Zero remaining character positions in the last word. */ j = divide (out, chars_per_word, 17, 0); i = out - j * chars_per_word; if i ^= 0 then word (j + 1) = word (j + 1) & char_mask (i); out = divide (out + chars_per_halfword - 1, chars_per_halfword, 17, 0) * chars_per_halfword; /* round to half word */ /* Post processing for v-format. */ if V_format_location ^= 0 then do; if V_format_location ^= field_count then call parse_failure (LIST_DIRECTED_ERROR, NO_CONTEXT); output_format.list_directed = TRUE; out = chars_per_word; end; /* Post processing for asterisk-format. */ else if asterisk_format_location ^= 0 then do; if asterisk_format_location ^= field_count then call parse_failure (LIST_DIRECTED_ERROR2, NO_CONTEXT); output_format.list_directed = TRUE; out = chars_per_word; end; /* Post processing for $-format. */ if dollar_format_location ^= 0 then do; if dollar_format_location ^= field_count then call parse_failure ("$-format must be the last specification in a format specification.", NO_CONTEXT); output_format.suppress_newline = TRUE; end; list_directed_return: output_format.fmt_len = out; /* Copy length into format */ output_ptr -> old_format.fmt (divide (out, chars_per_halfword, 17, 0) - 1) = in + 1; /* Return number of chars parsed. */ error_code = 0; return; abort_return: error_code = -1; return; store_specification: procedure (a_type); dcl a_type fixed bin; dcl word_count fixed bin; dcl p ptr; dcl spec_type fixed bin; dcl fix_bin_17 fixed bin internal static options (constant) initial (131071); if r > fix_bin_17 then call parse_failure ("Implementation restriction: repetition count must be less than 131072.", WITH_CONTEXT) ; if w > fix_bin_17 | -w > fix_bin_17 then call parse_failure ("Implementation restriction: field width must be less than 131072.", WITH_CONTEXT); if d > fix_bin_17 then call parse_failure ("Implementation restriction: number of fractional digits must be less than 131072.", WITH_CONTEXT); spec_type = a_type; p = addr (output_format.fmt (out + 1)); /* Use long format for all string fields or if overflow occurs. Note: w must always be positive, except for tl_format which is implemented as "negative" tr_format */ if r > max_value | w > max_value | d > max_value | spec_type = hollerith_field | spec_type = quoted_string | expon_field > 0 | -w > max_value then do; if increment_table (spec_type) <= 2 then word_count = 1; else word_count = 2; if out + word_count > hbound (output_format.fmt, 1) then call parse_failure ("Format specification is too long.", WITH_CONTEXT); else out = out + word_count; p -> long_format.spec = spec_type; p -> long_format.long_format = TRUE; p -> long_format.exponent = expon_field; p -> long_format.rep_factor = r; if word_count > 1 then do; p -> long_format.width = w; p -> long_format.precision = d; end; end; else do; if out + 1 > hbound (output_format.fmt, 1) then call parse_failure ("Format specifiation is too long.", WITH_CONTEXT); else out = out + 1; p -> format.spec = spec_type; p -> format.long_format = FALSE; p -> format.rep_factor = r; p -> format.width = w; p -> format.precision = d; end; r, w, d, expon_field, prev_delim = 0; minus_encountered, digit_encountered = FALSE; end /* store_specification */; skip_line_numbers: procedure; declare err_chars char (2) varying; if field_count ^= 1 then call parse_failure ("Line number skipping must be the first specification in a format specification.", NO_CONTEXT); if output_format.skip_line_numbers then do; if ansi77 then err_chars = "^N"; else err_chars = "S"; call parse_failure (ONLY1 || err_chars || ALLOWED, NO_CONTEXT); end; output_format.skip_line_numbers = TRUE; prev_delim = 0; end skip_line_numbers; parse_failure: procedure (err_str, add_chars); dcl add_chars bit (1) aligned; dcl err_str char (*); dcl max builtin; /* This procedure is called to return abnormally from parsing a format specification. */ i = length (err_str); /* length of message */ addr (encoded_format) -> error_message = err_str; /* copy message and blank the rest */ if add_chars /* if message is to include context, add it now */ then do; substr (encoded_format, i + 5, 13) = " Context is: "; j = max (in - 9, 0); /* Try to get preceding characters */ substr (encoded_format, i + 18, in - j + 1) = substr (in_fmt, j + 1, in - j + 1); end; /* return number of characters parsed */ addr (encoded_format) -> input_length = in + 1; goto abort_return; end /* parse_failure */; end /* general_format_parse_ */;  return_to_user.alm 11/05/86 1557.9r w 11/04/86 1038.6 33894 " ****************************************************** " * * " * Copyright, (C) Honeywell Limited, 1983 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " ****************************************************** " HISTORY COMMENTS: " 1) change(86-07-14,BWong), approve(86-07-14,MCR7442), " audit(86-07-17,Ginter), install(86-07-28,MR12.0-1105): " Fix fortran bug 493. " END HISTORY COMMENTS " return_to_user.alm " " This module implements end= and err= for fortran_io_. It also implements all returns " to the user from fortran_io_. The entry point return_to_user is used to implement " end= and err=. The entry point special_return is used to implement a return from " fortran_io_ while "absorbing" fortran_io_'s stack frame. " " Written by Richard A. Barnes 18 November 1976. " " Usages: " " declare return_to_user entry(ptr, ptr); " call return_to_user(return_loc_ptr, stack_frame_ptr); " " declare return_to_user$special_return entry; " call return_to_user$special_return(); " " This module makes the following assumptions: " - no cleanup handlers exist between the user's stack frame and our stack frame, " - the user's stack frame is not extended, " - no rings have been crossed between the user's frame and fortran_io_'s (ours). " - fortran_io_'s stack frame is absorbed by the user frame when fortran_io_ returns. " This is possible only if fortran_io_ always uses return_to_user$special_return " to return to its caller. " " " Modified: " 11 March 86, MM & BW - 493: Make 'return_to_user' save indicators " in sp|stack_frame.return_ptr+1 before returning. Remove " restoring of indicators in 'special_return'. In both " cases, 'short_return' will restore the indicators. " 07 Dec 83, HH - Make 'special_return' restore indicators before returning. " 15 March 1978 DSL - fix $return_to_user code. " 19 Dec 1977 DSL - to implement special_return entry point and modify return_to_user " entry point for new stack frame conventions. " include stack_header include stack_frame name return_to_user segdef return_to_user return_to_user: " " First, make user stack frame the current frame and absorb " fortran_io_'s stack frame within the user stack frame. " eppbp ap|4,* " get address of 2nd argument inhibit on eppsp bp|0,* " get address of user stack frame into SP eppbp sp|stack_frame.next_sp,* " get address of fortran_io_ stack frame eppbb bp|4,* " get true end of fortran_io_ frame spribb bp|stack_frame.next_sp " restore fortran_io_'s next_sp spribb sp|stack_frame.next_sp " include fortran_io_ frame within user's spribb sb|stack_header.stack_end_ptr " shorten stack to end of user's frame inhibit off " " Next, use first argument to set return ptr. " eppbb ap|2,* " get address of 1st argument eppbb bb|0,* " get value of return_loc_ptr ldi sp|stack_frame.return_ptr+1 " save indicators temporarily spribb sp|stack_frame.return_ptr " the seg num must be restored sti sp|stack_frame.return_ptr+1 " restore indicators in memory " short_return " return to user " " " " entry point special_return. Coded: 12 Dec 1977 by David Levin. " segdef special_return special_return: eppbb sp|stack_frame.next_sp,* " get address of end of fio stack frame inhibit on eppsp sp|stack_frame.prev_sp,* " pop back to user frame spribb sp|stack_frame.next_sp " absorb fortran_io_ stack frame inhibit off lreg sp|8 " load regs stored by pl1_operators_ short_return " return to user end  set_cc.pl1 12/27/84 0853.8rew 12/27/84 0838.8 27684 /* ****************************************************** * * * Copyright, (C) Honeywell Limited, 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ****************************************************** */ /* Coded by A. Downing to turn carriage control off/on for fortran files. */ /* Modified: 14 July 1983, Michael Mabey - add the control args: -defer, -no_defer 22 April 1977, David Levin -change to just act as command interface and not attempt to validate its input */ /* format: style3,^delnl,linecom */ set_cc: proc; dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl com_err_ entry options (variable); dcl error_table_$wrong_no_of_args ext static fixed bin (35); dcl file_num fixed bin; dcl fortran_io_$set_cc entry (fixed bin, bit (1) aligned, fixed bin (35)); dcl fortran_io_$set_cc_defer entry (fixed bin, bit (1) aligned, bit (1) aligned, bit (1) aligned, fixed bin (35)); dcl arg char (n) based (argp); dcl argp ptr; dcl n fixed bin; dcl i fixed bin; dcl number_of_args fixed bin; dcl cc bit (1) aligned init ("1"b); dcl defer bit (1) aligned init ("0"b); dcl defer_specified bit (1) aligned init ("0"b); dcl code fixed bin (35); dcl (verify, substr) builtin; call cu_$arg_count (number_of_args); /* get number of args */ if number_of_args < 2 then do; call com_err_ (error_table_$wrong_no_of_args, "set_cc", "^/Usage: set_cc filenn -control_args"); return; end; call cu_$arg_ptr (1, argp, n, code); /* Get first one, file name. */ if code ^= 0 then do; call com_err_ (code, "set_cc"); return; end; /* validate it */ if substr (arg, 1, 4) ^= "file" | verify (substr (arg, 5, 2), "0123456789") ^= 0 | substr (arg, 7) ^= "" then do; call com_err_ (0, "set_cc", "filenn is filename, where nn is two digit value of file number. ""^a""", arg); return; end; file_num = convert (file_num, substr (arg, 5)); /* convert to binary */ do i = 2 to number_of_args; /* process the remaining arguments */ call cu_$arg_ptr (i, argp, n, code); if code ^= 0 then do; call com_err_ (code, "set_cc"); return; end; if arg = "-on" then cc = "1"b; else if arg = "-off" then cc = "0"b; else if arg = "-defer" then defer, defer_specified = "1"b; else if arg = "-no_defer" then do; defer = "0"b; defer_specified = "1"b; end; else do; call com_err_ (0, "set_cc", "Valid arguments are: -on; -off; -defer; -no_defer. Not ""^a"".", arg); return; end; end /* of while loop */; call fortran_io_$set_cc_defer (file_num, cc, defer, defer_specified, code); if code ^= 0 then call com_err_ (code, "set_cc", "File number ^d", file_num); end /* set_cc */; 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