!Modified 26/ 4/82 10.00
!**********************************************************************!
!**********************************************************************!
! !
! !
! This Module is designed to provide unformatted I/O !
! !
! for FORTRAN77 Programs !
! !
! on ICL PERQ Machines !
! !
! !
!**********************************************************************!
!**********************************************************************!
!-----Module History-----!
! !
! !
! FIO7701Q --------first version (numerous restrictions)
! (derived from FIO7731N)
!
! FIO7731N ---conversion to IMP80
!
! FIO7730N -----includes reps to B70 release
!Conditional Compilation Variables:
!
%CONSTINTEGER EMAS= 0
%CONSTINTEGER PERQ= 1
!
{********************} %CONSTINTEGER SYSTEM=PERQ {********************}
%CONSTHALFINTEGER FALSE= 0
%CONSTHALFINTEGER TRUE = 1
%CONSTHALFINTEGER NONE = 0, NOT SET=NONE
!***********************************************************************
!
! RECORD FORMATS
!
!***********************************************************************
!
%RECORDFORMAT FILE DEFINITION TABLE ( %C
%C
%INTEGER LINK , BACK {LINK},
%INTEGER DSNUM ,
%BYTEINTEGER STATUS , CUR STATE ,
%BYTEINTEGER VALID ACTION , Spare1 ,
%BYTEINTEGER MODE OF USE , ACCESS TYPE ,
%HALFINTEGER EXISTENCE , ACCESS ROUTE ,
%HALFINTEGER RECORD TYPE ,
%HALFINTEGER RECORD LEN , {of the current record}
%HALFINTEGER RECSIZE ,
%HALFINTEGER MINREC ,
%HALFINTEGER MAXREC ,
%INTEGER DA RECNUM ,
%INTEGER LINES IN ,
%INTEGER LINES OUT ,
%HALFINTEGER FILE ID ,
%HALFINTEGER SCRATCH ID ,
%HALFINTEGER LAST BLK , MAX BLK ,
%HALFINTEGER BLK , {the current one}
%HALFINTEGER POS , {and position within it}
%HALFINTEGER REC POS ,
%HALFINTEGER UFD ,
%HALFINTEGER F77BLANK ,
%HALFINTEGER F77RECL ,
%HALFINTEGER FLAGS ,
%INTEGER CUR POS {in bytes from start of file},
%INTEGER CUR LEN {In bytes from start of file},
%INTEGER ID ADDR )
!
! %C
Values That May Be Set in a File Definition Table:
!
!
%CONSTINTEGER F77 DEFINED = X'48'; ! Bit Values
%CONSTINTEGER FORMATTED BIT = X'01'; ! of the
%CONSTINTEGER FREEFMT BIT = X'02'; ! F77UFD field
%CONSTINTEGER FMTED FILE BITS= X'49'; !and byte values
%CONSTINTEGER FREEFMT FILE BITS= X'4B'; ! of the field
%RECORDFORMAT TRANSFER CONTROL TABLE ( %C
%C
%INTEGER DSNUM ,
%INTEGER REC NUMBER ,
%HALFINTEGER COROUTINE INDEX ,
%HALFINTEGER IOSTAT VALUE ,
%INTEGER IOSTAT ADDRESS {used only by user code} )
!
!***********************************************************************
!
! GLOBAL PROCEDURE SPECIFICATIONS
!
!***********************************************************************
!
%HALFINTEGERFNSPEC F77 IOE %C
(%RECORD (Transfer Control Table) %NAME TCT ,
%HALFINTEGER KEY , FORM ,
%HALFINTEGER IO MODE, FLAGS, MARKERS ,
%HALFINTEGERFN IO ITEM %C
(%HALFINTEGER KEY ,
%INTEGER LEN TYPE ADR,
%INTEGERNAME ADDRESS) )
%EXTERNALHALFINTEGERFN F77 IOE ( %C
{! }%C
{! }%C
{! }%C
{! }%C
{! THIS PROCEDURE IS THE INTERFACE BETWEEN AN UNFORMATTED I/O }%C
{! }%C
{! STATEMENT IN THE USER PROGRAM AND THE UNDERLYING }%C
{! }%C
{! SYSTEM-DEPENDENT PROCEDURES OF THE FORTRAN77 }%C
{! }%C
{! RUN-TIME SYSTEM. }%C
{! }%C
{! }%C
{! At Exit: RESULT= 1 if the END= label is to be used }%C
{! RESULT= 2 if the ERR= label is to be used }%C
{! RESULT= 0 otherwise }%C
{! }%C
{!-Parameters: }%C
{! ! }%C
{parm1} %RECORD (Transfer Control Table) %NAME TCT ,
{parm2} %HALFINTEGER KEY ,
{parm3} %HALFINTEGER FORM ,
{parm4} %HALFINTEGER IO MODE ,
{parm5} %HALFINTEGER FLAGS ,
{parm6} %HALFINTEGER SPECIFIER FLAGS ,
%C
{parm7} %HALFINTEGERFN IO ITEM (%HALFINTEGER KEY ,
%INTEGER SIZE TYPE ADR,
%INTEGERNAME ADDRESS ) )
!The Parameters have the following meanings:
!
! %C
DSNUM the FORTRAN channel number,
IO MODE classifies the I/O statement
! X'5x' if Internal File I/O,
X'6x' if Sequential File I/O,
X'7x' if Direct-Access File I/O {where x=1 if input }
{ or x=2 if output}
!also X'04' if Rewind and X'20' if Open,
X'08' if Backspace X'40' if Close,
X'10' if Endfile X'80' if Inquire,
%C
FILE TYPE defines the type of file access
{5 if an Internal File }
{6 if a Sequential File }
{7 if a Direct-Access File}
!%C
IO TYPE defined only for a READ (=1) or WRITE (=2) request,
and is undefined for all other operations
!%C
INOUT set from IO TYPE (above),
set to 0 if input ,
set to 1 if output
!
!***********************************************************************
!
! SPECIFICATIONS FOR EXTERNAL ERROR HANDLING ROUTINES
!
!***********************************************************************
!
%EXTERNALROUTINESPEC SSMESS (%HALFINTEGER FAULT)
%EXTERNALROUTINESPEC F77IOERR (%HALFINTEGER STACK %C
TRACEBACK)
!
!***********************************************************************
!
! SPECIFICATIONS FOR EXTERNAL I/O ROUTINES
!
!***********************************************************************
!
%EXTERNALHALFINTEGERFNSPEC NEW FILE OP (%INTEGER DSNUM ,
%HALFINTEGER ACTION,FILE TYPE,
%INTEGERNAME ADDR OF FD TABLE)
%EXTERNALHALFINTEGERFNSPEC OUT REC
%EXTERNALHALFINTEGERFNSPEC IN REC
%EXTERNALHALFINTEGERFNSPEC IN FIELD (%HALFINTEGER LENGTH, BPTR ,
%INTEGER TO, TO INC)
%EXTERNALHALFINTEGERFNSPEC OUT FIELD (%HALFINTEGER LENGTH,
%INTEGER FROM, FROM INC,
%HALFINTEGER BPTR)
%EXTERNALHALFINTEGERFNSPEC OUT FILL (%HALFINTEGER LENGTH,BPTR,WITH)
%EXTERNALHALFINTEGERFNSPEC POSITION %C
DA FILE (%HALFINTEGER ACTION,
%INTEGER RECORD NUMBER )
!
!***********************************************************************
!
! SPECIFICATIONS FOR MAIN UTILITY ROUTINES
!
!***********************************************************************
!
%HALFINTEGERFNSPEC INITIALISE EXTERNAL IO OPERATION
%HALFINTEGERFNSPEC NEW UNFMT RECORD
%HALFINTEGERFNSPEC SPAN DA IO (%INTEGERNAME TRANSFER LENGTH)
%INTEGERFNSPEC ARRAY ADDRESS ( %INTEGER DV ADDR ,
%HALFINTEGER DATA TYPE )
!***********************************************************************
!
! ERROR MESSAGES
!
!***********************************************************************
!
%CONSTHALFINTEGER INPUT ENDED = 153
%CONSTHALFINTEGER RECORD TOO SMALL = 154
%CONSTHALFINTEGER RECORD OUT OF RANGE = 158
%CONSTHALFINTEGER CONNECTION NOT UNFORMATTED= 193
%CONSTHALFINTEGER ACCESS CONFLICT = 119
!***********************************************************************
!
! GLOBAL VARIABLES
!
!***********************************************************************
!
!
! Variables defining the compilation options specified
!
%HALFINTEGER RELAX ANSI
!
!the operating values of these variables is governed
! by the values within the Transfer Control Table
!
! Variables Controlling Access to the File Definition Table
!
%RECORD (File Definition Table) %NAME F
!
! Buffer Variables
!
%OWNHALFINTEGER BLEN {relative end of buffer +1} ,
BPTR {scanning ptr through the buffer}
%HALFINTEGER BUFF LENGTH; !length of the current record
!
! Declarations of Variables Extracted from the Parameter list
!
%HALFINTEGER IO TYPE
%HALFINTEGER FILE TYPE
%HALFINTEGER INOUT
{see the PARAMETERS above }
{ for the values taken }
{ by these variables }
%INTEGER DSNUM
!
! Variables Controlling Access to or from a File
!
%HALFINTEGER UFD; !copy of F77UFD field of the current I/O channel FD Table
!
!its bits are set as follows:
!
! F77 DEFINED= X'48' => details are F77 defined
! FORMATTED BIT= X'01' => connection/file is formatted
! FREEFMT BIT= X'02' => connection/file has
!list-directed records
!
! Variables associated with Error Reporting
!
%HALFINTEGER ERROR ; !the value to be assigned to the IOSTAT scalar
!
! Variables Defining the Current I/O Item
!
%INTEGER NUM DATA ITEMS; !set to number of elements in an array
!set to 2 for COMPLEX arrays
!set to 1 for other scalars
%INTEGER DATA AD ; !address of I/O item
%INTEGER DATA INC ; !set 0 if I/O item is on a word boundary
!set 1 if I/O item is on a byte boundary
%HALFINTEGER DATA BYTES ; !length of I/O item in bytes
%HALFINTEGER DATA WORDS ; !length of I/O item in words
!HALFINTEGER DATA SIZE ; !code for length if I/O item,
as follows: %C
0 for Character variables,
3 for Byte ,
4 for Word ,
5 for Double Word
%HALFINTEGER DATA TYPE
!DATA TYPE defines the FORTRAN type %C
as follows:
%constinteger AN INTEGER = 1 , A REAL = 2 ,
A COMPLEX = 3 , A LOGICAL= 4 ,
A CHARACTER= 5
!***********************************************************************
!
! UNFORMATTED I/O SPECIFIC VARIABLES
!
!***********************************************************************
!
%HALFINTEGER FAULT; !reported by SPAN DA IO or NEW UNFMT RECORD
%INTEGER I ; !the number of bytes of an I/O item on which to do I/O
!
! I/O List related variables
!
%HALFINTEGER NOS PER ITEM; !set to 2 for Complex I/O items, else set to 1
%INTEGER ITEM AD ; !address of the next I/O item
%HALFINTEGER ITEM TYPE ;!%C
ITEM TYPE is the result from %C
the coroutine as follows: -1 if end of I/O list
! 0 if a scalar
! 1 if an array
! 2 if a Character scalar
!
! Analyse The Parameters
!
RELAX ANSI = FLAGS & 8
!
FILE TYPE = IO MODE >> 4
IO TYPE = IO MODE & 15
INOUT = IO TYPE - 1
!
DSNUM = TCT_DSNUM
!
! Prepare for Another File Operation
!
FAULT=INITIALISE EXTERNAL IO OPERATION
-> IO ERROR %IF FAULT\=NONE
!
! Extract the FORM Property of the Connection
!
UFD= F_UFD
%IF UFD= NOT SET %THENSTART
!
! Set the FORM Property of the File
!
UFD= X'48'
F_UFD= UFD
%FINISH
!And now Validate the FORM Property:
!
%IF (UFD&FMTEDFILE BITS)\=X'48' %THENSTART
!
! Report a FORM Conflict
!
FAULT=CONNECTION NOT UNFORMATTED
-> IO ERROR
%FINISH
%IF (FILE TYPE-6)\=F_ACCESS TYPE %THEN FAULT=ACCESS CONFLICT %C
%AND -> IO ERROR
%IF FILE TYPE=7 %THENSTART
!
! Perform Direct-Access Initialisation
!
%UNLESS 0<TCT_REC NUMBER<=32767 %THEN FAULT= RECORD OUT OF RANGE %C
%AND -> IO ERROR
!
FAULT= POSITION DA FILE (IO TYPE,TCT_REC NUMBER)
%UNLESS FAULT= NONE %THEN -> IO ERROR
%FINISH
%IF INOUT=0 %THENSTART
!
!
! READ THE FIRST RECORD
!
!
FAULT = INREC
%IF FAULT\= NONE %THEN -> IO ERROR
!
!---AND NOW INITIALISE FOR PROCESSING INPUT
!
BUFF LENGTH= F_RECSIZE
%FINISHELSESTART
!
!
! PREPARE FOR PROCESSING OUTPUT
!
!
%IF FILE TYPE=7 %THEN BUFF LENGTH= F_RECSIZE %C
%ELSE BUFF LENGTH= F_MAXREC
%FINISH; !preparing output
!
! INITIALISE THE BUFFER POINTERS
!
BPTR = 0 ; !-> relative start of buffer
BLEN = BUFF LENGTH; !-> relative end of buffer
!***********************************************************************
!
! PERFORM UNFORMATTED INPUT OR OUTPUT
!
!***********************************************************************
! %C
IO FORM (UNFORMATTED IO):
!
!
%IF TCT_COROUTINE INDEX\=NOT SET %THENSTART
!
! GET THE NEXT I/O ITEM
!
%CYCLE; ITEM TYPE= IO ITEM (KEY,ADDR(DATA WORDS),ITEM AD)
%EXIT %IF ITEM TYPE< 0
DATA INC = NOT SET
DATA TYPE=DATA TYPE & 15
%IF DATA TYPE=A COMPLEX %THEN DATA WORDS= DATA WORDS >> 1 %C
%AND NOS PER ITEM = 2 %C
%ELSE NOS PER ITEM = 1
%IF ITEM TYPE=0 %THENSTART
!
! I/O Item is a Non-Character Scalar
!
DATA BYTES=DATA WORDS + DATA WORDS
DATA AD =ITEM AD
NUM DATA ITEMS= NOS PER ITEM; %FINISHELSESTART
%IF ITEM TYPE=1 %THENSTART
!
! I/O Item is an Array
!
DATA AD = ARRAY ADDRESS(ITEM AD,DATA TYPE)
NUM DATA ITEMS= NUM DATA ITEMS * NOS PER ITEM
%FINISHELSESTART
{%IF ITEM TYPE=2 %THENSTART}
!
! I/O Item is a Character Scalar
!
NUM DATA ITEMS= 1
DATA AD = INTEGER(ITEM AD )
DATA INC = HALFINTEGER(ITEM AD+2)
DATA BYTES= DATA WORDS
%FINISH
%FINISH
!
! DETERMINE IF THE BUFFER IS LARGE ENOUGH
!
I= NUM DATA ITEMS * DATA BYTES
%IF I+ BPTR>BLEN %THENSTART
%IF FILETYPE= 6 %THEN FAULT= RECORD TOO SMALL %C
%ELSE FAULT= SPAN DA IO (I)
%IF FAULT\=NONE %THEN -> IO ERROR
%FINISH
!
! TRANSFER DATA BETWEEN BUFFER AND I/O ITEM
!
%IF INOUT=0 %THEN FAULT= IN FIELD (I,BPTR ,DATA AD ,DATA INC) %C
%ELSE FAULT=OUT FIELD (I,DATA AD,DATA INC, BPTR)
%UNLESS FAULT=0 %THEN -> IO ERROR
!
BPTR=BPTR+I; !Update the BUffer Pointer
%REPEAT
%FINISH
!
! TIDY UP THE I/O OPERATION
!
%IF INOUT= 1 %THENSTART
FAULT = NEW UNFMT RECORD
-> IO ERROR %UNLESS FAULT=NONE
%FINISH
!***********************************************************************
!
! RETURN (after successful completion)
!
!***********************************************************************
!
!Set the IOSTAT field in the Transfer Control Table
!
TCT_IOSTAT VALUE= 0
!
%RESULT= 0
!***********************************************************************
!
! REPORT AN ERROR
!
!***********************************************************************
!
IO ERROR:
%IF SPECIFIER FLAGS\=NONE %THENSTART
!
!
! Examine the I/O error specifiers given
!
!
ERROR= FAULT
ERROR=-1 %IF ERROR=INPUT ENDED {check for FAULT 153}
!
TCT_IOSTAT VALUE= ERROR {first set the IOSTAT value}
!
! Check Label Exits
!
%RESULT=1 %IF FAULT=INPUT ENDED %AND SPECIFIER FLAGS&1\= 0
%RESULT=2 %IF SPECIFIER FLAGS&2\= 0
!
%RESULT=0 %IF SPECIFIER FLAGS>= 4
!
!Continue with ordinary error reporting
!if no label exit was taken and
%FINISH; !if no IOSTAT specifier was given
%IF FAULT>0 %THENSTART
!
!
! Report a fault detected by FIO
!
!
{SELECT OUTPUT (107)}
SSMESS (FAULT) {print the error message }
%FINISH
{give a %MONITOR and %STOP} F77IOERR ( 1 {stack frame to unwind})
!***********************************************************************
!
! I/O PERFORMING PROCEDURES
!
!***********************************************************************
!
%HALFINTEGERFN INITIALISE EXTERNAL IO OPERATION
!
!
!
!
! A PROCEDURE TO ESTABLISH A CONNECTION BETWEEN
!
! THE UNIT SPECIFIER AND THE CORRESPONDING
!
! EXTERNAL FILE.
!
!
!
%HALFINTEGER FAULT; !reported from NEW FILE OP
%INTEGER AFD
!
!
! Initialise for External File Input/Output
!
!
FAULT = NEW FILE OP (DSNUM,IO TYPE,(7-FILE TYPE)<<1,AFD)
%IF FAULT\=NONE %THENRESULT=FAULT
!
F==RECORD(AFD); !map address of file definition table
! onto the corresponding record fmt
%RESULT= 0
%END; !of INITIALISE EXTERNAL IO OPERATION
%HALFINTEGERFN NEW UNFMT RECORD
!
!
!
!
! A UTILITY PROCEDURE TO READ OR WRITE THE
!
! NEXT UNFORMATTED RECORD.
!
!
!
%HALFINTEGER BUFF LENGTH; !length of the current record or buffer
%HALFINTEGER FAULT ; !fault reported by INREC or OUTREC
%HALFINTEGER I ; !----a work variable
%IF INOUT=0 %THENSTART
!
!
! Read the next record
!
!
FAULT= INREC
BLEN= F_RECSIZE; %FINISHELSESTART
!
!
! Write the next record
!
!
BUFF LENGTH= BPTR
I=F_MINREC - BUFF LENGTH
%IF I> 0 %THENSTART
!
! Expand the Record to the Required Size
!
FAULT= OUT FILL ( I,BUFF LENGTH, 0 {zeros})
%IF FAULT>None %THENRESULT= FAULT
!
BUFF LENGTH=F_MINREC
%FINISH
!OUTPUT THE RECORD:
!
FAULT= OUTREC
%IF FILETYPE=7 %THEN BLEN= F_RECSIZE %C
%ELSE BLEN= F_MAXREC; !determine length of
%FINISH; !the next record
!
! RE-SET THE BUFFER POINTER
!
BPTR= 0
!
%RESULT= FAULT
%END; !of NEW UNFMT RECORD
%HALFINTEGERFN SPAN DA IO (%INTEGERNAME TRANSFER LENGTH)
!
!
!
! A LOCAL ROUTINE TO SPAN I/O FOR DIRECT ACCESS, AND
!
! TO UPDATE CERTAIN ASSOCIATED VARIABLES. TRANSFER
!
! OF THE LAST RECORD IS LEFT TO THE OUTER LEVEL.
!
!
%HALFINTEGER BUFF LENGTH ; !actual record length
%HALFINTEGER IO LENGTH ; !number of bytes to transfer to/from
! the current record
%HALFINTEGER BYTES PER BUFF ; !maximum number of bytes that may be moved
! to or from the buffer in this actual
! spanning operation
%HALFINTEGER FAULT
FAULT= RECORD TOO SMALL %IF RELAX ANSI=FALSE
!
! CHECK THE SIZE OF THE RECORD
!
BUFF LENGTH= BLEN
%IF BUFF LENGTH< DATA BYTES %THENRESULT= RECORD TOO SMALL
!RESULT=> RECORD TOO SMALL TO CONTAIN A
! SINGLE I/O ITEM
!
! FILL THE REST OF THE CURRENT BUFFER
!
IO LENGTH = (BLEN - BPTR)//DATA BYTES * DATA BYTES
BYTES PER BUFF = BUFF LENGTH //DATA BYTES * DATA BYTES
PERFORM TRANSFER:
!
%IF INOUT=0 %THENSTART
!
! Receive Input
!
FAULT= IN FIELD (IO LENGTH,BPTR,DATA AD,DATA INC)
!
%FINISHELSESTART
!
! Send Output
!
FAULT=OUT FIELD(IO LENGTH,DATA AD,DATA INC,BPTR)
BPTR= IO LENGTH+BPTR
%FINISH
!
! READ/WRITE THE NEXT RECORD
!
FAULT = NEW UNFMT RECORD
%IF FAULT\=0 %THENRESULT= FAULT
!
! UPDATE VARIABLES
!
DATA INC = DATA INC + IO LENGTH; !Update item address
TRANSFER LENGTH= TRANSFER LENGTH - IO LENGTH; !Update bytes left to
! be written
!
! TEST FOR END OF SPANNING OPERATION
!
%IF TRANSFER LENGTH>BYTES PER BUFF %THEN IO LENGTH= BYTES PER BUFF %C
%AND -> PERFORM TRANSFER
%RESULT= 0
%END; !of SPAN DA IO
%INTEGERFN ARRAY ADDRESS (%INTEGER DATA AD , %HALFINTEGER DATA TYPE)
!
!
!
!
! THIS PROCEDURE DETERMINES THE ADDRESS OF THE FIRST ACTUAL
!
! ARRAY ELEMENT AND THE NUMBER OF ARRAY ELEMENTS
!
! USING THE DOPE VECTOR ADDRESS (Data Ad) AND THE
!
! VARIABLE TYPE (Data Type).
!
!
!The Form of a Dope Vector is as follows:
! %C
Integer: Address of 1st actual element (word boundary) %C
Halfinteger: Increment to start of 1st actual element ---AND %C
Halfinteger: Element size if type= CHARACTER Array %C
Integer: Number of Array elements
!
!
%INTEGER RESULT {returned is address of 1st element}
RESULT= INTEGER(DATA AD)
!
!
%IF DATA TYPE=A CHARACTER %THENSTART
!
! Extract CHARACTER Dependent Information
!
DATA INC = HALFINTEGER(DATA AD + 2)
DATA BYTES= HALFINTEGER(DATA AD + 3)
DATA WORDS= DATA BYTES
DATA AD = DATA AD + 4
%FINISHELSE %C
DATA BYTES= DATA WORDS + DATA WORDS
NUM DATA ITEMS= INTEGER(DATA AD + 2)
%RESULT= RESULT
!
%END; !of ARRAY ADDRESS
%END; !of F77 IOE
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
%ENDOFFILE