!Modified 26/ 3/82 13.30 !**********************************************************************! !**********************************************************************! ! ! ! ! ! This Module is designed to provide I/0 support ! ! ! ! for FORTRAN77 Programs ! ! ! ! on ICL PERQ Machines ! ! ! ! ! !**********************************************************************! !**********************************************************************! ! ! compile either PARM(STACK,NOCHECK) ! or PARM(STACK,OPT) !-----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 ! !*********************************************************************** ! ! ENVIRONMENTAL VARIABLES ! !*********************************************************************** ! ! !Initialisation Criterion on EMAS is determined via: ! !E2900 %SYSTEMINTEGERMAPSPEC FIO2 FLAG ! %C which returns a reference to a word in the %C Subsystem which is set to zero before %C executing any command. ! ! %IF SYSTEM\=EMAS %THENSTART ! !Initialisation Criterion on PERQ is determined via: ! %OWNHALFINTEGER FIO2 FLAG= FALSE {= TRUE if FIO2 is initialised} %FINISH; !if PERQ ! ! %OWNINTEGER CURRENT FD = 0; !%C CURRENT FD is set to the address of the current %C File Definition Table for which the%C procedures INREC and OUTREC have %C been initialised for %CONSTINTEGER OUTPUT LEN= 84; !The record length of the diagnostic ! stream. Should the characteristics ! of the stream change then only this ! variable need be altered. %OWNBYTEINTEGERARRAY MONITOR BUFFER (0:OUTPUT LEN) ;!%C MONITOR BUFFER is used %C to hold a snapshot of the current %C I/O buffer when reporting an error !*********************************************************************** ! ! RECORD FORMATS ! !*********************************************************************** ! %RECORDFORMAT FILE DEFINITION TABLE ( %C %C %INTEGER LINK , %INTEGER DSNUM , %BYTEINTEGER STATUS , ACCESS ROUTE , %BYTEINTEGER VALID ACTION , CUR STATE , %BYTEINTEGER MODE OF USE , ACCESS TYPE , %HALFINTEGER FLAGS , %INTEGER AREC , %INTEGER RECSIZE , %INTEGER MINREC , %INTEGER MAXREC , %INTEGER MAXSIZE , %INTEGER DA RECNUM , %INTEGER TRANSFERS , %BYTEINTEGER EXISTENCE , UFD , %BYTEINTEGER F77BLANK , F77FORM , %INTEGER F77RECL , %STRING(15) ID ) ! ! %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 ! ! %CONSTINTEGER NEW DETAILS= X'10'; !bit set in FLAGS ! if UFD contains ! new information %RECORDFORMAT FORM OF FORMAT TABLE ENTRY ( %C (%INTEGER TABLE ENTRY %C %OR %BYTEINTEGER FMT TYPE , unused byte , %HALFINTEGER VALUE ) %C %C %OR %HALFINTEGER VALUE1, VALUE2 ) %RECORDFORMAT FORM OF FORMAT TABLE ( %C %C (%INTEGER TABLE ENTRY %C %OR %BYTEINTEGER FMT TYPE , unused byte , %HALFINTEGER VALUE) %C %C %OR %HALFINTEGER VALUE1 , VALUE2 , %C %RECORD (Form of Format Table Entry) NEXT ENTRY ) %RECORDFORMAT FORM OF AN INTERNAL FILE DESC{ription} ( %C %C %INTEGER ADDRESS {of first word} , %HALFINTEGER INC{rement to 1st char from ADDRESS}, %HALFINTEGER LENGTH {of each element} , %INTEGER COUNT {of number of elements} ) %RECORDFORMAT FORM OF A PARAMETER PAIR ( %C %C %HALFINTEGER ID{entifier} , %INTEGER ADDRESS , %HALFINTEGER INC{rement from ADDRESS} , %HALFINTEGER LENGTH ) %RECORDFORMAT FORM OF A PARAMETER PAIR LIST ( %C %C %HALFINTEGER ID{entifier} , %INTEGER ADDRESS , %HALFINTEGER INC{rement from ADDRESS} , %HALFINTEGER LENGTH , %C %RECORD (Form of a Parameter Pair) NEXT PP PAIR) %RECORDFORMAT FORM OF RUN TIME FORMAT ENTRY ( %C %C %INTEGER LINK {to next entry} , %INTEGER TXT ADR {of format array} , %C %BYTEINTEGERARRAY TXT AND TABLE (0:30000 {ie undefined})); !%C of the format %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} , %INTEGER FORMAT ADDRESS , %HALFINTEGER FORMAT INC{rement} , %HALFINTEGER FORMAT LENGTH , %RECORD (Form of an Internal File Desc{ription}) %C INTERNAL FILE DESC , %RECORD (Form of a Parameter Pair) %ARRAY PPs(0:17) ) ! !*********************************************************************** ! ! GLOBAL PROCEDURE SPECIFICATIONS ! !*********************************************************************** ! %HALFINTEGERFNSPEC F77 IO %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) ) %HALFINTEGERFNSPEC INREC %HALFINTEGERFNSPEC OUTREC (%INTEGER LENGTH) %HALFINTEGERFNSPEC NEW FILE OP (%INTEGER DSNUM , %HALFINTEGER ACTION, FILETYPE, %INTEGERNAME FILE DEFINITION ADDR) %EXTERNALHALFINTEGERFN F77 IO ( %C {! }%C {! }%C {! }%C {! }%C {! THIS PROCEDURE IS THE INTERFACE BETWEEN AN INPUT/OUTPUT }%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 FORM classifies the processing required, as follows: %CONSTINTEGERC UNFORMATTED IO = 0 , FORMAT IO = 1 , FORMAT IN ARRAY= 2 , LIST DIRECTED IO= 3 , REWIND = 7 , BACKSPACE = 7 , ENDFILE = 7 , OPEN CLOSE AND INQUIRE= 8 !%C IO TYPE defined only for a READ (=2) or WRITE (=3) 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 , %C FORMATTED IO a boolean variable which is set from %C the least significant bit of IO INFO %C =FALSE if formatted I/O is not required, =TRUE if otherwise ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL ERROR HANDLING ROUTINES ! !*********************************************************************** ! %EXTERNALROUTINESPEC SSMESS (%HALFINTEGER FAULT) %EXTERNALROUTINESPEC F77IOERR (%HALFINTEGER STACK %C TRACEBACK) ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL I/O ROUTINES ! !*********************************************************************** ! !SYSTEMINTEGERFNSPEC F77OPEN (%INTEGER DSNUM , STATUS , %INTEGER ACCESS , FORM , %INTEGER BLANKS , RECL ,NREC, %STRINGNAME FILENAME, FILETYPE ) !SYSTEMINTEGERFNSPEC F77CLOSE (%INTEGER DSNUM , STATUS ) !SYSTEMINTEGERFNSPEC F77INQUIRE (%INTEGER DSNUM , %STRINGNAME FILENAME, %INTEGERNAME ADDRESS OF VALUES ) ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL UTILITY ROUTINES ! !*********************************************************************** ! %EXTERNALINTEGERFNSPEC FORMATCD %C (%INTEGER TEXT ADDR , %INTEGER TEXT DISP , TAB ADDR , %INTEGER TEXT LEN , TAB LEN , %INTEGER ANSI FLAG , RT FLAG , %INTEGERNAME ACTUAL TABLE LEN , %INTEGERNAME ACTUAL TEXT LEN ) ! !SYSTEMINTEGERMAPSPEC COMREG (%INTEGER N ) !SYSTEMROUTINESPEC F77AUX (%INTEGER EP , P1 , P2 ) !SYSTEMROUTINESPEC OUTFILE %C (%STRING(15) AREA NAME , %INTEGER LENGTH ,MAX LENGTH,USE , %INTEGERNAME AREA ADDRESS, FLAG ) ! !*********************************************************************** ! ! SPECIFICATIONS FOR MAIN UTILITY ROUTINES ! !*********************************************************************** ! %HALFINTEGERFNSPEC UNFMT IO %INTEGERFNSPEC FMT IO %HALFINTEGERFNSPEC FREE FMT IO %HALFINTEGERFNSPEC OPEN (%INTEGER PPLIST ADDRESS) %HALFINTEGERFNSPEC CLOSE (%INTEGER PPLIST ADDRESS) %HALFINTEGERFNSPEC INQUIRE (%INTEGER PPLIST ADDRESS) %ROUTINESPEC GET EXTRA ERROR INFO %HALFINTEGERFNSPEC INITIALISE EXTERNAL IO OPERATION %HALFINTEGERFNSPEC INITIALISE INTERNAL IO OPERATION %HALFINTEGERFNSPEC NEW UNFMT RECORD %HALFINTEGERFNSPEC NEW RECORD %HALFINTEGERFNSPEC IN FORMAT %HALFINTEGERFNSPEC OUT FORMAT %HALFINTEGERFNSPEC OUT ITEM %INTEGERFNSPEC ARRAY ADDRESS ( %INTEGER DV ADDR , %HALFINTEGER DATA TYPE ) %HALFINTEGERFNSPEC TO INTEGER (%INTEGER DATA AD , DATA LEN , %INTEGER TEXT ADDRESS , %INTEGER INT LEN , INT PTR , MODE ) %HALFINTEGERFNSPEC TO REAL (%INTEGER DATA AD , DATA LEN , %INTEGER TEXT ADDRESS , %INTEGER INT LEN , INT PTR , %INTEGER DEC LEN , DEC PTR , %INTEGER EXP LEN , EXP PTR , DECS , %INTEGER SCALE FACTOR , MODE ) %HALFINTEGERFNSPEC UNASSIGNED CHECK (%INTEGER ADR, %HALFINTEGER LEN) %HALFINTEGERFNSPEC BYTE AT (%INTEGER ADR, %HALFINTEGER INC) %ROUTINESPEC FILL BUFF (%INTEGER LENGTH, %HALFINTEGER AT INC, WITH) %ROUTINESPEC PROPAGATE (%INTEGER LENGTH, %INTEGER BASE, %HALFINTEGER AT INC, WITH) %ROUTINESPEC COPY (%INTEGER LENGTH, %INTEGER FROM, %HALFINTEGER FROM DISP , %INTEGER TO , %HALFINTEGER TO DISP ) %INTEGERFNSPEC COMPARE (%INTEGER LENGTH, %INTEGER THIS BASE, %HALFINTEGER THIS INC , %INTEGER THAT BASE, %HALFINTEGER THAT INC ) !*********************************************************************** ! ! ERROR MESSAGES ! !*********************************************************************** ! %CONSTHALFINTEGER UNASSIGNED VARIABLE = 401 %CONSTHALFINTEGER LITERAL IN INPUT FMT = 111 %CONSTHALFINTEGER INVALID INTEGER = 140 %CONSTHALFINTEGER INVALID REAL = 141 %CONSTHALFINTEGER INVALID COMPLEX = 143 %CONSTHALFINTEGER INVALID CHARACTER = 148 %CONSTHALFINTEGER LITERAL NOT TERMINATED = 150 %CONSTHALFINTEGER UNIT NOT DEFINED = 151 %CONSTHALFINTEGER FILE DOES NOT EXIST = 152 %CONSTHALFINTEGER INPUT ENDED = 153 %CONSTHALFINTEGER RECORD TOO SMALL = 154 %CONSTHALFINTEGER INCOMPATIBLE FORMAT = 155 %CONSTHALFINTEGER RECORD OUT OF RANGE = 158 %CONSTHALFINTEGER NO FMT FOR IO ITEM = 159 %CONSTHALFINTEGER INVALID UNIT NUMBER = 164 %CONSTHALFINTEGER FILE FULL = 169 %CONSTHALFINTEGER FMT TOO LARGE = 184 %CONSTHALFINTEGER INVALID LOGICAL = 135 %CONSTHALFINTEGER INVALID CONSTANT = 137 %CONSTHALFINTEGER INVALID CHARACTER CONSTANT= 136 %CONSTHALFINTEGER INVALID REPETITION = 138 %CONSTHALFINTEGER ILLEGAL REPETITION = 139 %CONSTHALFINTEGER VALUE SEPARATOR MISSING = 132 %CONSTHALFINTEGER NULL FIELD = 133 %CONSTHALFINTEGER INVALID SCALING = 134 %CONSTHALFINTEGER INVALID FILENAME = 128 %CONSTHALFINTEGER NO FILENAME GIVEN = 129 %CONSTHALFINTEGER ILLEGAL SPECIFIER VALUE = 127 %CONSTHALFINTEGER RECORD LENGTH MISSING = 130 %CONSTHALFINTEGER SPECIFIER NOT RECOGNISED = 125 %CONSTHALFINTEGER SPECIFIERS INCONSISTENT = 126 %CONSTHALFINTEGER CONNECTION NOT UNFORMATTED= 193 %CONSTHALFINTEGER CONNECTION NOT FORMATTED = 194 %CONSTHALFINTEGER BACKSPACE NOT ALLOWED = 195 %CONSTHALFINTEGER ACCESS CONFLICT = 119 !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! %CONSTHALFINTEGER DOT = '.' %CONSTHALFINTEGER STAR = '*' %CONSTHALFINTEGER PLUS = '+' %CONSTHALFINTEGER TRUE SIGN = 'T' %CONSTHALFINTEGER FALSE SIGN = 'F' %CONSTHALFINTEGER BLANK = ' ' %CONSTHALFINTEGER QUOTE = '''' %CONSTHALFINTEGER MINUS = '-' %CONSTHALFINTEGER NOUGHT= '0' !* !* !* %CONSTHALFINTEGER NULL = 0 %CONSTHALFINTEGER NONE = 0 %CONSTHALFINTEGER NOT SET = 0, SET = 1 %CONSTHALFINTEGER NOT USED= 0 %CONSTHALFINTEGER NOT REQD= 0, REQD= 1 %CONSTHALFINTEGER NIL = 0 %CONSTHALFINTEGER OFF = 0, ON = 1 %CONSTINTEGER UNDEFINED =-9 !Values taken by 'boolean' variables ! (ie. Integers used as flags) %IF SYSTEM\=PERQ %THENSTART ! %CONSTREALARRAY POWERS OF TEN (-37:38) %C = R'2222073B' , R'23154485' , R'23D4AD2E' , R'2484EC3D' , R'255313A6' , R'2633EC48' , R'272073AD' , R'2814484C' , R'28CAD2F8' , R'297EC3DB' , R'2A4F3A69' , R'2B318482' , R'2C1EF2D1' , R'2D1357C3' , R'2DC16D9A' , R'2E78E480' , R'2F4B8ED0' , R'302F3942' , R'311D83C9' , R'3212725E' , R'32B877AA' , R'33734ACA' , R'34480EBE' , R'352D0937' , R'361C25C2' , R'3711979A' , R'37AFEBFF' , R'386DF37F' , R'3944B830' , R'3A2AF31E' , R'3B1AD7F3' , R'3C10C6F8' , R'3CA7C5AC' , R'3D68DB8C' , R'3E418937' , R'3F28F5C2' , R'4019999A' , R'41100000' , R'41A00000' , R'42640000' , R'433E8000' , R'44271000' , R'45186A00' , R'45F42400' , R'46989680' , R'475F5E10' , R'483B9ACA' , R'492540BE' , R'4A174876' , R'4AE8D4A5' , R'4B9184E7' , R'4C5AF310' , R'4D38D7EA' , R'4E2386F2' , R'4F163458' , R'4FDE0B6B' , R'508AC723' , R'5156BC76' , R'523635CA' , R'5321E19E' , R'54152D02' , R'54D3C21C' , R'55845951' , R'5652B7D3' , R'5733B2E4' , R'58204FCE' , R'591431E0' , R'59C9F2CA' , R'5A7E37BE' , R'5B4EE2D7' , R'5C314DC6' , R'5D1ED09C' , R'5E134261' , R'5EC097CE' , R'5F785EE1' , R'604B3B4D' ! ! Other Floating Point Constants ! %CONSTREAL LARGEST REAL = R'7FFFFFFF' ! %CONSTREAL POINT ONE = R'4019999A' %CONSTREAL TEN TO THE 11= R'4A174877' %CONSTREAL TEN TO THE 12= R'4AE8D4A5' %CONSTREAL TEN TO THE 38= R'604B3B4D' %CONSTREAL TEN TO THE %C MINUS 36= R'23154485' %FINISH; !if not PERQ %IF SYSTEM=PERQ %THENSTART ! ! %CONSTREALARRAY POWERS OF TEN (-37:38) %C = R'02081CEA' , R'03AA2425' , R'0554AD2E' , R'0704EC3D' , R'08A6274C' , R'0A4FB11F' , R'0C01CEB3' , R'0DA24260' , R'0F4AD2F8' , {This Table } R'10FD87B6' , R'129E74D2' , R'14461206' , { is } R'15F79688' , R'179ABE15' , R'19416D9A' , { an } R'1AF1C901' , R'1C971DA0' , R'1E3CE508' , { accurate } R'1FEC1E4A' , R'219392EF' , R'233877AA' , { representation} R'24E69595' , R'26901D7D' , R'283424DC' , { of } R'29E12E13' , R'2B8CBCCC' , R'2D2FEBFF' , { the } R'2EDBE6FF' , R'3089705F' , R'322BCC77' , { powers of ten } R'33D6BF95' , R'358637BD' , R'3727C5AC' , { in } R'38D1B717' , R'3A83126F' , R'3C23D70A' , { the } R'3DCCCCCD' , R'3F800000' , R'41200000' , { range } R'42C80000' , R'447A0000' , R'461C4000' , { 10**(-37) } R'47C35000' , R'49742400' , R'4B189680' , { to 10** 38 } R'4CBEBC20' , R'4E6E6B28' , R'501502F9' , { expressed } R'51BA43B7' , R'5368D4A5' , R'551184E7' , { in the } R'56B5E621' , R'58635FA9' , R'5A0E1BCA' , { form of } R'5BB1A2BC' , R'5D5E0B6B' , R'5F0AC723' , { floating } R'60AD78EC' , R'6258D727' , R'64078678' , { point } R'65A96816' , R'6753C21C' , R'69045951' , { numbers } R'6AA56FA6' , R'6C4ECB8F' , R'6E013F39' , { which conform } R'6FA18F08' , R'7149F2CA' , R'72FC6F7C' , { to the } R'749DC5AE' , R'76453719' , R'77F684DF' , { IEEE draft } R'799A130C' , R'7B4097CE' , R'7CF0BDC2' , { standard } R'7E967699' ! ! Other Floating Point Constants ! %CONSTREAL LARGEST REAL = R'3F7FFFFF' %CONSTREAL POINT ONE = R'3DCCCCCD' %CONSTREAL TEN TO THE 38= R'7E967699' %CONSTREAL TEN TO THE %C MINUS 36= R'03AA2425' ! ! %FINISH; !if PERQ !*********************************************************************** ! ! INTERNAL WORK-AREAS ! !*********************************************************************** ! {---TEMPORARILY----->} %OWNBYTEINTEGERARRAY WORK AREA (0:1023) ! %OWNINTEGER WORKAREA ADDR %OWNBYTEINTEGERARRAYNAME OUTPUT AREA ; !The %OWNBYTEINTEGERARRAYNAME COPY AREA ; ! Internal !E2900 %OWNBYTEINTEGERARRAYNAME BLANK BUFFER; ! Work Areas ! ! !The workareas are mapped onto an area which is created %C as part of FIO2's internal initialisation. !The array formats used are: ! %BYTEINTEGERARRAYFORMAT FORM A (0:1023) ; !for COPY AREA %BYTEINTEGERARRAYFORMAT FORM B (0:1023) ; !for OUTPUT AREA !E2900 %BYTEINTEGERARRAYFORMAT FORM C (0: 79) ; !for BLANK BUFFER ! !%C OUTPUT AREA is used by OUT FORMAT for generating the required digits %C COPY AREA is used by IN FORMAT to remove any embedded blanks within%C a numeric field %C and is used by IN ITEM to evaluate literals and also repeated%C complex values which cross record boundaries %C BLANK BUFFER is used to copy a formatted record read from an external %C file when the record length is less than 80 and %C the user is trying to read the trailing spaces. %C It is used for 2900 EMAS only. !In Addition: ! ! Access to the current ! I/O buffer is as follows: ! ! %OWNBYTEINTEGERARRAYNAME IO BUFFER {using the format %BYTEINTEGERARRAYFORMAT FORM A (0:32767)} !*********************************************************************** ! ! GLOBAL VARIABLES ! !*********************************************************************** ! %OWNHALFINTEGER RUN MODE; ! =-1 => Running in JOBBER mode ! = 0 => Running in STAND-ALONE mode but ! using Subsystem Diagnostics ! = 1 => Running in OPEH mode {Set At Initialisation} %OWNINTEGER FIO MODE=0 ! !Controls the handling of the condition whereby a numeric ! value that is read in is outside the permitted range. !It may take one of the values below: ! %CONSTHALFINTEGER NORMAL MODE=0 !CONSTHALFINTEGER DEBUG MODE=2 %CONSTHALFINTEGER FIO PLUS MODE=3 !currently non-zero values ! imply that values out of range are to be faulted ! ! Variables defining the compilation options specified ! %HALFINTEGER CHECK %HALFINTEGER RELAX ANSI ! !the operating values of these variables is governed ! by the values within the Transfer Control Table ! {also} %HALFINTEGER CASE; !set LOWER if lower case input acceptable !set UPPER if only upper case is accepted %CONSTHALFINTEGER UPPER = 0 ;!%C LOWER\= 0 ! ! Global Variables for Run-Time Format Optimisation ! %OWNRECORD (Form of Run Time Format Entry) %C %NAME RT {ptr to latest format saved or used} %OWNINTEGER START OF RT FMTS {adr of area for saving formats} ! ! Variables Controlling Access to the File Definition Table ! %OWNRECORD (File Definition Table) %NAME F %INTEGER AFD ;!%C address of the File DEfinition Table for BACKSPACE,REWIND,etc ! ! Buffer Variables ! %OWNINTEGER BLEN {relative (from BSTART+BINC) end of buffer +1} , BSTART { address of the buffer } , BPTR {scanning ptr through the buffer} , MAX BPTR { maximum value of BPTR achieved} ! while writing to an output buffer ! %INTEGER BUFF LENGTH; !length of the current record %OWNINTEGER BINC= 0 ;!%C BINC is primarily used for Internal File I/O and %C is used to indicate the displacement from %C the start of the file to the start of the %C current I/O buffer !for external files BINC is set to zero always ! ! Internal File Variables ! %OWNINTEGER CHAR IO BUFF LEN; !Length of the current character I/O buffer %OWNINTEGER CHAR IO BUFF CNT; !Number of buffers (records/array elements) ! that are still unused by the ! current internal file I/O operation ! ! Auxilary I/O Statement Variables ! %OWNSTRING(1) UNASSIGNED SPECIFIER= ""; ! !Local representation of a Character specifier ! which is unassigned %INTEGER PPLIST ADDRESS ;!%C Address of the Parameter-Pairs List %C (if zero then there is none) ! ! Declarations of Variables Extracted from the Parameter list ! %HALFINTEGER IO TYPE %HALFINTEGER FILE TYPE %HALFINTEGER INOUT %HALFINTEGER FORMATTED IO {see the PARAMETERS above } { for the values taken } { by these variables } %INTEGER DSNUM ! ! Variables Controlling Access to or from a File ! %OWNHALFINTEGER %C BLANKS ATTRIBUTE= TRUE; ! %C An attribute associated with the current %C channel and determines the significance %C of blanks within a numeric input field %C FALSE=> they are to be ignored %C TRUE => they are significant %OWNINTEGER 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 %INTEGER SFD; !copy of the 1st byte of the UFD field ! (---the System File Details) ! !recognised values are: ! ! Ebcdic 'F' => formatted records only in file ! Ebcdic 'U' => unformatted records only in file ! Ebcdic 'L' => list-directed records in file ! Ebcdic ' ' => record type not defined ! Hex 00 => record type not defined ! mask Hex 48 => unformatted records only in file ! mask Hex 49 => formatted records only in file ! mask Hex 4B => list-directed records in file %OWNINTEGER FORM MASK; !copy of FORMATTED IO with F77 DEFINED or'ed in ! !the I/O request is validated by ! comparing FORM MASK with UFD above ! ! Variables associated with Error Reporting ! %HALFINTEGER ERROR ; !the value to be assigned to the IOSTAT scalar %HALFINTEGER FAULT ; !the error that has been detected ! ! 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 ! ! Variables Defining the Current Format ! %INTEGER WIDTH %HALFINTEGER EXP WIDTH %HALFINTEGER INT WIDTH %HALFINTEGER DECIMALS %HALFINTEGER PLUS SIGN {='+' if a sign is mandatory, else set to zero} %INTEGER SCALE %HALFINTEGER BLANKS {=TRUE if blanks are significant and not NULL} %HALFINTEGER FMTCODE ;!%C FMTCODE may take special values %C which are: %consthalfinteger A SPECIAL= 'Y' , I SPECIAL= 'J' , FREE FORMAT = 'K' ! ! Utility Variables ! %OWNBYTEINTEGERARRAY BUFFER(0:255) %INTEGER I ; !a work variable %SWITCH IO FORM (UNFORMATTED IO:OPEN CLOSE AND INQUIRE) %IF FIO2 FLAG = FALSE %THENSTART; ! ! ! ! ! Initialise FIO Itself ! ! ! ! ! RUN MODE={COMREG (42)} 0 FIO MODE= NORMAL MODE START OF RT FMTS= NOT SET ; !forget any area acquired for Run-Time formats RT == RECORD(NULL); !forget any record of the last format saved ! F77AUX(13,ADDR(WORKAREA DESC),ADDR(FAULT)); !create workarea ! ! ! -> BASIC IO ERROR %IF FAULT\= 0 WORKAREA ADDR=ADDR(WORK AREA(0)) OUTPUT AREA ==ARRAY( WORKAREA ADDR , FORM B) COPY AREA == OUTPUT AREA !E2900 BLANK BUFFER==ARRAY( ADDR (MONITOR BUFFER(0)) , FORM C) ! !Create (map) the required work-areas FIO2FLAG= TRUE; ! (for EMAS or PERQ) ! !----->END OF INTERNAL INITIALISATION ! %FINISH ! ! Analyse The Parameters ! CASE = FLAGS & 16 RELAX ANSI = FLAGS & 8 CHECK = FLAGS & 4 FORMATTED IO = FLAGS & 1 ! FORM MASK =FORMATTED IO ! F77 DEFINED ! FILE TYPE = IO MODE >> 4 IO TYPE = (IO MODE & 15) + 1 INOUT = IO TYPE - 2 ! DSNUM = TCT_DSNUM %IF FORM<=LIST DIRECTED IO %THENSTART; !a transfer request ! %IF FILE TYPE= 5 %THENSTART FAULT=INITIALISE INTERNAL IO OPERATION %IF FAULT>0 %THEN -> BASIC IO ERROR %FINISHELSESTART F==RECORD(CURRENT FD) ! ! Test if a New File Operation is Requested ! %IF F==RECORD(NULL) %OR %C F_CURSTATE\=IO TYPE %ORC F_DSNUM \= DSNUM %THENSTART FAULT=INITIALISE EXTERNAL IO OPERATION -> BASIC IO ERROR %IF FAULT\=NONE %FINISH ! ! Extract the FORM Property of the Connection ! UFD= F_UFD %IF UFD= NOT SET %THENSTART ! ! Set the FORM Property of the File ! UFD= FORM MASK F_UFD= UFD %FINISH !And now Validate the FORM Property: ! %IF (UFD&FMTEDFILE BITS)\=FORM MASK %C %AND RELAX ANSI =FALSE %THENSTART ! ! Report a FORM Conflict ! %IF FORMATTED IO=FALSE %C %THEN FAULT=CONNECTION NOT UNFORMATTED %C %ELSE FAULT=CONNECTION NOT FORMATTED ->BASIC IO ERROR %FINISH %IF SYSTEM\=EMAS %THENSTART ! ! ! %IF (FILE TYPE-6)\=F_ACCESS TYPE %THEN FAULT=ACCESS CONFLICT %C %AND -> BASIC IO ERROR %FINISH; !if not EMAS %IF FILE TYPE=7 %THENSTART ! ! Perform Direct-Access Initialisation ! F_DA RECNUM = TCT_REC NUMBER %UNLESS 0 BASIC IO ERROR %FINISH %IF INOUT=0 %THENSTART ! ! ! READ THE FIRST RECORD ! ! FAULT = INREC %IF FAULT\= NONE %THEN -> BASIC IO ERROR ! !---AND NOW INITIALISE FOR PROCESSING INPUT ! BUFF LENGTH= F_RECSIZE BSTART= F_AREC ! !prepare to handle formatted records ! %IF FORMATTED IO\=FALSE %THENSTART ! BLANKS ATTRIBUTE= F_F77BLANK; !=> a property of the connection ! %FINISH; !processing formatted records %FINISHELSESTART ! ! ! PREPARE FOR PROCESSING OUTPUT ! ! %IF FILE TYPE=7 %THEN BUFF LENGTH= F_RECSIZE %C %ELSE BUFF LENGTH= F_MAXREC BSTART= F_AREC %FINISH; !preparing output %FINISH; !preparing external file I/O ! ! INITIALISE THE BUFFER POINTERS ! IO BUFFER== ARRAY(BSTART, FORM A) ! BPTR = BINC ; !-> relative start of buffer MAX BPTR = BINC ; !-> maximum value of BPTR BLEN = BUFF LENGTH + BINC; !-> relative end of buffer ! %FINISH; !preparing a transfer request -> IO FORM (FORM) ! ! ! IO FORM (UNFORMATTED IO): ! FAULT=UNFMT IO %IF FAULT=NONE %THEN -> RETURN -> IO ERROR IO FORM (FORMAT IN ARRAY): IO FORM (FORMAT IO): BLANKS=BLANKS ATTRIBUTE SCALE= NONE; EXP WIDTH= NONE PLUS SIGN = NONE; WIDTH= UNDEFINED FAULT= FMT IO { Initialise variables } %IF FAULT=NONE %THEN -> RETURN -> IO ERROR IO FORM (LIST DIRECTED IO): PLUS SIGN = NONE; DECIMALS= NONE EXP WIDTH= NONE; BLANKS = TRUE SCALE= 1; FMTCODE = FREE FORMAT FAULT=FREE FMTIO %IF FAULT=NONE %THEN -> RETURN -> IO ERROR !%C IO FORM (BACKSPACE): %C IO FORM (ENDFILE): IO FORM (REWIND) : ! FAULT= NEW FILE OP (DSNUM,IOMODE,8,AFD) %UNLESS FAULT=NONE %THENSTART ! %IF IO MODE=4 %AND FAULT=FILE DOES NOT EXIST %THEN ->RETURN ! !REWINDing a new file has no effect -> BASIC IO ERROR %FINISH ! %IF IOMODE=8 %AND RELAX ANSI=FALSE %THENSTART; F==RECORD(AFD) ! ! Validate the BACKSPACE operation ! %IF F_UFD=FREEFMTFILE BITS %THEN -> BSP NOT ALLOWED %FINISH -> RETURN ! BSP NOT ALLOWED: FAULT=BACKSPACE NOT ALLOWED -> BASIC IO ERROR IO FORM (OPEN CLOSE AND INQUIRE): ! %IF DSNUM<0 %THENSTART %IF DSNUM=-2 %OR IO MODE\=128 %THENSTART ! {NOTE: IO MODE=128 => Inquire} !Fail on the channel number { IO MODE= 64 => Close } ! { IO MODE= 32 => Open } FAULT=INVALID UNIT NUMBER -> BASIC IO ERROR %FINISH %FINISH %IF TCT_PPs(0)_ID= -1 %THEN PPLIST ADDRESS= NONE %C %ELSE PPLIST ADDRESS= ADDR(TCT_PPs(0)) %IF IO MODE=32 %THEN FAULT= OPEN (PPLIST ADDRESS) %ELSESTART %IF IO MODE=64 %THEN FAULT= CLOSE (PPLIST ADDRESS) %C %ELSE FAULT= INQUIRE (PPLIST ADDRESS) ; %FINISH ! -> BASIC IO ERROR %IF FAULT\=NONE RETURN: !*********************************************************************** ! ! RETURN (after successful completion) ! !*********************************************************************** ! !Set the IOSTAT field in the Transfer Control Table ! TCT_IOSTAT VALUE= 0 ! %RESULT= 0 !*********************************************************************** ! ! REPORT AN ERROR ! !*********************************************************************** ! BASIC IO ERROR: BPTR= UNDEFINED !=> an error has been detected !and no I/O buffer has been acquired IO ERROR: %IF SPECIFIER FLAGS\=NONE %THENSTART ! ! ! Examine the I/O error specifiers given ! ! ERROR= FAULT ERROR=-ERROR %IF ERROR< 0 {check for FORMATCD 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 } GET EXTRA ERROR INFO { and the I/O buffer} ! %FINISH {give a %MONITOR and %STOP} F77IOERR ( 1 {stack frame to unwind}) %ROUTINE GET EXTRA ERROR INFO ! ! ! ! ! This Routine Displays the Current I/O Buffer (if it ! ! is relevant) after an error message has ! ! been printed. ! ! ! %INTEGER BUFF DISP %INTEGER LENGTH %INTEGER I ! ! SEE IF A PRINT OF THE I/O BUFFER WOULD BE HELPFUL ! %IF BPTR>=0 %AND 0 0 %THEN BLEN= BPTR BLEN = BLEN - BINC LENGTH = BLEN BPTR = BPTR - BINC ! ! SEE IF BUFFER LENGTH IS GREATER THAN LINE-PRINTER PAPER WIDTH ! %IF LENGTH>OUTPUT LEN %THENSTART ; !Try and make sure that we ! print the part of the ! buffer that was being ! processed when the ! error occurred LENGTH=OUTPUT LEN %IF BPTR>=LENGTH %THENSTART I= BPTR + (OUTPUT LEN//2) %IF I REPORT FAULT %FINISH {Point to the next record} BINC= BINC + BUFF LENGTH BLEN= BINC + BUFF LENGTH %IF INOUT=0 %THENSTART ! ! Prepare a new record from an Internal File ! %IF CHECK\=FALSE %AND IO BUFFER(BINC)= NOT SET %C %THEN FAULT= UNASSIGNED VARIABLE %C %AND -> REPORT FAULT %FINISHELSESTART ! ! Prepare a new record for an Internal File ! FILL BUFF (BUFF LENGTH, BINC, BLANK) %FINISH %FINISHELSESTART !process an external file %IF INOUT=0 %THENSTART ! ! ! Read another record from an External File ! ! FAULT= INREC %IF FAULT\= NONE %THEN -> REPORT FAULT {%ELSE extract buffer address and record length} ! BLEN=F_RECSIZE BSTART=F_AREC %FINISHELSESTART ! ! ! Write a record to an External File ! ! BPTR= MAX BPTR %IF MAX BPTR>BPTR BUFF LENGTH= BPTR %IF BUFF LENGTH= 0 %THEN IO BUFFER(0)= BLANK %C %AND BUFF LENGTH = 1 MINREC=F_MINREC %IF MINREC>BUFF LENGTH %THENSTART ! FILL BUFF(MINREC-BUFF LENGTH,BUFF LENGTH, BLANK{s}) BUFF LENGTH=MINREC %FINISH ! ! NOW WRITE THE RECORD OUT ! FAULT = OUTREC (BUFF LENGTH) -> REPORT FAULT %IF FAULT\= NONE ! ! Tidy up after the output operation ! %IF FILE TYPE=7 %THEN BLEN= F_RECSIZE %C %ELSE BLEN= F_MAXREC BSTART= F_AREC %FINISH; !external file output ! IO BUFFER== ARRAY(BSTART, FORM A) ! %FINISH; !external file I/O ! ! Re-set the buffer variables ! MAX BPTR= BINC BPTR= BINC ! %RESULT= 0 !REPORT FAULT: REPORT FAULT: !REPORT FAULT: BPTR=UNDEFINED ; %RESULT=FAULT {Inhibit error handling} { from displaying a } { non-existant buffer} %END; !of NEW RECORD %HALFINTEGERFN NEW UNFMT RECORD ! ! ! ! ! A UTILITY PROCEDURE TO READ OR WRITE THE ! ! NEXT UNFORMATTED RECORD. ! ! ! %INTEGER BUFF LENGTH; !length of the current record or buffer %HALFINTEGER FAULT ; !fault reported by INREC or OUTREC %INTEGER 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 %IF BUFF LENGTH= 0 %THEN IO BUFFER(0)= 0 %C %AND BUFF LENGTH= 1 ! ! Check that the record is large enough ! I=F_MINREC - BUFF LENGTH %IF I> 0 %THENSTART FILL BUFF (I,BUFF LENGTH, 0 {zeros}) ! BUFF LENGTH= F_MINREC %FINISH !OUTPUT THE RECORD: ! FAULT= OUTREC (BUFF LENGTH) %IF FILETYPE=7 %THEN BLEN= F_RECSIZE %C %ELSE BLEN= F_MAXREC; !determine length of %FINISH; !the next record ! ! RE-SET THE BUFFER POINTERS ! BSTART= F_AREC ; !Define the IO BUFFER== ARRAY(BSTART, FORM A); ! I/O buffer BPTR= 0 !and initialise its ptr ! %RESULT= FAULT %END; !of NEW UNFMT RECORD !*********************************************************************** ! ! READ and WRITE Servicing Procedures ! !*********************************************************************** ! %INTEGERFN FMT IO ! ! ! ! ! THIS ROUTINE IS RESPONSIBLE FOR HANDLING I/O ! ! UNDER THE CONTROL OF FORMATS. IT IS THE ! ! PRINCIPAL SERVICE ROUTINE INSIDE FIO. ! ! !Its Basic Functions are: ! ! (1). Encode the format if it is a run-time format ! (performing optimisation if possible), ! (2). Decide if there are any I/O items. If there are then access to ! the user's coroutine is established and the first ! I/O item is acquired, ! (3). Process the format, until an edit code which corresponds to the ! I/O item is found, or until the end of the format is ! encountered, ! (4). Check for completion of the I/O operation, ! (5). Call the appropriate data conversion routine (depending on ! whether reading or writing is being performed, ! (6). Decide whether another I/O item is required, ! (7). Decide whether another edit descriptor is required. Continue ! from Step 3 if one is: otherwise continue from Step 4. ! ! ! ! ! ! ! THE FOLLOWING VARIABLES ARE FOR RUN-TIME ARRAY FORMAT PROCESSING ! %CONSTINTEGER RT FORMAT SIZE=4096 ; !MAXIMUM SIZE THAT A RUN-TIME ! FORMAT ARRAY MAY TAKE %CONSTINTEGER MAX RT FORMAT SIZE=4096 ; !MAXIMUM SIZE OF AREA FOR RUN- ! TIME FORMAT PROCESSING !-WHEN OPERATING IN BATCH MODE %CONSTINTEGER MAX RT FORMAT TEXT=2048 ; !MAXIMUM LENGTH ALLOWED FOR A ! RUN-TIME FORMAT TEXT %IF SYSTEM= EMAS %THENSTART ! %CONSTSTRING(7) RT FMT AREA NAME= "T#RFMT2" {if EMAS} %FINISHELSESTART; %CONSTSTRING(5) RT FMT AREA NAME= "RFMT2" %FINISH; !if PERQ ! ! THE FOLLOWING VARIABLES ARE USED FOR RUN-TIME ARRAY ! FORMAT PROCESSING WHEN OPERATING IN STAND-ALONE MODE ! %CONSTINTEGER RT FMT AREA SIZE=12288 ; !SIZE OF AREA FOR RUN-TIME ! FORMAT PROCESSING !-WHEN OPERATING IN SOLO MODE %CONSTINTEGER MAX RT FMT AREA SIZE=12288; !MAXIMUM AREA SIZE FOR RUNTIME ! FORMAT PROCESSING %OWNINTEGER RT FMT AREA ADDR ; !ADDRESS OF AREA ACQUIRED ! FOR RT FORMAT PROCESSING %OWNHALFINTEGER SPACE LEFT=0 ; !AMOUNT OF FREE SPACE LEFT ! IN THE CREATED AREA %INTEGER FMT LEN ; !SIZE OF A NEWLY PROCESSED ! RUN-TIME ARRAY FORMAT !NOTE: Run-Time Array Format Processing operates in one of two modes: ! ! ! In JOBBER mode no attempt is made to remember previously %C processed formats, and each Run-Time format %C is regarded as a new one ! ! In STAND-ALONE mode each newly processed Run-Time format %C is stored in an area and is compared later %C with any new Run-Time format for equivalence %C to see if processing can be avoided. %C The Area is built up as a list of entries ordered %C on the format array address. When the %C area becomes full all the entries are %C thown away, and the list is built up %C afresh. Each such entry has the following form: ! ! !RECORDFORMAT FORM OF RUN TIME FORMAT LIST ( %C %C %INTEGER LINK {to next entry} , %INTEGER TXT ADR {of format array} , %C %BYTEINTEGERARRAY TXT AND TABLE (0:30000 {ie undefined})); !%C of the format ! ! Run-Time Format Entry Pointers ! %RECORD (Form of Run Time Format Entry) %NAME {s} %C {!} %C RT1 {mapped onto entry before the current one being examined}, RT2 {mapped onto start of free space} ! ! ! { } %CONSTHALFINTEGER I SPECIAL = X'4A'; !ie. cIw.m { of } %CONSTHALFINTEGER OPEN BRACKET = X'42'; !ie. n(... { } %CONSTHALFINTEGER CLOSE BRACKET = X'4B'; !ie. ...) { entries} %CONSTHALFINTEGER NEGATIVE SCALE = X'4F'; !ie. -nP { } %CONSTHALFINTEGER POSITIVE SCALE = X'50'; !ie. nP { in } %CONSTHALFINTEGER SLASH = X'4E'; !ie. / { } %CONSTHALFINTEGER COLON = X'57'; !ie. : { the } %CONSTHALFINTEGER BN,BZ = X'4D'; !ie. BN or BZ { } %CONSTHALFINTEGER S,SP,SS = X'52'; !ie. SP or SS or S { FORMAT } %CONSTHALFINTEGER TL = X'55'; !ie. TLc { } %CONSTHALFINTEGER TR = X'56'; !ie. TRc { table } %CONSTHALFINTEGER REPETITION = X'5B'; !ie. cfmt { } %CONSTHALFINTEGER END OF FMTS = X'53'; ! ! RUN-TIME ARRAY TEXT VARIABLES ! %INTEGER TXT ADR; !word address of format text %HALFINTEGER TXT INC; ! and displacement to 1st character %HALFINTEGER TXT LEN; !length of the format text %HALFINTEGER FMT MAX ;!%C FMT MAX is the maximum length allowed for the format table ! ! FORMAT TABLE POINTERS ! %RECORD (Form of Format Table) %NAME {s} %C {!} %C RESTART POINT {ptr to 'level 1' bracket in format table}, FMT {ptr to current entry in the format table} %INTEGER FMT AD {address of the format table} ! ! FORMAT TABLE PROCESSING CONTROL VARIABLES ! %OWNHALFINTEGERARRAY NEST %C COUNTS(0:7); !A 'stack' to save the COUNT applying ! to each level of brackets %HALFINTEGER NEST LEVEL ; !Current level of bracketting %HALFINTEGER NEST COUNT ; !Repetition factor specified ! for current level of brackets ! %INTEGER TEXT LEN ; !Descriptor to a %INTEGER TEXT AD ; ! holerith store location ! ! FORMAT TABLE PROCESSING VARIABLES ! %INTEGER POSITIONING; !As is defined by an nX or Tc or TLc or TRc format ! and applied to the buffer pointer before any I/O %INTEGER COUNT ; !Repeat specification of an edit descriptor %INTEGER PTR ; !Pointer into the current I/O buffer %INTEGER I,J ; !Entries in the Format Table %SWITCH FMT TYPE ('A':REPETITION) ! ! VARIABLES ASSOCIATED WITH AN I/O LIST ! %HALFINTEGER MORE IO ITEMS ; !boolean variable: 0=> End of List ! else=> More Items %INTEGER VARIABLE ADDRESS ; !address of the next I/O item %HALFINTEGER NOS PER ITEM ; !set 2 for Complex variables !set 1 for other variable types %HALFINTEGER ITEM TYPE; !the result from !the coroutine as follows: -1 if no more items ! 0 if a scalar ! 1 if an array ! 2 if a Character scalar %INTEGER RESULT {of FMT IO} ! ! ! %IF FORM=FORMAT IN ARRAY %THENSTART ! !*********************************************************************** ! ! RUN-TIME FORMAT SPECIFIED: ENCODE THE TEXT ! !*********************************************************************** ! {Initialise Variables} TXT ADR= TCT_FORMAT ADDRESS TXT INC= TCT_FORMAT INC TXT LEN= TCT_FORMAT LENGTH RESULT=FMT TOO LARGE %AND %C -> REPORT ERROR %IF TXT LEN> MAX RT FORMAT TEXT FMT MAX=TXT LEN + TXT LEN + {an arbitary factor} 100 !=maximum anticipated size of the format table %UNLESS RT==RECORD(NULL) %THENSTART; !at least one format has been saved %IF TXT ADR\=RT_TXT ADR %ORC COMPARE(TXT LEN,TXT ADR,TXT INC, ADDR(RT_TXT AND TABLE(0)),0)\= 0 %THENSTART !new format is not the current one ! ! Search List for the new Format ! RT==RECORD(START OF RT FMTS) !! SCAN LIST: RT1== RT %AND RT== RECORD(RT1_LINK) %IF RT== RECORD(NULL) %THEN -> A NEW FMT %IF TXT ADR> RT_TXT ADR %THEN -> SCAN LIST %IF TXT ADR< RT_TXT ADR %THEN ->A NEW FMT %IF COMPARE(TXT LEN,TXT ADR,TXT INC, ADDR(RT_TXT AND TABLE(0)),0)\= 0 %THEN -> SCAN LIST %FINISH ! !---located new format in the list ! FMT AD= ADDR(RT_TXT AND TABLE( (TXT LEN +3) & (-4))) {note the address } { of the associated table} %FINISHELSESTART ! ! ! Check why no Run-Time Format has been saved ! ! %IF RUN MODE< 0 %THENSTART ! ! React to JOBBER Mode ! %IF START OF RT FMTS=NOT SET %THENSTART ! RESULT=125;!OUTFILE (RT FMT AREA NAME,RT FORMAT SIZE, MAX RT FORMAT SIZE,0, START OF RT FMTS,RESULT) -> REPORT ERROR %UNLESS RESULT=NONE %FINISH ! {Convert the Format} {!} FMT AD=START OF RT FMTS RESULT= FORMATCD(TXT ADR,TXT INC, FMT AD, TXT LEN, RT FORMAT SIZE, RELAX ANSI,1,FMT LEN,I) %UNLESS RESULT= NONE %THEN -> REPORT ERROR %FINISHELSESTART ! ! React to NORMAL RUNNING Mode ! !OUTFILE (RT FMT AREA NAME,RT FMT AREA SIZE, MAX RT FMT AREA SIZE,0,RT FMT AREA ADDR,RESULT) RESULT = 125 -> REPORT ERROR %IF RESULT\= 0 {create an area in which } { to remember Run-Time formats in} SPACE LEFT= NONE A NEW FMT: ! ! ! Prepare to Save a New Format ! ! %IF FMT MAX + TXT LEN +8> SPACE LEFT %THENSTART ! ! Make Room for a New List Entry ! SPACE LEFT = RT FMT AREA SIZE START OF RT FMTS= RT FMT AREA ADDR RT2 == RECORD(START OF RT FMTS) RT2_LINK=NOT SET %FINISHELSESTART ! ! Else Add a New Entry to the List ! RT2_LINK=RT1_LINK RT1_LINK= ADDR(RT2_LINK) %FINISH ! ! Remember a New Run-Time Format ! RT==RT2 FMT AD= ADDR(RT_TXT AND TABLE( (TXT LEN+3) & (-4))) ! RESULT= FORMATCD (TXT ADR,TXT INC,FMT AD , TXT LEN,FMT MAX,RELAX ANSI,1,FMT LEN,I) %IF RESULT\= 0 %THENSTART ! ! Throw away the Work-Area ! RT==RECORD(NULL) -> REPORT ERROR %FINISH COPY(TXT LEN,TXT ADR,TXT INC,ADDR(RT_TXT AND TABLE(0)),0) {save the format text } {! and the format array address} RT_TXT ADR=TXT ADR ! ! Point to the Next Free Entry in the Area ! I= (TXT LEN + FMT LEN +11) & (-4) {that is the length of the new entry} ! RT2==RECORD(ADDR(RT2) + I>>1) SPACE LEFT= SPACE LEFT - I %FINISH %FINISH %FINISHELSESTART ! !*********************************************************************** ! ! A FORMAT STATEMENT SPECIFIED: INITIALISE ! !*********************************************************************** ! FMT AD = TCT_FORMAT ADDRESS ! ! %FINISH NEST LEVEL = NONE {Initialise } COUNT = NONE { for } POSITIONING = NONE { Format } RESTART POINT== RECORD(FMT AD-2) { Table } FMT == RESTART POINT { processing} ! !*********************************************************************** ! ! CHECK FOR AN I/O LIST ! !*********************************************************************** ! MORE IO ITEMS = TCT_COROUTINE INDEX %IF MORE IO ITEMS\= FALSE %THENSTART; !---there is an I/O list ! ! Get The First I/O Item ! -> CALL COROUTINE %FINISH ! !*********************************************************************** ! ! EXTRACT THE NEXT FORMAT CODE (from the format table) ! !*********************************************************************** ! NEXT FORMAT: ! FMT==FMT_NEXT ENTRY %AND FMT CODE=FMT_FMT TYPE%C %AND -> FMT TYPE (FMT CODE) !**************************** END OF FORMAT **************************** ! ! FMT TYPE (END OF FMTS): %IF MORE IO ITEMS=FALSE %THEN -> TIDY UP ! RESULT=NO FMT FOR IO ITEM %AND -> REPORT FAULT %C %IF WIDTH=UNDEFINED FMT==RESTART POINT !**************************** END OF RECORD **************************** ! ! FMT TYPE (SLASH): RESULT= NEW RECORD %IF RESULT>0 %THEN -> REPORT FAULT %RESULT=RECORD OUT OF RANGE %IF SYSTEM =EMAS %C %AND INOUT >0 %C %AND FILE TYPE=7 %C %AND F_DA RECNUM>F_MAXSIZE POSITIONING=NONE -> NEXT FORMAT !**************************** COLON EDITTING *************************** ! ! FMT TYPE (COLON): %IF MORE IO ITEMS=FALSE %THEN -> TIDY UP -> NEXT FORMAT !********************** START OF BRACKETTED ITEMS ********************** ! ! FMT TYPE (OPEN BRACKET): ! %IF NEST LEVEL>0 %THEN NEST COUNTS (NEST LEVEL)= NEST COUNT %C %ELSE RESTART POINT==RECORD(ADDR(FMT)-2) NEST LEVEL= NEST LEVEL + 1 NEST COUNT= FMT_VALUE -> NEXT FORMAT !*********************** END OF BRACKETTED ITEMS *********************** ! ! FMT TYPE (CLOSE BRACKET): NEST COUNT= NEST COUNT - 1 ! %IF NEST COUNT<=0 %THEN NEST LEVEL= NEST LEVEL - 1 %C %AND NEST COUNT= NEST COUNTS (NEST LEVEL) %C %ELSE FMT== RECORD(FMT AD + %C FMT_VALUE - 2) -> NEXT FORMAT !**************************** BN - BZ ********************************** ! %C FMT TYPE (BN): FMT TYPE (BZ): BLANKS= FMT_VALUE -> NEXT FORMAT !**************************** S - SP - SS ****************************** ! %C FMT TYPE (S) : %C FMT TYPE (SP): FMT TYPE (SS): PLUS SIGN= FMT_VALUE %IF PLUS SIGN= 0 %THEN PLUS SIGN= PLUS %C %ELSE PLUS SIGN= NONE -> NEXT FORMAT !**************************** TRc - nX ********************************* ! ! FMT TYPE ('X'): FMT TYPE (TR) : POSITIONING= POSITIONING + FMT_VALUE ! ! NOTE that the 'T' format does not cause data to ! be transmitted. Also note that ANSI does ! not define the effect of positioning after ! the end of a record. ! ! ANSI specifically states that 'X' positioning ! beyond the end of an input record is ! allowed BUT no mention is made of output -> NEXT FORMAT !**************************** TLc ************************************** ! ! FMT TYPE (TL): POSITIONING= FMT_VALUE - POSITIONING POSITIONING= BPTR-BINC %IF POSITIONING>=BPTR-BINC POSITIONING=-POSITIONING !NOTE that TL may cause ! positioning which preceeds the buffer, and as per ANSI ! such positioning is forced onto the start of the buffer -> NEXT FORMAT !**************************** Tc *************************************** ! ! FMT TYPE ('T'): POSITIONING= (FMT_VALUE - 1) - (BPTR-BINC) -> NEXT FORMAT !**************************** nP *************************************** ! ! FMT TYPE (POSITIVE SCALE): SCALE= FMT_VALUE ; -> NEXT FORMAT FMT TYPE (NEGATIVE SCALE): SCALE= -(FMT_VALUE) ; -> NEXT FORMAT !**************************** a repeated format ************************ ! ! FMT TYPE (REPETITION): COUNT= FMT_VALUE -> NEXT FORMAT !****************************** Iw.m *********************************** ! ! FMT TYPE ( I SPECIAL): WIDTH= FMT_VALUE ; FMT==FMT_NEXT ENTRY INT WIDTH= FMT_VALUE2 -> DO FORMATTING !********** Dw.d - Ew.d - Fw.d - Gw.d - Qw.d - Ew.dEe - Gw.dEe ********* ! ! FMT TYPE ('D'): FMT TYPE ('E'): FMT TYPE ('F'): FMT TYPE ('G'): FMT TYPE ('Q'): WIDTH= FMT_VALUE %AND FMT==FMT_NEXT ENTRY EXP WIDTH= FMT_VALUE1 DECIMALS = FMT_VALUE2 ! -> DO FORMATTING !*********************** A - Aw - Iw - Lw - Zw ************************* ! ! FMT TYPE ('I'): INT WIDTH= 0 FMT TYPE ( A SPECIAL): FMT TYPE ('A'): FMT TYPE ('L'): FMT TYPE ('Z'): WIDTH= FMT_VALUE -> DO FORMATTING !************** SINGLE CHARACTER HOLERITHS AND LITERALS **************** ! ! FMT TYPE ('C'): TEXT LEN= 1 TEXT AD = ADDR(FMT_VALUE) ! -> HOLERITHS !**************************** nHliteral - 'literal' ******************** ! ! FMT TYPE ('H'): TEXT LEN= FMT_VALUE TEXT AD = ADDR(FMT_NEXT ENTRY) ! FMT==RECORD( (TEXT AD-2) + ( (TEXT LEN + 3) & X'FFFC') >> 1) !==addr of holerith address ! + holerith length rounded up to an integer boundary ! and converted to a word displacement ! !*********************************************************************** ! ! PERFORM HOLERITH OUTPUT ! !*********************************************************************** ! HOLERITHS: ! %IF POSITIONING\=0 %THEN BPTR=BPTR+POSITIONING %AND POSITIONING= NONE %IF INOUT =0 %THEN RESULT=LITERAL IN INPUT FMT %AND ->REPORT FAULT %IF BPTR>BLEN %THEN ->RECORD TOO SMALL ! %IF BPTR> MAX BPTR %THENSTART ! ! The 'T' or 'X' edit code has been used to re-specify ! the position of the buffer pointer in a ! forwards direction. Now is the time to move ! spaces into the unfilled positions. ! FILL BUFF (BPTR-MAXBPTR,BPTR,BLANK) MAXBPTR= BPTR %FINISH ! PTR =BPTR + TEXT LEN %IF PTR >BLEN %THEN -> RECORD TOO SMALL ! ! Move Holerith into the output buffer ! COPY (TEXT LEN,FMT AD,(TEXT AD-FMT AD)<<1,BSTART,BPTR) ! ! Move onto the next format item ! BPTR= PTR MAX BPTR=BPTR %IF BPTR>MAX BPTR ! !Update current buffer position and also ! 'last position written' if applicable ! -> NEXT FORMAT RECORD TOO SMALL: BPTR=MAX BPTR %AND RESULT=RECORD TOO SMALL %C %AND ->REPORT FAULT DO FORMATTING: ! !*********************************************************************** ! ! CHECK FOR COMPLETION OF I/O OPERATION ! !*********************************************************************** ! %IF MORE IO ITEMS=FALSE %THENSTART TIDY UP: %IF FILE TYPE\=5 %THENSTART ! %IF INOUT\=0 %THENRESULT= NEW RECORD ;!%C Output the current record %FINISH %RESULT=0 %FINISH ! !*********************************************************************** ! ! CALL THE INPUT OR OUTPUT FORMATTING ROUTINE ! !*********************************************************************** ! %IF POSITIONING\=NONE %THEN BPTR=BPTR+POSITIONING %AND POSITIONING=NONE ! %IF INOUT>0 %THENSTART %IF BPTR>MAXBPTR %AND BPTR 0 %THEN -> REPORT FAULT ! !*********************************************************************** ! ! ACQUIRE THE NEXT I/O ITEM ! !*********************************************************************** ! NUM DATA ITEMS= NUM DATA ITEMS - 1 %IF NUM DATA ITEMS> 0 %THENSTART ! %IF DATA TYPE = A CHARACTER %THEN DATA INC= DATA INC + DATA BYTES %C %ELSE DATA AD = DATA AD + DATA WORDS %FINISHELSESTART ! ! CALL COROUTINE: !for the next I/O item ! ITEM TYPE= IO ITEM (KEY,ADDR(DATA WORDS),VARIABLE ADDRESS) %IF ITEM TYPE< 0 %THEN -> END OF IO LIST 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 = VARIABLE ADDRESS NUM DATA ITEMS= NOS PER ITEM; %FINISHELSESTART %IF ITEM TYPE= 1 %THENSTART ! ! I/O Item is an Array ! DATA AD = ARRAY ADDRESS(VARIABLE ADDRESS, 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(VARIABLE ADDRESS ) DATA INC = HALFINTEGER(VARIABLE ADDRESS+2) DATA BYTES= DATA WORDS %FINISH %FINISH %FINISH; !determining the new I/O item MORE ITEMS: COUNT = COUNT - 1 %IF COUNT<=0 %THEN -> NEXT FORMAT %C %ELSE -> DO FORMATTING ! ! NOTE END OF I/O LIST ! END OF IO LIST: MORE IO ITEMS= FALSE -> MORE ITEMS ! ! Report Failure to Acquire a Format Table ! REPORT ERROR: !(associated with run-time format processing) ! BPTR = UNDEFINED {because buffer contents are irrelevant} %RESULT= RESULT ! ! Report other faults (other than immediately above) ! REPORT FAULT: ! %RESULT= RESULT ! ! ! ! ! %END; !of FMT IO %HALFINTEGERFN UNFMT IO ! ! ! ! A ROUTINE TO CONTROL THE I/O OF AN UNFORMATTED ! ! READ OR WRITE STATEMENT. ! ! ! %HALFINTEGERFNSPEC SPAN DA IO (%INTEGERNAME DATA LENGTH) ! ! %HALFINTEGER FAULT; !reported by SPAN DA IO or NEW 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 -> RETURN %IF TCT_COROUTINE INDEX=NONE !Jump if there's no I/O list ! ! Get the 1st I/O Item ! -> CALL COROUTINE %CYCLE ! ! 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 %THENRESULT=FAULT %FINISH ! ! TRANSFER DATA BETWEEN BUFFER AND I/O ITEM ! %IF INOUT=0 %THEN COPY(I,BSTART , BPTR ,DATA AD, DATA INC) %C %ELSE COPY(I,DATA AD, DATA INC, BSTART, BPTR ) BPTR= BPTR+I; !Update the Buffer Pointer ! ! GET THE NEXT I/O ITEM ! CALL COROUTINE: ITEM TYPE=IO ITEM(KEY,ADDR(DATA WORDS),ITEM AD) %IF ITEM TYPE<0 %THEN -> RETURN 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 %REPEAT ! ! TIDY UP THE I/O OPERATION ! RETURN: %IF INOUT=0 %THENRESULT= 0 %C %ELSERESULT= NEW UNFMT RECORD ! NEW UNFMT RECORD will zero fill ! any unwritten part of ! a direct-access 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. ! ! %INTEGER BUFF LENGTH ; !actual record length %INTEGER IO LENGTH ; !number of bytes to transfer to/from ! the current record %INTEGER 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 ! COPY (IO LENGTH,BSTART,BPTR,DATA AD,DATA INC) ! %FINISHELSESTART ! ! Send Output ! COPY (IO LENGTH,DATA AD,DATA INC,BSTART,BPTR) BPTR= IO LENGTH+BPTR %FINISH ! ! READ/WRITE THE NEXT RECORD ! FAULT = NEW UNFMT RECORD %IF FAULT\=0 %THENRESULT= FAULT %IF SYSTEM=EMAS %AND TRANSFER LENGTH>0 %AND INOUT>0 %THENSTART ! ! Check File Capacity (because EMAS can't) ! %RESULT=158 %IF F_DA RECNUM>F_MAXSIZE %FINISH; !if EMAS ! ! 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 %END; !of UNFMT 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 + 2 %FINISHELSE %C DATA BYTES= DATA WORDS + DATA WORDS NUM DATA ITEMS= INTEGER(DATA AD + 2) %RESULT= RESULT ! %END; !of ARRAY ADDRESS %HALFINTEGERFN FREE FMTIO ! ! ! ! AN INTEGER FUNCTION TO SERVICE A ! ! LIST-DIRECTED I/O REQUEST. ! ! %HALFINTEGERFNSPEC IN ITEM ! %HALFINTEGER OUTIN ; !local copy of INOUT %HALFINTEGER FAULT ! ! Variables for processing the I/O list ! %INTEGER ITEM AD ; !address of the next I/O item %HALFINTEGER ITEM TYPE ;!%C ITEM TYPE is the result from %C the coroutine which is set: -1 for end of list ! 0 for a scalar ! 1 for an array ! 2 for a Character scalar ! ! Variables associated with processing an input request ! %INTEGER PTR ; !scanning pointer through the current input buffer %INTEGER ITEM ; !the type of item being processed in the input buffer %INTEGER DELIM ; !the type of delimiter terminating the last value found %INTEGER COUNT ; !the repetition factor applying to the last value found %INTEGER DATA LEN; !the number of bytes associated with the current I/O item ! ! ! %IF TCT_COROUTINE INDEX\=NONE %THENSTART ; !There is an I/O list ! ! INITIALISE VARIABLES ! OUTIN= INOUT %IF OUTIN> 0 %THEN IO BUFFER(0)= BLANK %C %AND BPTR = 1 %C %ELSESTART ; SCALE= NONE; !-no scaling {Initialise} COUNT= NONE; !-no repetition (yet) { for } DELIM= 1 ; !-a comma { input} PTR= BPTR; !-set the scanning ptr %FINISH ! ! GET THE FIRST I/O ITEM ! -> CALL COROUTINE ! ! DO I/O FOR THE NEXT DATA ITEM ! %CYCLE; %IF OUTIN=0 %THEN FAULT= IN ITEM %C %ELSE FAULT= OUT ITEM %AND BPTR=BPTR+1 %UNLESS FAULT=0 %THENEXIT ! ! GET THE NEXT I/O ITEM ! CALL COROUTINE: ITEM TYPE=IO ITEM(KEY,ADDR(DATA WORDS),ITEM AD) %IF ITEM TYPE<0 %THEN -> RETURN DATA TYPE=DATA TYPE & 15 %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=1; %FINISHELSESTART %IF ITEM TYPE= 1 %THENSTART ! ! I/O Item is an Array ! DATA AD= ARRAY ADDRESS(ITEM AD,DATA TYPE) %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 %REPEAT ! ! TIDY UP THE I/O OPERATION ! %IF FAULT>0 %THEN BPTR= BPTR - OUTIN %C %ANDRESULT= FAULT %FINISH RETURN: %IF INOUT>0 %THENSTART ! ! Tidy up after Writing ! %IF UFD\=FREEFMTFILE BITS %THENSTART ! ! Mark the connection/file as having FREEFMT records ! UFD= FREEFMTFILE BITS {F_UFD= UFD} %FINISH %RESULT=NEW RECORD; !output the final record %FINISH %RESULT= 0; !if input !*********************************************************************** ! ! UTILITY PROCEDURE FOR LIST-DIRECTED INPUT ! !*********************************************************************** ! %HALFINTEGERFN IN ITEM ! ! ! ! ! A LOCAL PROCEDURE FOR PROCESSING LIST-DIRECTED INPUT. ! ! ! It locates the next value in the input stream and assigns it ! to the current I/O item. If the I/O item is an array then ! each array element is assigned the corresponding input value. ! ! ! %HALFINTEGERFNSPEC NEXT ITEM %HALFINTEGERFNSPEC NEXT CHAR %HALFINTEGERFNSPEC IN COMPLEX %HALFINTEGERFNSPEC IN LITERAL {These } %CONSTHALFINTEGER END OF INPUT = 0; !ie a '/' { are } %CONSTHALFINTEGER A COMMA = 1; !ie a ',' { the } %CONSTHALFINTEGER END OF RECORD = 2; !ie next record reqd { types } %CONSTHALFINTEGER A BLANK = 3; !ie a ' ' { of } %CONSTHALFINTEGER CLOSE BRACKET = 4; !ie a ')' { values } %CONSTHALFINTEGER COMPLEX = 5; !ie (..... { which } %CONSTHALFINTEGER LITERAL = 6; !ie '..... { are } %CONSTHALFINTEGER REPETITION FACTOR= 7; !ie 123* {recognised} %CONSTHALFINTEGER LOGICAL CONSTANT = 8; !ie T or F.... { in } %CONSTHALFINTEGER A LETTER = 9; !ie ...letter.... { the } %CONSTHALFINTEGER A CONSTANT = 10; !ie . or + or -... { current} %CONSTHALFINTEGER INTEGER CONSTANT = 11; !ie digits { input } %CONSTHALFINTEGER AN ERROR = 12; !ie invalid character { buffer } %CONSTHALFINTEGER SCANNED COMPLEX = 13; !ie repeated complex { } %CONSTHALFINTEGER SCANNED LITERAL = 14; !ie repeated literal %CONSTHALFINTEGER A DELIMITER= 3; !or less %OWNINTEGER R PTR; !set to the start of a repeated constant and is used !should the constant have to be re-evaluated for a !different I/O item. %SWITCH TYPE (END OF INPUT:SCANNED LITERAL) %HALFINTEGER FAULT; !utility variable - set to error identified ! ! Variables associated with the current I/O item ! %OWNINTEGER LAST DATA INC ; !a record of the increment %OWNINTEGER LAST DATA AD ; ! and address and type %OWNINTEGER LAST DATA TYPE ; ! of an evaluated, repeated, value %OWNINTEGER LAST DATA BYTES; ! --used to decide if re-evaluation is %C reqd when the next I/O item is known %IF COUNT>0 %THENSTART %IF WIDTH=NULL %THEN -> TIDY UP ! ! Continue handling a repeated constant ! %IF DATA BYTES= LAST DATA BYTES %AND %C DATA TYPE = LAST DATA TYPE %THENSTART %IF DATA TYPE=A CHARACTER %THEN -> COPY TEXT %C %ELSE -> COPY VALUE %FINISH; !if new and old I/O items are similar {otherwise} LAST DATA BYTES= DATA BYTES; !make a note of LAST DATA TYPE = DATA TYPE ; ! the new type of LAST DATA AD = DATA AD ; ! the repeated constant {and} B PTR = R PTR ; !ensure that the constant %FINISHELSESTART ; ! is rescanned ! ! LOCATE A NEW CONSTANT AMONGST THE INPUT ! NEXT: -> READ NEXT RECORD %IF DELIM=END OF RECORD -> NO MORE INPUT %IF DELIM=END OF INPUT ITEM: ITEM=NEXT ITEM %IF ITEM< 0 %THEN FAULT=-ITEM %AND -> FAULT REPORTED %FINISH {*********************} -> TYPE (ITEM); {**********************} !go and process next value! ! ! REPORT FAULTS ! NO VALUE SEPARATOR : BPTR=PTR-1; FAULT= VALUE SEPARATOR %C MISSING ; -> REPORT INVALID REPETITION : FAULT=INVALID REPETITION; -> REPORT ILLEGAL REPETITION : FAULT=ILLEGAL REPETITION; -> REPORT INCOMPATIBLE CONSTANT: ! %IF DATA TYPE=AN INTEGER %THEN FAULT=INVALID INTEGER %ELSESTART %IF DATA TYPE= A LOGICAL %THEN FAULT=INVALID LOGICAL %ELSESTART %IF DATA TYPE= A COMPLEX %THEN FAULT=INVALID COMPLEX %ELSESTART %IF DATA TYPE= A REAL %THEN FAULT=INVALID REAL %C %ELSE FAULT=INVALID CHARACTER CONSTANT %FINISH; %FINISH; %FINISH REPORT: FAULT REPORTED: -> INCOMPATIBLE CONSTANT %IF FAULT=INCOMPATIBLE FORMAT ! %RESULT=FAULT ! ! HANDLE A REPETITION FACTOR ! TYPE (REPETITION FACTOR): -> ILLEGAL REPETITION %IF COUNT> 0 ! FAULT= TO INTEGER (ADDR(COUNT),2,BSTART,WIDTH,BPTR,FIO PLUS MODE) %IF FAULT> 0 %THEN -> FAULT REPORTED ! %IF COUNT= 0 %THEN -> INVALID REPETITION %IF COUNT>NUM DATA ITEMS %THENSTART ; R PTR = PTR {Save the identity of the current I/O item } { as the repeated constant also applies} LAST DATA TYPE =DATA TYPE { to the following I/O items } LAST DATA BYTES=DATA BYTES {we may be able to avoid rescanning it: %FINISH; LAST DATA AD =DATA AD ! DELIM= NEXT CHAR %IF DELIM>A DELIMITER %THEN PTR=PTR-1 %AND -> ITEM !go and evaluate the next item -> A NULL VALUE;!otherwise ! ! HANDLE END OF RECORD ! TYPE (END OF RECORD): READ NEXT RECORD: FAULT = NEW RECORD ! -> FAULT REPORTED %IF FAULT\= NONE; PTR=BPTR {otherwise} -> ITEM; !and !locate the next value ! ! HANDLE A COMMA ! TYPE (A COMMA): {we must ignore the comma if it is the first item} { on a record when the last item was assumed } { to be delimited by the record boundary } DELIM=A COMMA %AND -> NEXT %IF DELIM=A BLANK %OR DELIM=END OF RECORD ! {ELSE} A NULL VALUE: WIDTH = NULL -> TIDY UP ! ! HANDLE A SLASH ! TYPE (END OF INPUT): {report end of input} NO MORE INPUT: ! %RESULT= -1 ! ! HANDLE A LITERAL ! TYPE (LITERAL): TYPE (SCANNED LITERAL): ! ! This sequence is used for both unscanned literals ! and literals which have been evaluated within ! the scope of a repetition factor. ! FAULT = IN LITERAL %IF FAULT\= 0 %THEN -> FAULT REPORTED %C %ELSE -> CHECK SEPARATOR ! ! HANDLE A COMPLEX VALUE ! TYPE (COMPLEX): TYPE (SCANNED COMPLEX): ! ! This code is used for previously scanned complex ! values (preceded by a repetition factor) and for ! as yet unscanned complex values. ! FAULT = IN COMPLEX %IF FAULT\= 0 %THEN -> FAULT REPORTED {Make sure that} CHECK SEPARATOR: DELIM = NEXT CHAR { there is } { a valid } -> TIDY UP %IF DELIM<=A DELIMITER { separator} -> NO VALUE SEPARATOR ! ! HANDLE ANY OTHER TYPE OF CONSTANT (logical,real,or integer) ! TYPE (INTEGER CONSTANT): TYPE (A LETTER) : TYPE (LOGICAL CONSTANT): TYPE (A CONSTANT): ! -> INCOMPATIBLE CONSTANT %IF DATA TYPE=A COMPLEX %C %OR DATA TYPE=A CHARACTER FAULT = IN FORMAT %IF FAULT\= 0 %THEN -> FAULT REPORTED !*****END OF HANDLING INPUT TYPES ! ! TIDY UP: {after a single assignment} DATA LEN= DATA BYTES ! !CYCLE through the current I/O item ! %IF DATA TYPE\=A CHARACTER %THENSTART %CYCLE DATA AD= DATA AD + DATA LEN>>1 COUNT = COUNT-1 %RESULT=0 %IF NUM DATA ITEMS=1; !exit if I/O item is finished ! NUM DATA ITEMS=NUM DATA ITEMS -1 %IF COUNT<=0 %THEN -> NEXT; !jump if data item is finished %IF WIDTH\=0 %THENSTART; !copy a non-null value ! COPY VALUE: ! COPY(DATA LEN,LAST DATA AD,0,DATA AD,0) %FINISH %REPEAT %FINISHELSESTART ! ! Handle a CHARACTER Variable (Special Case) ! %CYCLE; DATA INC=DATA INC + DATA LEN COUNT =COUNT-1 %RESULT=0 %IF NUM DATA ITEMS=1 {exit if I/O item is finished} ! NUM DATA ITEMS=NUM DATA ITEMS -1 %IF COUNT<=0 %THEN -> NEXT COPY TEXT: %IF WIDTH\=NULL %THEN COPY(DATA LEN,LAST DATA AD , LAST DATA INC, DATA AD ,DATA INC) %REPEAT %FINISH !*********************************************************************** ! ! LOCAL PROCEDURES FOR IN ITEM ! !*********************************************************************** ! %HALFINTEGERFN NEXT ITEM ! ! ! ! ! A LOCAL PROCEDURE TO IDENTIFY AND CATEGORISE THE NEXT ! ! ITEM WITHIN A LIST-DIRECTED INPUT STREAM. ! ! !An item is categorised either as a delimiter or as a value. In either !case its type is the result of this function and BPTR identifies its !location. If the item is a value then DELIM additionally identifies !the type of delimiter. Note that a blank is only returned as such a !delimiter if there is no following comma, slash, or end of record. ! ! ! %HALFINTEGER CHAR; !the type of the current character %HALFINTEGER ITEM; !the type of the current item -- the result %HALFINTEGER FAULT; !the fault identifier of any error detected ! %SWITCH HANDLE (END OF INPUT:AN ERROR) ! ! Initialise variables ! ITEM= NOT SET CHAR=NEXT CHAR %UNTIL CHAR\=A BLANK ! -> HANDLE (CHAR) ! ! REPORT A FAULT ! HANDLE (AN ERROR) : INVALID CHARACTER : FAULT=INVALID CHARACTER ; -> REPORT INVALID CONSTANT : FAULT=INVALID CONSTANT ; -> REPORT INVALID REPETITION: FAULT=INVALID REPETITION; ! REPORT: BPTR= PTR-1 %ANDRESULT=-FAULT ! ! PROCESS A 'NORMAL' CHARACTER ! HANDLE (LOGICAL CONSTANT): HANDLE (INTEGER CONSTANT): HANDLE ( A CONSTANT): ! %IF ITEM= NIL %THEN ITEM=CHAR %C %AND BPTR=PTR-1 %ELSESTART A CONTINUATION: !of the item {otherwise update } { the type of item} ITEM=CHAR %IF ITEM>CHAR ; %FINISH ! CHAR=NEXT CHAR %AND -> HANDLE (CHAR) ! ! PROCESS AN 'UNUSUAL' CHARACTER ! HANDLE (A LETTER): ! -> INVALID CONSTANT %IF ITEM=NOT SET {else} -> A CONTINUATION; !of the item ! and let IN FORMAT decide if it is ! really invalid (Logical values may ! contain almost anything). ! ! PROCESS A DELIMITER ! HANDLE (END OF INPUT ): HANDLE (END OF RECORD): HANDLE ( A COMMA) : HANDLE END OF ITEM : ! %IF ITEM=NOT SET %THEN BPTR=PTR-1 %ANDRESULT=CHAR !=> a delimiter on its own WIDTH=PTR-BPTR-1; !otherwise DELIM=CHAR ; ! note the type of delimiter %RESULT=ITEM ; ! and item type and length ! ! PROCESS THE START OF A COMPLEX OR LITERAL VALUE ! HANDLE (COMPLEX): !--- a "(" HANDLE (LITERAL): !--- a "'" ! %IF ITEM=NOT SET %THEN -> HANDLE END OF ITEM %C %ELSE CHAR=A LETTER %AND -> A CONTINUATION ! ! PROCESS THE END OF A COMPLEX VALUE ! HANDLE (CLOSE BRACKET): ! %IF DATA TYPE=A COMPLEX %THEN -> HANDLE END OF ITEM %C %ELSE -> A CONTINUATION ! ! PROCESS A BLANK ! HANDLE (A BLANK): ! %IF DATA TYPE=A COMPLEX %THEN DELIM=CLOSE BRACKET %C %ELSE DELIM=END OF RECORD !set range of delimiter types WIDTH=PTR-BPTR-1; CHAR=NEXT CHAR %UNTIL CHAR\=A BLANK !look for the next significant character %IF CHAR<=DELIM %THEN DELIM=CHAR %C %ELSE DELIM=A BLANK %AND PTR=PTR-1 %RESULT=ITEM ! ! PROCESS A REPETITION FACTOR ! HANDLE (REPETITION FACTOR): ! %IF ITEM= NOT SET %THEN -> INVALID CONSTANT %IF ITEM= A CONSTANT %THEN -> INVALID REPETITION %IF ITEM A CONTINUATION ITEM=REPETITION FACTOR; ! -> HANDLE END OF ITEM %END; !of NEXT ITEM %HALFINTEGERFN NEXT CHAR ! ! ! ! ! A LOCAL PROCEDURE TO CATEGORISE THE NEXT CHARACTER IN A ! ! LIST-DIRECTED INPUT STREAM INTO A PARTICULAR CLASS. ! ! !The classes are defined as follows: ! ! CLASS: 0 CHAR: '/' =>end of input ! 1 ',' => a value delimiter ! 2 end of record => a delimiter ! 3 ' ' => a delimiter ! 4 ')' =>end of a complex value ! 5 '(' =>start of a complex ! 6 ''' (quote) =>start of a literal ! 7 '*' =>repetition factor ! 8 'F' or 'T' =>start of a logical ! 9 any other valid ISO => part of a value ! 10 '+' or '-' or '.' => a number ! 11 any digit => a simple number ! 12 any other binary =>invalid character ! ! %CONSTBYTEINTEGERARRAY CHAR CLASS (0:127) %C = 12(32), 3 , 9( 6), 6 , 5 , 4 , 7 , 10 , 1 , 10 , 10 , 0 , 11(10), 9(12), 8 , 9(13), 8 , 9(43) ! ! %HALFINTEGER CHAR %HALFINTEGER CLASS ! %IF PTR>=BLEN %THEN CLASS=END OF RECORD %C %ELSESTART CHAR=IO BUFFER(PTR) %IF CHAR>127 %THEN CLASS=AN ERROR %C %ELSE CLASS= CHAR CLASS (CHAR) %FINISH PTR=PTR+1 %RESULT=CLASS %END; !of NEXT CHAR %HALFINTEGERFN IN COMPLEX ! ! ! ! ! A LOCAL PROCEDURE TO HANDLE A COMPLEX VALUE LOCATED ! ! WITHIN A LIST-DIRECTED INPUT STREAM. ! ! !Because complex values may be intersected by a record boundary between !the real and imaginary parts, and because such constants may have to be !repeatedly assigned to I/O items of differing types, it is essential !that a copy of the real part of such a constant is made before reading !the next record. (In this instance as much of the record as possible is !copied into a work-area). Note that due to the limited size of the !work-area, a repeated complex constant which crosses a record boundary !may occupy no more than 256 bytes of the first record. ! ! !NOTE a record is kept of the location of the real and imaginary parts ! which is used should the constant have to be re-evaluated for a ! complex I/O item at a different precision. This avoids having to ! re-scan the constant. ! ! ! ! ! Variables associated with copying the real part ! %OWNHALFINTEGER COPY MADE=FALSE !=>no copy has been made: =TRUE otherwise %INTEGER COPY ADDR; !the address of the work-area %INTEGER COPY FROM; !the address within the record to start copying %OWNINTEGER COPY LEN ; !the amount of the record copied ! ! Variables identifying the complex constant ! %OWNINTEGER REAL PTR; !the location and %OWNINTEGER REAL LEN; ! length of the real part %OWNINTEGER IMAG PTR; !the location and %OWNINTEGER IMAG LEN; ! length of the imaginary part %OWNINTEGER VALUE PTR; !the location of the opening bracket %C -----may be used for fault reporting %HALFINTEGER FAULT; !is used to identify any error %HALFINTEGER TYPE; !is used to identify the next item in the input stream DATA BYTES= DATA BYTES >> 1 DATA WORDS= DATA WORDS >> 1 %IF DATA TYPE\= A COMPLEX %THEN -> INCOMPATIBLE CONSTANT %IF ITEM=SCANNED COMPLEX %THENSTART ! ! RE-EVALUATE THE CONSTANT (at a different precision) ! BPTR = REAL PTR ; !evaluate WIDTH= REAL LEN ; ! the real part FAULT= IN FORMAT; ! (do not expect any errors) ! DATA AD= DATA AD + DATA WORDS ! BPTR = IMAG PTR ; !similarly WIDTH= IMAG LEN ; ! evaluate the FAULT= IN FORMAT; ! imaginary part -> RETURN %FINISH ! ! LOCATE AND ANALYSE THE REAL PART ! -> INVALID COMPLEX %IF NEXT ITEM VALUE SEPARATOR MISSING ! REAL PTR= BPTR ; !Note the position of the real part in case REAL LEN= WIDTH; ! the value is a repeated constant COPY MADE=FALSE {Now evaluate} FAULT=IN FORMAT { the real} -> FAULT REPORTED %IF FAULT\=NONE { part} DATA AD=DATA AD + DATA WORDS %IF DELIM=A COMMA %THENSTART; !(otherwise we have an end-of-record state ! ! NOW LOCATE THE IMAGINARY PART ! TYPE = NEXT ITEM %IF TYPE>= A LETTER %THENSTART ! EVAL IMAGINARY: -> VALUE SEPARATOR MISSING %IF DELIM\=CLOSE BRACKET IMAG PTR= BPTR IMAG LEN=WIDTH; !note position of imaginary part FAULT =IN FORMAT %IF FAULT\= 0 %THEN -> FAULT REPORTED !Finally tidy up and return ! ITEM=SCANNED COMPLEX -> RETURN %FINISH !Now see what really happened after looking for the imaginary part ! ! %IF TYPE\=END OF RECORD %THEN -> INVALID COMPLEX %FINISH !We are now in an end-of-record condition and we must decide whether to !make a copy of the current record to cope with the eventuality that the !constant has to be re-evaluated for an I/O item of different type. ! ! %IF COUNT>NUM DATA ITEMS %THENSTART; !make a copy of the record ! COPY ADDR= ADDR(COPY AREA(0)) COPY LEN = BLEN COPY LEN = 256 %IF COPY LEN>256 COPY FROM= BLEN - COPY LEN {now make the copy} COPY(COPY LEN,BSTART,COPY FROM,ADDR(COPY AREA(0)),0) !---and reset the ptrs VALUE PTR= BLEN - R PTR REAL PTR= BLEN - REAL PTR ! COPY MADE = TRUE %FINISH FAULT=NEW RECORD ; !read the -> FAULT REPORTED %IF FAULT\=NONE; ! next record in PTR=BPTR -> NO VALUE SEPARATOR %IF DELIM=END OF RECORD %AND NEXT ITEM\=A COMMA !=> no comma separating the real and imaginary parts ! %IF NEXT ITEM>=A LETTER %THEN -> EVAL IMAGINARY ! ! REPORT ERRORS ! INVALID COMPLEX : FAULT=INVALID COMPLEX ; -> REPORT ! VALUE SEPARATOR MISSING: BPTR= BPTR+WIDTH NO VALUE SEPARATOR : FAULT=VALUE SEPARATOR MISSING; -> REPORT ! INCOMPATIBLE CONSTANT : %IF COPY MADE=TRUE %AND ITEM=SCANNED COMPLEX %C %THENSTART BSTART= ADDR(COPY AREA(0)); !make the copy BLEN = COPY LEN ; !look like the BPTR =VALUE PTR ; !current buffer %FINISH FAULT =INCOMPATIBLE FORMAT; -> REPORT ! FAULT REPORTED: %IF FAULT=INPUT ENDED %THEN BPTR=BLEN %C %AND FAULT=INVALID COMPLEX REPORT : COPY MADE= FALSE ! ! Return ! RETURN: DATA AD = DATA AD - DATA WORDS DATA WORDS= DATA WORDS + DATA WORDS DATA BYTES= DATA BYTES + DATA BYTES %RESULT=FAULT ! %END; !of IN COMPLEX %HALFINTEGERFN IN LITERAL ! ! ! ! ! A LOCAL PROCEDURE TO ASSIGN A LITERAL VALUE IN A LIST ! ! DIRECTED INPUT STREAM TO THE CURRENT I/O ITEM. ! ! ! The literal is first evaluated into a work-area which ! can then be reused if the value has later to be assigned ! to a different I/O item (via a repetition factor). ! ! ! %INTEGER DATA LEN ; !number of bytes associated with the I/O item %INTEGER LENGTH ; !number of characters in the literal value %HALFINTEGER X ; !the current character during evaluation ! %OWNINTEGER COPY LEN ; !length of scanned literal %IF ITEM\=SCANNED LITERAL %THENSTART ! ! ! EVALUATE THE LITERAL IN THE INPUT STREAM ! ! LENGTH=NOT SET; %CYCLE; !until the matching quote is found ! %IF PTR>=BLEN %THENSTART; !at end of the record FAULT=NEW RECORD %IF FAULT>0 %THEN -> FAULT REPORTED PTR=BPTR %FINISH ! ! Examine the next character ! X=IO BUFFER(PTR) %AND PTR=PTR+1 %IF X=QUOTE %THENSTART %IF PTR=BLEN %OR X\=IO BUFFER(PTR) %THENEXIT PTR= PTR + 1 %FINISH ! ! Copy the next character ! %IF LENGTH<32768 %THEN COPY AREA(LENGTH)=X %AND LENGTH=LENGTH+1 ! %REPEAT; ! and repeat the cycle ! ITEM=SCANNED LITERAL ! ! Construct and save a descriptor to the literal ! COPY LEN= LENGTH %IF COPY LEN= NULL %THEN -> NULL LITERAL INVALID %FINISH; !evaluating the literal constant ! ! ! ASSIGN THE LITERAL TO THE I/O ITEM ! ! DATA INC= 0 %IF DATA TYPE\= A CHARACTER LAST DATA INC=DATA INC {in case the literal is repetitioned} DATA LEN=DATA BYTES I=DATA LEN-COPY LEN %IF I> 0 %THEN DATA LEN= COPY LEN COPY(DATA LEN,ADDR(COPY AREA(0)),0, DATA AD,DATA INC ) %IF I> 0 %THEN PROPAGATE( I ,DATA AD,DATA INC + DATA LEN,BLANK) ! %RESULT= 0 ! ! REPORT ERRORS ! FAULT REPORTED: %IF FAULT=INPUT ENDED %THEN BPTR =BLEN %C %AND FAULT=LITERAL NOT TERMINATED REPORT : %RESULT=FAULT NULL LITERAL INVALID: FAULT=INVALID CHARACTER CONSTANT; -> REPORT %END; !of IN LITERAL %END; !of IN ITEM %END; !of FREE FMTIO %HALFINTEGERFN OUT ITEM ! ! ! ! ! A UTILITY PROCEDURE TO OUTPUT A SCALAR OR AN ARRAY ELEMENT OR ! ! A WHOLE ARRAY ACCORDING TO THE VARIABLE TYPE, AND ! ! ACCORDING TO THE STANDARDS OF LIST-DIRECTED OUTPUT. ! ! ! %HALFINTEGERFNSPEC CHECK LENGTH (%HALFINTEGER BUFFER SPACE REQD) %HALFINTEGERFNSPEC OUT COMPLEX %HALFINTEGERFNSPEC OUT CHARACTER ! ! %CONSTHALFINTEGERARRAY INTEGER WIDTHS(0:2)= 6, 11, 20 %CONSTHALFINTEGERARRAY REAL WIDTHS(1:4)= 14, 22, 0, 37 %CONSTHALFINTEGERARRAY DECS PER SIZE(1:4)= 7, 15, 0, 30 ! ! %HALFINTEGER LEN ; !the field width reserved in the buffer for the value %HALFINTEGER SIZE ; !set to DATA BYTES/4 for Reals, Integers, and Complex !ie. 0=> bytes=2 ! 1=> bytes=4 ! 2=> bytes=8 ! 4=> bytes=16 %HALFINTEGER FAULT !Character Output: Under List-Directed I/O Character variables are output !without preceding or following value separators. Thus !before a Character variable is output the buffer pointer !is backspaced by one position to overwrite the last !separator. The buffer pointer is similarly backspaced !after the variable has been output so that a subsequent !value overwrites the separator that is put down. !However in the case of two (or more) Character variables !being output in succession the above strategy will result !in a significant character being overwritten. Thus the !following variable is used to decide whether to backspace !the pointer before outputting a Character variable. ! %OWNHALFINTEGER LAST TYPE A CHAR=FALSE {last I/O item was not of type CHARACTER} ! ! DETERMINE HOW TO OUTPUT A NON-NUMERIC VALUE ! %IF DATA TYPE= 5 %THENSTART FAULT= OUT CHARACTER %IF FAULT= 0 %THEN LAST TYPE A CHAR=TRUE %ANDRESULT=0 -> RETURN %FINISH {determine} {DATA SIZE} SIZE=DATA BYTES// 4 ! ! DETERMINE HOW TO OUTPUT A 'STANDARD' VALUE ! %IF DATA TYPE= A LOGICAL %THEN LEN =1 %ELSESTART %IF DATA TYPE=AN INTEGER %THEN LEN =INTEGER WIDTHS (SIZE) %C %ELSESTART; LEN = REAL WIDTHS (SIZE) DECIMALS= DECS PER SIZE (SIZE) %FINISH; %FINISH %CYCLE; !through each element of the current I/O item ! and output each in turn ! %IF DATA TYPE=A COMPLEX %THEN FAULT= OUT COMPLEX %ELSESTART ! {!otherwise check that } WIDTH=LEN {! there is buffer space} FAULT= CHECK LENGTH (WIDTH) %IF FAULT> 0 %THEN -> RETURN ! ! Output an Integer, Real, or Logical Value ! FAULT=OUT FORMAT; %FINISH %IF FAULT>0 %THEN -> RETURN {place the trailing delimiter} IO BUFFER (BPTR)= BLANK ! !note that BPTR is not incremented, this ! only happens if there is another ! I/O item in the list %EXIT %IF NUM DATA ITEMS<=1 ! NUM DATA ITEMS =NUM DATA ITEMS-1 ; !select the next DATA AD = DATA AD + DATA WORDS; ! element of BPTR = BPTR+1 ; ! an array %REPEAT ! ! RETURN: LAST TYPE A CHAR= FALSE %RESULT= FAULT %HALFINTEGERFN OUT CHARACTER ! ! ! ! ! A ROUTINE TO OUTPUT THE VALUE (or values) OF ! ! A CHARACTER VARIABLE FOR FREE FORMAT ! ! ! %INTEGER BUFFER LENGTH %INTEGER ITEM PTR %INTEGER WIDTH %HALFINTEGER FAULT %IF LAST TYPE A CHAR=FALSE %AND BPTR>BSTART+1 %THEN BPTR= BPTR-1 ! !NOTE: CHARACTER variables are to be output ! without preceding or following value ! separators. ITEM PTR = DATA INC {note displacement for start of 1st variable} %CYCLE; !OUTPUT A CHARACTER VARIABLE! ! FOR FREE FORMAT ! ! ! ! ! %UNLESS CHECK=FALSE %AND BYTE AT(DATA AD,DATA INC)= NOT SET %C %THEN %RESULT = UNASSIGNED VARIABLE ! WIDTH=DATA BYTES LOOP: !Check if the variable overflows the buffer! ! ! BUFFER LENGTH= BLEN - BPTR %IF BUFFER LENGTH< WIDTH %THENSTART ! ! Fill (the rest of) the Buffer ! COPY(BUFFER LENGTH,DATA AD,ITEM PTR,BSTART,BPTR) ITEM PTR = BUFFER LENGTH + ITEM PTR {Write Out The Full Buffer} BPTR=BLEN { } FAULT=NEW RECORD {----reinitialise it } {----and move the rest} -> FAULT REPORTED %UNLESS FAULT=NONE {---- of the variable } IO BUFFER(BPTR)=BLANK {---- into it } BPTR =1 %AND -> LOOP ! %FINISH; !if the variable is longer than the current buffer ! ! Now Move (the rest of) the Variable into the Buffer ! ! COPY(WIDTH,DATA AD,ITEM PTR,BSTART,BPTR) ITEM PTR= WIDTH + ITEM PTR ! ! Tidy Up ! BPTR= BPTR+WIDTH; !update the buffer pointer ! {and check if more variables} %EXIT %IF NUM DATA ITEMS<= 1 {repeat if more} NUM DATA ITEMS=NUM DATA ITEMS - 1 %REPEAT ! ! RETURN WHEN NO MORE VARIABLES ! BPTR=BPTR-1 %RESULT=0 ! ! RETURN WITH AN ERROR ! FAULT REPORTED: ! %RESULT= FAULT ! ! ! %END; !of OUT CHARACTER %HALFINTEGERFN OUT COMPLEX ! ! ! ! ! A LOCAL PROCEDURE WHICH OUTPUTS A COMPLEX VALUE IN FREE FORMAT ! ! ! ANSI 77 requires that complex values which are too long for an ! entire record, are split across a record boundary between the ! comma and the following imaginary part. This procedure takes ! this requirement into consideration. ! ! ! %HALFINTEGERFNSPEC WIDTH FOR (%INTEGER DATA AD) ! %HALFINTEGER LENGTH; !field width reserved for the complex value %HALFINTEGER WIDTH1; !field width reserved for the real part %HALFINTEGER WIDTH2; !field width reserved for the imaginary part %HALFINTEGER WIDTH3; !least width required for the complex value %INTEGER BUFF WIDTH ; !largest field available within the record size ! !Note that, if possible, the field width used is twice the ! field required for a real value plus space for the ! opening and closing bracket and the separating comma ! %HALFINTEGER SPACES REQD !to right-justify the value within the determined field %HALFINTEGER FAULT; !reported by CHECK LENGTH DATA WORDS= DATA WORDS >> 1 ! ! Determine the field widths for each complex part ! WIDTH1= WIDTH FOR (DATA AD) WIDTH2= WIDTH FOR (DATA AD + DATA WORDS) WIDTH3= WIDTH1 + WIDTH2 + 3; !=Width(imaginary part) + '(' !+Width(real part) + ',' + ')' LENGTH = LEN + LEN + 3 ! ! Compare Constant and Record Sizes ! BUFF WIDTH= BLEN-2; !allow for initial ' ' and final ',' %IF BUFF WIDTH< LENGTH %THENSTART %IF BUFF WIDTH<=WIDTH1 %THEN FAULT=RECORD TOO SMALL %AND -> RETURN ! ! Decide if an 'un-spaced' constant will fit wholely in the record ! %IF BUFF WIDTH< WIDTH3 %THEN LENGTH=WIDTH1+1 %ELSE LENGTH=BUFF WIDTH !Then no it wont Else yes it will %FINISH ! FAULT=CHECK LENGTH(LENGTH); !get a new record %IF FAULT>0 %THEN -> RETURN ; ! if we need one %IF CHECK\=FALSE %THENSTART ! ! Perform Unassigned Checking ! -> COMPLEX UNASSIGNED %C {machine } %IF UNASSIGNED CHECK (DATA AD , DATA WORDS)=TRUE %C {independent} %OR UNASSIGNED CHECK (DATA AD + DATA WORDS, { code} DATA WORDS)=TRUE %FINISH !performing unassigned checking ! ! Insert any leading spaces required to right-justify the value ! SPACES REQD= LENGTH-WIDTH3 %IF SPACES REQD> 0 %THENSTART ! FILL BUFF (SPACES REQD,BPTR,BLANK) BPTR= SPACES REQD+BPTR %FINISH; !inserting any leading spaces ! ! Now Output the Real Part ! IO BUFFER(BPTR)= '(' %AND BPTR=BPTR+1 WIDTH = WIDTH1 FAULT = OUT FORMAT; !--no fault expected IO BUFFER(BPTR)= ',' %AND BPTR=BPTR+1 ! ! Then Output the Imaginary Part ! %IF LENGTH=WIDTH1+1 %THENSTART ; !Check the imaginary FAULT=CHECK LENGTH(WIDTH2+1); ! part will fit if %IF FAULT>0 %THEN -> RETURN ; ! the value crosses %FINISH ; ! a record boundary DATA AD=DATA AD + DATA WORDS WIDTH=WIDTH2 FAULT=OUT FORMAT !(no fault expected) ! ! Finally Return ! IO BUFFER(BPTR)= ')' BPTR = BPTR+1 RETURN: DATA AD = DATA AD - DATA WORDS DATA WORDS= DATA WORDS + DATA WORDS %RESULT=FAULT ! ! Report UNASSIGNED VARIABLE ! COMPLEX UNASSIGNED: FAULT = UNASSIGNED VARIABLE %AND -> RETURN %HALFINTEGERFN WIDTH FOR (%INTEGER DATA AD) ! ! ! ! ! A LOCAL PROCEDURE WHICH RETURNS THE FIELD WIDTH TO BE USED ! ! TO OUTPUT A PART OF A COMPLEX VALUE. THE FACTORS ! ! INVOLVED ARE THE SCALE OF THE VALUE AND THE NUMBER ! ! OF SIGNIFICANT DIGITS REQUIRED. ! ! !It should be noted that the value will be output under a 'G' format ! which left justifies the value up to four places. This feature of ! 'G' format is unsatisfactory for complex values and necessitates a ! setting of the global variable WIDTH which will preclude any ! left justification. ! ! ! %HALFINTEGER WIDTH {the result returned}, SIGN {set to 1 if A is negative} {set to zero otherwise } %REAL A; !a copy of the value to be output ! ! Get a copy of the complex part ! A = REAL(DATA AD) ! %IF A< 0.0 %THEN A=-A %AND SIGN=TRUE %C %ELSE SIGN=FALSE ! ! Determine whether 'F' or 'E' formatting will be used ! %IF A>=POINT ONE %AND A EXTRA %THEN IO BUFFER(0)= BLANK %C %AND BPTR = 1 %C %ELSE FAULT = RECORD TOO SMALL %FINISH %RESULT= FAULT %END; !of CHECK LENGTH ! ! ! %END; !of OUT ITEM %HALFINTEGERFN UNASSIGNED CHECK ( %INTEGER DATA AD , %HALFINTEGER DATA WORDS ) ! ! ! ! ! THIS IS A UTILITY PROCEDURE TO PERFORM UNASSIGNED ! ! VARIABLE CHECKING IN A MACHINE-INDEPENDENT FORM. ! ! !Note: The data type is assumed NOT to be of type CHARACTER ! ! ! %IF DATA WORDS = 1 %THENSTART ! %RESULT=FALSE %IF HALFINTEGER(DATA AD)\=X'8080' %FINISHELSESTART; %RESULT=FALSE %IF INTEGER(DATA AD)\=X'80808080' %FINISH; %RESULT= TRUE ! ! %END; !of UNASSIGNED CHECK %HALFINTEGERFN IN FORMAT ! ! ! ! ! ! %HALFINTEGERFNSPEC ANALYSE %HALFINTEGERFNSPEC CHAR TO HEX ! ! {Input Field } %HALFINTEGER PTR {---scanning ptr through field} { Pointers} %HALFINTEGER COPY OF PTR {---ptr to the start of field} {Parms to TO REAL} %INTEGER INT LEN {---len and displacement of } { and TO INTEGER} %INTEGER INT PTR {--- number analsed into BUFFER} { Utility } %HALFINTEGER C ; !a character from the IO BUFFER { } %INTEGER N ; !a displacement into IO BUFFER { Variables } %INTEGER I ; !a work-variable {Z Format } %BYTEINTEGERARRAYNAME IO ITEM {to give byte access to I/O item} { Variables} %HALFINTEGER K { and a displacement into it } %HALFINTEGER BYTE COUNT ; !local copy of DATA BYTES %HALFINTEGER VARIABLE TYPE ; !local copy of DATA TYPE %HALFINTEGER FAULT ; != 0 => NO ERROR !=154 => RECORD TOO SMALL !=148 => INVALID CHARACTER !=141 => INVALID REAL !=140 => INVALID INTEGER != -1 => NUMBER INPUT IS TOO ! SMALL: 0.0 USED ! OR => NUMBER INPUT IS TOO ! LARGE: MAXIMUM USED %HALFINTEGER LENGTH ; !initially value of WIDTH %HALFINTEGER FORMAT ; !initially value of FMTCODE %INTEGER SCALE FACTOR ; !initially value of SCALE %HALFINTEGER DECS ; !initially value of DECIMALS ! %SWITCH FORMAT TYPE('A':'Z') ! ! INITIALISE VARIABLES ! FORMAT= FMTCODE LENGTH= WIDTH ! CHECK RECORD SIZE: PTR=BPTR BPTR= PTR+LENGTH %IF BPTR>BLEN %THENSTART ! !Check if the record is less than 80 bytes long ! and if it is then expand it by adding ! blanks onto the end. ! !Note: This does not apply to Internal Files ! -> RECORD TOO SMALL %IF BPTR>80 %OR FILE TYPE=5 ! %IF SYSTEM=EMAS %THENSTART ! ! Make a Copy of the Record first ! COPY(BLEN, BSTART,0, ADDR(BLANK BUFFER(0)),0) BSTART= ADDR(BLANK BUFFER(0)) IO BUFFER== ARRAY(BSTART, FORM A) %FINISH ! ! Space-Fill the Buffer up to 80 Bytes ! FILL BUFF (80-BLEN,BLEN,BLANK{s}) BLEN= 80 %FINISH; !if BPTR was greater than BLEN COPY OF PTR = PTR VARIABLE TYPE= DATA TYPE BYTE COUNT = DATA BYTES -> FORMAT TYPE (FORMAT) !*********************************************************************** ! ! HANDLE 'A' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('A'): DATA INC=0 %UNLESS DATA TYPE=A CHARACTER ! ! A FORMAT: N= LENGTH - BYTE COUNT %IF N> 0 %THEN PTR= PTR+N %AND LENGTH=BYTE COUNT %C %ELSE %C {space-fill I/O item} PROPAGATE (BYTE COUNT,DATA AD,DATA INC,BLANK) {if necessary} {then assign with the input} COPY (LENGTH,BSTART,PTR,DATA AD,DATA INC) -> EXIT !*********************************************************************** ! ! HANDLE 'A' FORMAT USED WITHOUT A WIDTH ! !*********************************************************************** ! FORMAT TYPE (A SPECIAL): LENGTH=BYTE COUNT FORMAT= 'A' -> CHECK RECORD SIZE !*********************************************************************** ! ! HANDLE 'G' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('G'): ! %IF VARIABLE TYPE=4 %THEN -> L FORMAT %IF VARIABLE TYPE=5 %THEN -> A FORMAT %IF VARIABLE TYPE=1 %THEN FORMAT= 'I' %AND -> I FORMAT !*********************************************************************** ! ! HANDLE 'D' FORMAT AND 'E' FORMAT AND 'F' FORMAT AND 'Q' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('D'): FORMAT TYPE ('E'): FORMAT TYPE ('F'): FORMAT TYPE ('Q'): ! %IF VARIABLE TYPE\=A REAL %THEN -> INCOMPATIBLE FORMAT FAULT !Note only ! REAL and COMPLEX types may F FORMAT: ! use 'D','E','Q','G' formats ! SCALE FACTOR= SCALE {get a copy of } DECS = DECIMALS { the formatting variables} {check the number} FAULT=ANALYSE -> SYNTAX FAULT %IF FAULT\= NONE ! ! CONVERT THE CHARACTERS INTO BINARY ! FAULT = TO REAL (DATA AD , DATA WORDS, ADDR(BUFFER(0)) , INT LEN , INT PTR , 0 , 0 , 0, 0, DECS , SCALE FACTOR, FIO MODE) %IF FAULT\= NONE %THEN -> FAULT REPORTED -> EXIT; !otherwise !*********************************************************************** ! ! HANDLE 'I' FORMAT ! !*********************************************************************** ! FORMAT TYPE ( I SPECIAL): FORMAT TYPE ('I'): ! %IF VARIABLE TYPE\=AN INTEGER %THEN -> INCOMPATIBLE FORMAT FAULT !only integers ! may be input with I format I FORMAT: FAULT = ANALYSE -> SYNTAX FAULT %IF FAULT\= NONE ! ! CONVERT THE CHARACTERS INTO BINARY ! FAULT = TO INTEGER (DATA AD, DATA WORDS, ADDR(BUFFER(0)), INT LEN,INT PTR, FIO MODE) -> FAULT REPORTED %IF FAULT\=NONE -> EXIT;!otherwise !*********************************************************************** ! ! HANDLE FREE FORMAT (for list-directed input) ! !*********************************************************************** ! FORMAT TYPE ('K'): ! %IF VARIABLE TYPE= A LOGICAL %THEN -> L FORMAT %IF VARIABLE TYPE=AN INTEGER %THEN FORMAT='I' %AND -> I FORMAT %C %ELSE FORMAT='F' %AND -> F FORMAT !*********************************************************************** ! ! HANDLE 'L' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('L'): !Enforce strict ANSI ! -> INCOMPATIBLE FORMAT %IF VARIABLE TYPE\=A LOGICAL L FORMAT: !"The input field consists of optional blanks, optionally : EXTRACT ! followed by a decimal point, followed by a T for true : FROM ! or F for false. The T or F may be followed by additional: FORTRAN77 ! characters in the field." : MANUAL ! ! SKIP OVER ANY OPTIONAL CHARACTERS ! C=IO BUFFER(PTR) %AND PTR=PTR+1 %UNTIL C\=' ' %OR PTR>=BPTR C=IO BUFFER(PTR) %AND PTR=PTR+1 %IF C ='.' %AND PTR< BPTR ! ! Now look for a T or F ! %IF C\= TRUE SIGN %THENSTART %IF C\=FALSE SIGN %THEN -> INVALID LOGICAL %C %ELSE C= FALSE %FINISHELSE C= TRUE ! ! Assign LOGICAL value to the I/O item ! %IF BYTE COUNT= 2 %THEN HALFINTEGER (DATA AD)= C %C %ELSE INTEGER (DATA AD)= C -> EXIT !*********************************************************************** ! ! HANDLE 'Z' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('Z'): ! ! ! Initialise Local Variables ! FAULT= NOT SET IO ITEM== ARRAY(DATA AD,FORM A) ! DATA INC= 0 %IF VARIABLE TYPE\=A CHARACTER ! ! Establish Ptrs (to IO BUFFER and I/O ITEM) ! K =(BYTE COUNT + BYTE COUNT) - LENGTH %IF K<= 0 %THEN PTR= PTR-K %AND K=DATA INC %C %ELSESTART; K=DATA INC + K>>1 ! %FOR I=DATA INC,1,K %CYCLE IO ITEM(I)= 0 %REPEAT %UNLESS LENGTH & 1= 0 %THEN C=0 %AND -> SECOND DIGIT %FINISH ! ! Perform Input ! FIRST DIGIT: C= CHAR TO HEX << 4 -> RETURN %IF FAULT\= NONE SECOND DIGIT: C= CHAR TO HEX ! C ! IO ITEM (K)= C K = K+1 -> RETURN %IF FAULT\= NONE %IF PTR < BPTR %THEN -> FIRST DIGIT -> EXIT ! !*********************************************************************** ! ! ERROR REPORTING ! !*********************************************************************** ! RECORD TOO SMALL: BPTR=BLEN %RESULT=RECORD TOO SMALL INCOMPATIBLE FORMAT: INCOMPATIBLE FORMAT FAULT: FAULT=INCOMPATIBLE FORMAT -> ERROR INVALID LOGICAL: !reported by L format FAULT= INVALID LOGICAL; -> RETURN SYNTAX FAULT: PTR = COPY OF PTR + 1 %C %IF PTR<= COPY OF PTR -> RETURN FAULT REPORTED: !report a detected error and set the error ptr (BPTR) ERROR : ! PTR= PTR + 1 RETURN : BPTR= PTR - 1 %RESULT= FAULT ! !*********************************************************************** ! ! END OF HANDLING INPUT FORMATS ! !*********************************************************************** ! ! ! EXIT: ! HERE NORMALLY ! %RESULT= 0 !*********************************************************************** ! ! ROUTINES FOR HANDLING INPUT FORMATS ! !*********************************************************************** ! %HALFINTEGERFN ANALYSE ! ! ! ! ! This Procedure Analyses the Number in the Input BUffer ! ! to determine (A) if the Syntax is correct, ! ! (B) the scale of the number ! ! and to remove all occurrences of signs, exponents, and decimal points ! ! !The following table represents values assigned to each ! character in the ISO Character Set. The assignments ! are made on the following basis: ! %CONSTHALFINTEGER Syntax Fault = 0 {for an invalid char}, A Blank = 1 {for ' ' }, A Digit = 2 {for '0' - '9' incl }, A Sign = 3 {for '+' , '-' }, A Decimal Point = 4 {for '.' }, A Lower Case Exp{onent}= 5 {for 'd' , 'e' , 'q'}, An Exponent = 6 {for 'D' , 'E' , 'Q'} %CONSTBYTEINTEGERARRAY TYPE (0:127)= Syntax Fault (32), A Blank { }, Syntax Fault (10), A Sign { + } , Syntax Fault , A Sign { - }, A Decimal Point { . } , Syntax Fault , A Digit {0-9} (10) , Syntax Fault (10), An Exponent {D,E} ( 2) , Syntax Fault (11), An Exponent { Q } , Syntax Fault (18), A Lower Case Exp {d,e} ( 2) , Syntax Fault (11), A Lower Case Exp { q} , Syntax Fault (14) ! ! %SWITCH HANDLE (Syntax Fault:An Exponent) ! ! Local Variables ! %HALFINTEGER D PTR ; !ptr to decimal digits in local buffer %HALFINTEGER E PTR ; !ptr to exponent digits in local buffer %HALFINTEGER E LEN ; !number of digits in the exponent %INTEGER E SIGN; !set zero of no exponent sign !set -ve if exponent sign='-' !set +ve if exponent sign='+' %INTEGER SIGN; !set zero if no numeric sign !set -ve if numeric sign='-' !set +ve if numeric sign='+' %HALFINTEGER B FLAG; ! if zero then leading spaces are to be ignored %INTEGER C ; !the current character being analysed %HALFINTEGER I ; !the scanning ptr through the local buffer %INTEGER LENGTH; !the number of digits specified ! %INTEGER S1 PTR, S2 PTR, S PTR ;!%C S1 PTR, S2 PTR are ptrs into the I/O buffer to positions %C where significant digits for the numeric %C and exponent parts respectively are expected {and S PTR points to the exponent character in the I/O buffer} ! ! Exponent Related Variables ! %INTEGER EXP ; !the exponent converted into binary %INTEGER MULT ; ! a multiplier used while converting the exponent %INTEGER J ; !--a utility variable ! ! Initialise Variables ! D PTR = NOT SET ; !=> no decimal point found E PTR = NOT SET ; !=> no exponent found E SIGN= NOT SET ; !=> no exponent sign found SIGN= NOT SET ; !=> no numeric sign found B FLAG= NOT SET ; !=> leading spaces are not significant I = NOT SET ; !=> no significant digits found ! S1 PTR = PTR; !used to determine a null numeric S2 PTR = PTR; ! or null exponent part ! ! ! ANALYSE THE NUMBER ! ! %WHILE PTR HANDLE(TYPE(C)) {and go and process it} HANDLE (Syntax Fault): ! Handle an ILLEGAL Character ! ! ! ! ! INVALID CHAR : %RESULT= INVALID CHARACTER INVALID REAL : %RESULT= INVALID REAL INVALID INTEGER: %RESULT= INVALID INTEGER NULL FIELD1 : PTR= S1 PTR %RESULT= NULL FIELD NULL FIELD2 : PTR= S2 PTR %RESULT= NULL FIELD HANDLE (A Blank): ! Handle a SPACE Character ! ! ! ! ! %CONTINUE %IF B FLAG= 0 %OR BLANKS=NULL {ignore insignificant blanks} ! {otherwise} C ='0' {and fall through} HANDLE (A Digit): ! Handle a DIGIT ! ! ! ! ! I=I+1; BUFFER(I)= C {save the digit} B FLAG = ON %CONTINUE HANDLE (A Sign): ! Handle a SIGN (it may signify an exponent) ! ! ! ! ! %IF E PTR=NOT SET %THENSTART %IF SIGN\=NOT SET {ie we have already had a sign} %OR %C I\=NOT SET {ie we have at least one digit} %THEN %C E SIGN= C %AND -> AN EXPONENT {otherwise} SIGN= C %AND S1 PTR= PTR %FINISHELSESTART {IF E PTR \=NOT SET %THENSTART} %IF E PTR \= I+1 {ie sign is embedded in an exponent} %ORC E SIGN\=NOT SET {ie we have an exponent sign already} %C %THEN -> INVALID REAL E SIGN = C S2 PTR = PTR %FINISH %CONTINUE HANDLE (A Decimal Point): ! Handle a DECIMAL part ! ! ! ! ! -> INVALID INTEGER %IF FORMAT='I' -> INVALID REAL %IF D PTR\= 0 %C %OR E PTR\= 0 B FLAG= SET {save any embedded blank} D PTR = I+1 {note the decimal point} %CONTINUE HANDLE (A Lower Case Exp{onent}): ! Handle a Lower Case Exponent ! ! ! ! ! -> INVALID CHAR %IF CASE=UPPER {only} C=C-' ' {convert to upper case} HANDLE (An Exponent): ! Handle an EXPONENT ! AN EXPONENT : ! ! ! ! -> INVALID CHAR %IF C='Q' %AND RELAX ANSI=FALSE -> INVALID INTEGER %IF FORMAT='I' -> INVALID REAL %IF E PTR\=NOT SET E PTR = I+1 B FLAG= OFF S2 PTR= PTR %AND S PTR= PTR %REPEAT; !for the next character LENGTH= I ! ! ANALYSE THE ANALYSIS ! %IF E PTR\=NOT SET %THENSTART ! ! Analyse the given Exponent ! %IF E PTR>LENGTH %THENSTART -> NULL FIELD2 %IF BLANKS=NULL %C %OR S2 PTR= PTR %FINISH E LEN=LENGTH - (E PTR-1) LENGTH= E PTR - 1 PTR= S PTR - 1 ! ! Convert the given Exponent into Binary ! %IF E LEN> 9 %THENSTART ! !Use the Integer Conversion Routine for Large Exponents ! J=TO INTEGER(ADDR(EXP),2,ADDR(BUFFER(0)), E LEN,E PTR,0 ) %FINISHELSESTART ! EXP = 0 %IF E LEN > 0 %THENSTART ! MULT=10 ** ** (E LEN - 1) %WHILE MULT> 0 %CYCLE EXP = EXP + (MULT * (BUFFER(E PTR) - NOUGHT)) E PTR = E PTR+ 1 MULT= MULT//10 %REPEAT %FINISH; %FINISH ! %IF EXP>32767 %THEN EXP= 32767 %IF E SIGN='-' %THEN EXP= -EXP ! SCALE FACTOR= -EXP %FINISH !Handling an Exponent ! ! Analyse the (rest of the) Number ! %IF LENGTH=NULL %THENSTART ! -> NULL FIELD1 %IF S1 PTR = PTR - D PTR %OR %C (S1 PTR\=S2 PTR - D PTR %AND BLANKS=NULL) %FINISH %IF D PTR\=NULL %THEN DECS=LENGTH - (D PTR-1) ! ! Prepare to Call a Numeric Conversion Routine ! %IF SIGN\= NOT SET %THENSTART ! {set parameters} BUFFER(0)= SIGN; INT PTR= 0 {for a call on } INT LEN= LENGTH+1 { TO REAL } %FINISHELSESTART; INT LEN= LENGTH { or on } INT PTR= 1 { TO INTEGER} %FINISH %RESULT= 0 %END; !of ANALYSE %HALFINTEGERFN CHAR TO HEX ! ! CONVERT NEXT INPUT CHARACTER INTO A HEXADECIMAL DIGIT ! %HALFINTEGER X X= IO BUFFER(PTR) %AND PTR= PTR + 1 %IF NOUGHT<=X<='9' %THENRESULT= X - NOUGHT %C %ELSESTART %IF 'A'<=X<='F' %THENRESULT= X - '7' %C %ELSESTART %IF X\=BLANK %THEN FAULT= 148 %FINISH %FINISH %RESULT= 0 %END; !of CHAR TO HEX %END; !of IN FORMAT ! ! ! ! ! Modified 25/ 2/81 10.00 ! ! ! ! ! ! ! ! !*********************************************************************** !*********************************************************************%C %C %C A SET OF NUMBER CONVERSION ROUTINES (version 1.0) %C %C FOR THE FORTRAN COMPILER AND RUN-TIME SYSTEM %C %C when running on ICL PERQs %C %C %C !*********************************************************************%C !*********************************************************************** !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! !CONSTHALFINTEGER NONE= 0 !CONSTHALFINTEGER NULL= 0 %CONSTHALFINTEGER A MINUS= 0 ; !values used internally %CONSTHALFINTEGER A PLUS = 1 ; ! to indicate a positive or negative value is reqd ! ! Modes of operation ! !CONSTHALFINTEGER FIO MODE= 0; !the mode determines %CONSTHALFINTEGER COMPILER MODE= 1; ! the action to be !CONSTHALFINTEGER DEBUG MODE= 2; ! taken when a constant !CONSTHALFINTEGER FIO PLUS MODE= 3; ! is out of range {---and errors given} %CONSTHALFINTEGERARRAY ERROR NO (1:3) %C = 20 , 338 , 188 !these numbers are a function of MODE and correspond ! to a message of the form: CONSTANT OUT OF RANGE %HALFINTEGERFN TO INTEGER %C (%INTEGER DATA AD , DATA LEN , %INTEGER TEXT ADDRESS, TEXT LEN , TEXT INC , MODE) ! ! ! ! ! THIS IS A PROCEDURE TO CONVERT A STRING OF CHARACTERS (which ! ! have been analysed syntactically) INTO AN INTEGER VALUE. ! ! !The character string is assumed to be in an area addresses by TEXT !ADDRESS, and is defined by the parameters TEXT LEN and TEXT INC which !identify the length and start (relative to TEXT ADDRESS) of the string !respectively. At exit the result is stored in the location defined by !the parameters DATA AD and DATA LEN which identify the address and the !length (in {16 bit} words) of the result location. ! ! !NOTE1: It is assumed that there are no leading, embedded or trailing blanks !NOTE2: The string of digits is assumed to represent a valid integer ! ! ! At Exit: RESULT= 0 if the constant was within range ! RESULT= 20 if the constant was out of range and MODE=1 ! RESULT=338 if the constant was out of range and MODE=2 ! RESULT=188 if the constant was out of range and MODE=3 ! ! ! %CONSTINTEGERARRAY MAXIMUM OF (1:2)= -32768, X'80000000' ! !the values above represent the largest ! values that may be assigned to an ! INTEGER*2 and INTEGER*4 respectively !Text of the Largest Negative Integer: ! %CONSTSTRING(10) LARGEST INTEGER= {-}"2147483648" ! ! Variables used to Address the Digits ! %BYTEINTEGERARRAYNAME TEXT %BYTEINTEGERARRAYFORMAT TEXT FORMAT (0:32767) %HALFINTEGER PTR {scanning ptr through TEXT } %HALFINTEGER MAX PTR { maximum value PTR may have} %HALFINTEGER LEN ;!%C LEN is the actual number %C of significant digits in the TEXT ! ! Variables used to Convert the Digits to Binary ! %HALFINTEGER SIGN ; !set +ve if value is positive, else set to zero %INTEGER MULT ; !scaling to be applied to the next digit %INTEGER SUM ; !the binary result %HALFINTEGER I {a utility variable} ! ! Initialise Addressibility ! TEXT== ARRAY(TEXT ADDRESS, TEXT FORMAT) ! PTR= TEXT INC ; !initialise the scanning ptr MAX PTR= TEXT LEN + PTR; !initialise its maximum value ! ! Check for a Sign ! SIGN= TEXT (PTR) %IF SIGN< '0' %THENSTART %IF SIGN='+' %THEN SIGN=A PLUS %C %ELSE SIGN=A MINUS PTR=PTR+1 %FINISH %ELSE SIGN=A PLUS ! ! Check Magnitude of the Value ! LEN= MAX PTR - PTR %IF LEN> 9 %THENSTART {chance of Integer Overflow later} ! ! Skip any Leading Spaces or Zeros ! A: I=TEXT(PTR) %IF I=' ' %OR I='0' %THEN PTR= PTR + 1 %AND -> A LEN= MAX PTR - PTR -> INTEGER OVERFLOW %IF LEN> 10 -> SIMPLE APPROACH %IF LEN< 10 ! ! Now Test for Integer Overflow (when there are 10 digits) ! I=COMPARE(10,TEXT ADDRESS,PTR,ADDR(LARGEST INTEGER),1) -> INTEGER OVERFLOW %C %IF I+SIGN> 0 %FINISH SIMPLE APPROACH: SUM=0; %IF LEN>0 %THENSTART ! ! Now Convert the Text into Binary ! MULT=-10 ** ** (LEN-1) %WHILE MULT< 0 %CYCLE ! SUM = SUM + (MULT * (TEXT(PTR) - '0')) PTR = PTR + 1 MULT= MULT//10 %REPEAT SUM = -SUM %UNLESS SIGN=A MINUS %FINISH %IF DATA LEN= 1 {word} %THENSTART ! ! ! Assign the Value to an INTEGER*2 ! ! %IF SIGN=A MINUS %THENSTART %IF SUM<-32768 %THEN -> INTEGER OVERFLOW %FINISH %ELSE %IF SUM> 32767 %THEN -> INTEGER OVERFLOW ! ! {Perform the Assignment} HALFINTEGER(DATA AD)= SUM %FINISHELSESTART ! ! ! Assign the Value to an INTEGER*4 ! ! INTEGER(DATA AD)= SUM ! %FINISH %RESULT= 0 {return with no errors} INTEGER OVERFLOW: !check if this is a fault ! %IF MODE\= 0 %THENRESULT= ERROR NO (MODE) {if it is a fault} ! ! Set Data Item to Maximum Permitted Value ! SUM= MAXIMUM OF (DATA LEN) SUM=-(SUM+1) %IF SIGN=A PLUS ! %IF DATA LEN= 1 %THEN HALFINTEGER(DATA AD)= SUM %C %ELSE INTEGER(DATA AD)= SUM ! %RESULT= 0 %END; !of TO INTEGER %HALFINTEGERFN TO REAL (%INTEGER DATA AD , DATA LEN , %INTEGER TEXT ADDRESS , %INTEGER INT LEN , INT PTR , %INTEGER DEC LEN , DEC PTR , %INTEGER EXP LEN , EXP PTR , DECS , %INTEGER SCALE FACTOR , MODE ) ! ! ! ! ! THIS PROCEDURE CONVERTS A STRING OF CHARACTERS (which have been ! ! analysed syntactically) INTO A FLOATING POINT NUMBER. ! ! !The character string is assumed to be in an area addressed by TEXT !ADDRESS, and is defined by the set of parameters INT LEN, INT PTR, !DEC LEN, DEC PTR, EXP LEN, EXP PTR which identify the length and !start (relative to TEXT ADDRESS) of the characters: ! %C (a) before the decimal point %C (b) after the decimal point %C and (c) which make up the value of the exponent ! !Should any of these parts not exist in the number then the relevant !LEN (length) parameter will be set to zero. The parameter DECIMALS !defines the implied positioning of the decimal point should no decimal !point be specified: while the parameter SCALE FACTOR defines the !exponentiation to be applied to the result if an exponent was not !specified. The result is saved in the location defined by DATA AD and !DATA LEN which specify its address and length (in {16 bit} words) !respectively. ! ! !NOTE1: There are no embedded or trailing blanks !NOTE2: It is assumed that there are no leading spaces !NOTE3: The character string is assumed to represent a ! valid floating point number ! ! ! At Exit: RESULT= 0 if the constant was within range ! RESULT= 20 if the constant was out of range and MODE=1 ! RESULT=338 if the constant was out of range and MODE=2 ! RESULT=188 if the constant was out of range and MODE=3 ! ! ! %CONSTSTRING(8) LARGEST POSSIBLE= "34028234" ! !---a representation, in ISO digits of ! the 8 most significant digits of ! the largest possible real value ! ! Variables used to Address the Digits ! %BYTEINTEGERARRAYNAME TEXT %BYTEINTEGERARRAYFORMAT TEXT FORMAT (0:32767) %HALFINTEGER PTR {scanning ptr through TEXT } %HALFINTEGER MAX PTR { maximum value PTR may have} %INTEGER LEN ;!%C LEN is the actual number %C of significant digits in the TEXT ! ! Variables associated with the Scale of the Number ! %INTEGER VAL SIZE; !scale of the leftmost significant digit %INTEGER EXP ; !scale of the rightmost significant digit %HALFINTEGER SIGN; ! sign of the value, either=A MINUS, or=A PLUS ! ! Variables used in Numeric Conversion ! %INTEGER MULT ; !scaling to be applied to the next digit %INTEGER SUM ; ! binary integer value of the digits bar scaling %REAL X ; ! actual Real result %HALFINTEGER I {a utility variable} TEXT== ARRAY(TEXT ADDRESS, TEXT FORMAT) ! !Initialise addressibility %UNLESS EXP LEN=NONE %THENSTART ! ! Examine the Exponent Specified ! %IF EXP LEN> 9 %THENSTART ! !Use the Integer Conversion Routine for Large Exponents ! I= TO INTEGER (ADDR(EXP),2,TEXT ADDRESS, EXP LEN,EXP PTR,0) %FINISHELSESTART ! ! Look for an Exponent Sign ! SIGN= TEXT(EXP PTR) %IF SIGN<'0' %THENSTART %IF SIGN='+' %THEN SIGN=A PLUS %C %ELSE SIGN=A MINUS ! EXP PTR=EXP PTR+1 EXP LEN=EXP LEN-1 %FINISH %ELSE SIGN=A PLUS ! ! Now Convert the Exponent into Binary ! EXP = 0 MULT=10 ** ** (EXP LEN-1) %WHILE MULT> 0 %CYCLE ! EXP = EXP + (MULT * (TEXT(EXP PTR) - '0')) EXP PTR = EXP PTR + 1 MULT= MULT//10 %REPEAT EXP=-EXP %IF SIGN=A MINUS %FINISH %FINISHELSE EXP=-SCALE FACTOR {only if no exponent was specified} ! EXP=EXP-DECS %IF DEC LEN=0 !invoke implied decimal point if none was given ! ! ! Examine the Number ! ! SIGN=A PLUS {guess} ! %IF INT LEN>0 %THENSTART ! ! Look for a Numeric Sign ! SIGN= TEXT(INT PTR) %IF SIGN<'0' %THENSTART %IF SIGN='-' %THEN SIGN=A MINUS INT LEN=INT LEN-1 INT PTR=INT PTR+1 ! %FINISH %FINISH %IF MODE=COMPILER MODE %THENSTART ! ! Append Integer and Decimal Parts Together (in a work-area) ! COPY(INT LEN,TEXT ADDRESS,INT PTR, ADDR(BUFFER(0)), 1 ) %IF INT LEN>0 COPY(DEC LEN,TEXT ADDRESS,DEC PTR, ADDR(BUFFER(0)),INT LEN+1) %IF DEC LEN>0 TEXT==ARRAY (ADDR(BUFFER(0)),TEXT FORMAT) %FINISH PTR= 1; MAX PTR= INT LEN + DEC LEN ! ! Ignore Leading and Trailing Zeros ! PTR= PTR+1 %WHILE MAX PTR>=PTR %AND TEXT(PTR)='0' !ignore any leading zeros MAX PTR=MAX PTR-1 %AND %C EXP= EXP+1 %WHILE MAX PTR>=PTR %AND TEXT(MAX PTR)='0' !ignore any trailing zeros ! ! Determine the Magnitude of the Value ! LEN=MAX PTR - (PTR-1) %IF LEN> 8 %THENSTART ! ! Ignore any digits which have no bearing on the result ! EXP= EXP + (LEN-8) LEN= 8 %FINISH VAL SIZE=EXP + (LEN-1); !NOTE: LEN=number of significant digits ! ! EXP= scale of rightmost digit ! ! VAL SIZE= scale of leftmost digit %IF VAL SIZE> 37 %OR %C VAL SIZE<-36 %THEN -> FURTHER EXAMINATION !Jump if ! the value is around or beyond ! the capabilities of the code below FORM RESULT: ! ! ! Perform the Conversion ! ! %IF LEN<= 0 %THEN X=0.0 %C %ELSESTART ! ! Convert the Value First into an Integer ! SUM = 0 MULT=10 ** ** (LEN-1) %WHILE MULT> 0 %CYCLE ! SUM = SUM + (MULT * (TEXT(PTR) - '0')) PTR = PTR + 1 MULT= MULT//10 %REPEAT ! !---Now Convert into a Real and Apply Scaling ! X= SUM * POWERS OF TEN (EXP); %FINISH RETURN RESULT: {!assign the value to the variable} X=-X %IF SIGN=A MINUS ! REAL (DATA AD)= X %RESULT=0 FURTHER EXAMINATION: !required for very large or for very small ! values before conversion can be ! attempted ! %IF VAL SIZE< -37 %THEN -> VALUE TOO SMALL %IF VAL SIZE>= 38 %THENSTART %IF VAL SIZE = 38 %THENSTART ! ! Compare Digits with the Largest Possible Real ! -> VALUE TOO LARGE %C %IF COMPARE (LEN,TEXT ADDRESS,PTR, ADDR(LARGEST POSSIBLE),1)>0 %FINISHELSE %C {!} %C %IF LEN=0 %THEN -> VALUE TOO SMALL %C %ELSE -> VALUE TOO LARGE %FINISH %IF EXP< -37 %THENSTART ! ! Ignore digit which will have no effect on the Result ! LEN = LEN + (37+EXP) EXP = -37 %FINISH -> FORM RESULT ! ! HANDLE NUMBERS OUT OF THE PERMITTED RANGE ! VALUE TOO SMALL: X= 0.0 ; -> CHECK MODE VALUE TOO LARGE: X=LARGEST REAL; ! CHECK MODE : %IF MODE\=0 %THENRESULT=ERROR NO (MODE) !=> it is a fault -> RETURN RESULT ! ! ! %END; !of TO REAL %HALFINTEGERFN OUT FORMAT ! ! ! ! ! %ROUTINESPEC OUTPUT Z FORMAT %REALFNSPEC INTO RANGE (%REAL VALUE) ! ! ! %CONSTINTEGERARRAY MIN PER WIDTH (0:10)= 0, -9, -99, -999, -9999, -99999, -999999, -9999999, -99999999, -999999999, X'80000000' ! !Each array element corresponds to a value of ! WIDTH, and denotes the largest negative ! integer that may be formatted given that ! value of WIDTH ! ! ! POINTERS ! %INTEGER AREA PTR ; !Ptr used to save numerals in the work-area %INTEGER PTR ; !Ptr used to construct a value in the output field %INTEGER PTR MAX ; !addresses the end of the output field (+1) ! ! %HALFINTEGER IO ITEM {FORTRAN type of } %HALFINTEGER DATA LEN { the I/O item} %HALFINTEGER FORMAT {Variables } %HALFINTEGER DECS { describing } %HALFINTEGER SCALE FACTOR { the format } %HALFINTEGER LENGTH { code} %REAL A {REAL value to format } %HALFINTEGER SIGN {='+' or '-' or NONE } %HALFINTEGER EXP {scale of the value to be formatted } %HALFINTEGER ROUNDING {scale of the rounding to be applied} %INTEGER I {INTEGER value to format} %INTEGER M {a scale factor} %INTEGER Q {a quotient } %HALFINTEGER N {a utility variable} %HALFINTEGER MAX INT DIGITS {max digits allowed left of '.'} %HALFINTEGER INT DIGITS {no of digits reqd left of '.' } %HALFINTEGER LEADING ZEROS {no of zeros reqd left of '.' } %HALFINTEGER TOTAL CHARS {no of digits reqd on both sides of '.'} %HALFINTEGER EXPONENT {value of an exponent } %HALFINTEGER EXP TYPE {='D' or 'E' or 'Q' or NONE} %HALFINTEGER EXP LENGTH {no of digits reqd in formatted exponent} ! %CONSTHALFINTEGER MAX SCALE= 36 !=the highest power of ten that may ! be applied to a rounding factor %SWITCH FORMAT TYPE('A':'Z') ! ! INITIALISE VARIABLES ! LENGTH = WIDTH LENGTH = DATA BYTES %IF LENGTH=NIL PTR =BPTR PTR MAX= PTR + LENGTH ! %IF PTR MAX>BLEN %THENSTART %IF BPTR>BLEN %THEN BPTR=MAXBPTR ! %RESULT = RECORD TOO SMALL %FINISH ! {copy details of the I/O item} IO ITEM= DATA TYPE DATA LEN = DATA BYTES ! ! SPACE FILL THE OUTPUT BUFFER ! FILL BUFF (LENGTH,PTR,BLANK) %IF CHECK\=FALSE %AND FMTCODE\='Z' %THENSTART ! ! PERFORM UNASSIGNED CHECKING ! %IF IO ITEM=A CHARACTER %THENSTART ! -> UNASSIGNED VARIABLE %IF BYTE AT (DATA AD , DATA INC)=NULL %FINISHELSESTART ! ! Test for an unassigned INTEGER or REAL or COMPLEX or LOGICAL ! %IF UNASSIGNED CHECK(DATA AD,DATA LEN)=TRUE %THEN -> UNASSIGNED VARIABLE ! %FINISH %FINISH FORMAT =FMTCODE ! %IF 'D'<=FORMAT<='J' %OR %C FORMAT ='Q' %THENSTART; !NUMERIC FORMATTING IS REQUIRED %IF FORMAT ='G' %THENSTART ! %IF RELAX ANSI\=FALSE %THENSTART ! %IF IO ITEM= A CHARACTER %THEN -> A FORMAT %IF IO ITEM= A LOGICAL %THEN -> L FORMAT %IF IO ITEM=AN INTEGER %THEN FORMAT='I' %FINISHELSESTART %IF IO ITEM\=A REAL %THEN -> FAULT 155 %FINISH %FINISHELSESTART; %IF IO ITEM=A CHARACTER %THEN -> FAULT 155 %FINISH ! ! ! PICK UP THE VALUE TO BE FORMATTED NUMERICALLY ! ! %IF IO ITEM=A REAL %THENSTART ! LOAD UP A REAL VALUE: A= REAL(DATA AD) + 0.0 {to normalise} %FINISHELSESTART ! %IF IO ITEM=AN INTEGER %THENSTART ! LOAD UP AN INTEGER VALUE: ! Get an INTEGER*4 or INTEGER*2 ! %IF DATA LEN=2 %THEN I=HALFINTEGER(DATA AD) %C %ELSE I= INTEGER(DATA AD) -> I FORMAT %IF FORMAT='I' %C %OR FORMAT= I SPECIAL -> INCOMPATIBLE FORMAT {otherwise} %FINISHELSE -> INCOMPATIBLE FORMAT %FINISH ! ! HANDLE A NEGATIVE VALUE ! %IF A<0.0 %THEN A=-A %AND SIGN=MINUS %C %ELSE SIGN=PLUS SIGN LENGTH= LENGTH -1 %UNLESS SIGN=NONE ! ! INITIALISE WORK-AREA VARIABLES ! AREA PTR= 0 {displacement into OUTPUT AREA} EXP= 1 %FINISH; !preparing for numeric formatting -> FORMAT TYPE (FORMAT) !*********************************************************************** ! ! HANDLE 'A' FORMAT (with or without a WIDTH) ! !*********************************************************************** ! FORMAT TYPE ( A SPECIAL): FORMAT TYPE ('A'): DATA INC= 0 %IF DATA TYPE\=A CHARACTER ! A FORMAT: N=LENGTH - DATA LEN LENGTH = DATA LEN %AND PTR= PTR+N %IF N>0 COPY ( DATA LEN, DATA AD,DATA INC,BSTART,PTR) -> EXIT !*********************************************************************** ! ! HANDLE 'D' FORMAT AND 'E' FORMAT AND 'Q' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('D'): FORMAT TYPE ('E'): FORMAT TYPE ('Q'): %IF IO ITEM\=A REAL %THEN -> INCOMPATIBLE FORMAT D FORMAT: ! {!Examine the scale factor} DECS= DECIMALS ! SCALE FACTOR= SCALE %IF SCALE FACTOR> 0 %THENSTART {adjust the } ROUNDING= DECS + 1 { DECIMALS} DECS= ROUNDING - SCALE FACTOR { field } %IF DECS< 0 %THEN -> SCALING INVALID %FINISHELSESTART ;!%C %IF SCALE FACTOR<=0 %THENSTART {determine } ROUNDING = DECS + SCALE FACTOR { the } %IF ROUNDING<= NONE %THENSTART { rounding} ! { factor } -> SCALING INVALID %IF SCALE FACTOR\=NONE %FINISH ; %FINISH ! %IF IMOD(ROUNDING)>MAX SCALE %THEN ROUNDING=MAX SCALE ! %IF A=0.0 %THEN EXPONENT=NONE %C %AND EXP =NONE %ELSESTART !Bring the value into the range: 10.0> A >=1.0 ! A= INTO RANGE (A) + 5.0/POWERS OF TEN(ROUNDING) %IF A> 10.0 %THENSTART ; !apply rounding A=A/10.0; !apply correction EXP=EXP+1 ; ! if rounding took value back out of range %FINISH EXPONENT= EXP-SCALE FACTOR; !determine the value of the exponent part EXP=SCALE FACTOR; %FINISH ! ! Determine the sub-field required for the exponent ! %IF EXP WIDTH>0 %THEN EXP LENGTH= EXP WIDTH + 2 %C %ELSE EXP LENGTH= 4 != number of characters required ! to represent the exponent ! ! PRODUCE THE DECIMAL PART ! LENGTH= LENGTH - EXP LENGTH; FORMAT= 'D' ! -> COLLECT DIGITS !expect a return with DR pointing to ! the remainder of the output field !OUTPUT THE EXPONENT: OUTPUT THE EXPONENT: {ANALYSE THE EXPONENT TO FORMAT} !OUTPUT THE EXPONENT: I= EXPONENT %IF I< 0 %THEN SIGN= MINUS %C %ELSE SIGN= PLUS %AND I= -I %IF EXP WIDTH>0 %THENSTART ! !---the edit code is of the form Ew.dEe ! -> WIDTH TOO SMALL %IF EXP WIDTH < 10 %C %AND MIN PER WIDTH (EXP WIDTH+1)> I %FINISHELSESTART ! ! edit code is of the form Ew.d ! %IF I<-99 %THENSTART %IF I < -999 %THEN -> WIDTH TOO SMALL -> SKIP EXP TYPE %FINISH ! !IF 994 %THENSTART %IF DATA LEN>8 %THEN EXP TYPE= 'Q' %C %ELSE EXP TYPE= 'D' %FINISHELSE EXP TYPE= 'E' ! {and write it into the field} IO BUFFER(PTR)=EXP TYPE PTR= PTR +1 ! EXP LENGTH= EXP LENGTH -1 ! SKIP EXP TYPE: !only if the exponent form is '+zzz' or '-zzz' ! ! Determine formatting control variables ! EXP= EXP LENGTH -1 %IF EXP> 9 %THEN LEADING ZEROS= EXP-9 %AND EXP= 9 %C %ELSE LEADING ZEROS=NONE ! {PERFORM FORMATTING} -> FORMAT AN EXPONENT; !(see Iw.m) !*********************************************************************** ! ! HANDLE 'F' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('F'): ! %IF IO ITEM\=A REAL %THEN -> INCOMPATIBLE FORMAT DECS=DECIMALS; %IF A\= 0.0 %THENSTART ! ! !Initialise Variables! ! ! SCALE FACTOR = SCALE ROUNDING = SCALE FACTOR + DECS %IF IMOD(ROUNDING)> MAX SCALE %THEN ROUNDING=MAX SCALE ! ! APPLY ROUNDING AND BRING THE VALUE INTO THE RANGE 10.0> A >=1.0 ! A = INTO RANGE( A + 0.5/POWERS OF TEN(ROUNDING) ) EXP = EXP +SCALE %C FACTOR %FINISHELSE EXP=0; !if A=0.0 COLLECT DIGITS: ! %IF EXP<=(-DECS) %AND SIGN=MINUS %THENSTART ! !----only zeros will be printed, !------so ensure that no minus will be printed too ! SIGN= PLUS SIGN LENGTH=LENGTH+1 %IF SIGN= NONE %FINISH ! ! ! DETERMINE THE VARIABLES WHICH CONTROL FORMATTING ! ! MAX INT DIGITS= LENGTH - DECS - 1 ; != number of digits that %IF MAX INT DIGITS< 0 %THEN -> WIDTH TOO SMALL; ! may be output left ! of the decimal pt. INT DIGITS= EXP %IF INT DIGITS> MAX INT DIGITS %THEN -> WIDTH TOO SMALL ! !INT DIGITS is the number of digits that are ! required to the left of the decimal point %IF INT DIGITS<=0 %THENSTART ! ! Determine how many leading zeros are required if value is < 1.0 ! %IF MAX INT DIGITS=NONE %THENSTART ! %IF INT DIGITS=DECS %THEN -> WIDTH TOO SMALL ! (otherwise no significant digits ! will be produced in the field) ! LEADING ZEROS= -INT DIGITS %AND INT DIGITS= NONE %FINISHELSE LEADING ZEROS=1-INT DIGITS %AND INT DIGITS= 1 TOTAL CHARS= INT DIGITS - LEADING ZEROS + DECS GENERATE LEADING ZEROS: !in the work area ! PROPAGATE (LEADING ZEROS,ADDR(OUTPUT AREA(0)),0,NOUGHT) AREA PTR= LEADING ZEROS %FINISHELSESTART; ! ! Determine total number of numerals required if value>=1.0 ! TOTAL CHARS= INT DIGITS + DECS %FINISH FORMAT DIGITS: ! ! ! CONVERT VALUE TO CHARACTERS (using machine ! independent code) ! %WHILE TOTAL CHARS> 0 %CYCLE TOTAL CHARS= TOTAL CHARS - 1 ! N = INT PT (A) A = 10.0*(A - N) OUTPUT AREA(AREA PTR)= NOUGHT + N AREA PTR = AREA PTR + 1 ! %REPEAT ! ! ! FORM THE FORMATTED VALUE IN THE OUTPUT FIELD ! ! PTR= PTR + (MAX INT DIGITS - INT DIGITS) ! !point to where the first significant char should go ! %IF SIGN\=NONE %THENSTART ! ! Move in a Sign ! IO BUFFER(PTR)= SIGN PTR =PTR+1 %FINISH ! ! Write out the digits to the left of the decimal point ! COPY(INT DIGITS,ADDR(OUTPUT AREA(0)),0,BSTART, PTR) AREA PTR= INT DIGITS PTR= PTR + INT DIGITS -> FINALISE FORMATING %IF FORMAT>='I' ! ! Write out the decimal point ! IO BUFFER(PTR)=DOT PTR =PTR+1 ! ! Write out the digits to the right of the decimal point ! %IF DECS>0 %THENSTART COPY(DECS,ADDR(OUTPUT AREA(0)),AREA PTR,BSTART,PTR) %FINISH FINALISE FORMATING: ! %IF FORMAT='D' %THEN -> OUTPUT THE EXPONENT ! !Jump if format code is 'D' or 'E' or 'Q' and continue ! to format the exponent characteristic -> EXIT !*********************************************************************** ! ! HANDLE 'G' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('G'): DECS= DECIMALS ! %IF DECS>MAX SCALE+1 %OR POINT ONE<=A 0 %AND DECS<=MAX SCALE %THENSTART A = A + 5.0/POWERS OF TEN(DECS) %IF A>=10.0 %THENSTART A= A/10.0; !apply correction if rounding put EXP=EXP+1 ; ! the value back out of range %FINISH; %FINISH; %FINISH; ! ! Determine actual WIDTH and DECIMALS to use ! %IF EXP WIDTH>0 %THEN EXP LENGTH= EXP WIDTH + 2 %C %ELSE EXP LENGTH= 4 N =LENGTH - DECS - 1 !number of surplus characters in the field %IF N>=EXP LENGTH %THEN LENGTH = LENGTH - EXP LENGTH %C %ELSESTART %IF FMTCODE\=FREE FORMAT %THEN -> WIDTH TOO SMALL %FINISH !The formatted value should be left-justified by EXP LENGTH spaces ! which have to come from N (number of surplus characters). ! If these spaces are not available a fault is reported unless ! free format I/O is being used. ! DECS= DECS - EXP FORMAT= 'F' -> COLLECT DIGITS ! ! %FINISH ! ! OUTPUT THE NUMBER WITH AN EXPONENT ! -> D FORMAT ; !GO AND LET 'D' FORMATING ! DO ALL THE WORK !*********************************************************************** ! ! HANDLE 'I' FORMAT -----INCLUDING Iw.m ! !*********************************************************************** ! ! ! !NOTE on PERQ's maximum precision is currently ! available under INTEGER*4. Thus until ! Double Precision REALs become generally ! available the code below is expected to ! be temporary. FORMAT TYPE ( I SPECIAL): FORMAT TYPE ('I'): ! %IF IO ITEM\=AN INTEGER %THEN -> INCOMPATIBLE FORMAT I FORMAT: ! %IF I=0 %THEN -> OUTPUT A ZERO INTEGER %IF I<0 %THEN SIGN =MINUS %C %ELSE SIGN = PLUS SIGN %AND I=-I %IF SIGN\= NONE %THEN LENGTH= LENGTH-1 ! ! Determine the Scale of the Value ! EXP= 1 EXP=EXP+1 %WHILE I LENGTH %THEN -> WIDTH TOO SMALL %IF FORMAT=I SPECIAL %THENSTART ! ! Determine Form of Iw.m Formatting ! LEADING ZEROS= INT WIDTH - TOTAL CHARS %IF LEADING ZEROS> 0 %THENSTART %IF INT WIDTH> LENGTH %THEN -> WIDTH TOO SMALL %FINISHELSE LEADING ZEROS = NONE ! %FINISHELSE LEADING ZEROS = NONE ! ! Prepare the Output Field (for an Exponent as well) ! PTR=PTR +(LENGTH - LEADING ZEROS - EXP) FORMAT AN %C EXPONENT: IO BUFFER(PTR)=SIGN %C %AND PTR = PTR + 1 %UNLESS SIGN=NONE %IF LEADING ZEROS\=NONE %THEN FILL BUFF(LEADING ZEROS,PTR,NOUGHT) %C %AND PTR=LEADING ZEROS+PTR ! ! NOW PERFORM INTEGER FORMATTING ! M = MIN PER WIDTH (EXP-1) - 1 {initial value of Multiplier} ! %CYCLE; Q = I// M ; !extract the next digit I = I -(M*Q) ; ! and adjust the Value accordingly M = M// 10 ; ! and adjust the Multiplier too IO BUFFER(PTR)= Q + NOUGHT ; !insert the digit into PTR =PTR+ 1 ; ! the output field %REPEAT %UNTIL M = 0 ; ! and repeat 'til all digits are acquired ! ! -> EXIT OUTPUT A ZERO INTEGER: ! OUTPUT A ZERO INTEGER: ! OUTPUT A ZERO INTEGER: ! %IF FORMAT\=I SPECIAL %THENSTART %IF PLUS SIGN\=0 %THENSTART ! ! A leading '+' is required ! %IF WIDTH= 1 %THEN -> WIDTH TOO SMALL IO BUFFER(PTR MAX-2)= PLUS SIGN %FINISH IO BUFFER(PTR MAX-1)= NOUGHT %AND -> EXIT %FINISH {for Iw.m} %IF INT WIDTH>0 %THEN -> INITIALISE FOR I FORMAT -> EXIT !*********************************************************************** ! ! HANDLE FREE FORMAT (for List-Directed output) ! !*********************************************************************** ! FORMAT TYPE (FREE FORMAT): -> Z FORMAT %IF IO ITEM>A CHARACTER ! %IF IO ITEM = A LOGICAL %THEN -> L FORMAT %IF IO ITEM\=AN INTEGER %THEN FORMAT='G' %AND ->LOAD UP A REAL VALUE %C %ELSE FORMAT='I' %AND ->LOAD UP AN INTEGER VALUE !*********************************************************************** ! ! HANDLE 'L' FORMAT ! !*********************************************************************** ! ! FORMAT TYPE ('L'): ! %IF IO ITEM\=A LOGICAL %THEN -> INCOMPATIBLE FORMAT ! !test correspondence of format and I/O item L FORMAT: %IF DATA LEN=4 %THENSTART %IF INTEGER(DATA AD)&1= FALSE %C %THEN SIGN= FALSE SIGN %C %ELSE SIGN= TRUE SIGN %FINISHELSE %IF HALFINTEGER(DATA AD)&1= FALSE %C %THEN SIGN= FALSE SIGN %C %ELSE SIGN= TRUE SIGN IO BUFFER(PTR MAX-1)= SIGN -> EXIT !*********************************************************************** ! ! HANDLE 'Z' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('Z'): Z FORMAT: ! OUTPUT Z FORMAT -> EXIT !*********************************************************************** ! ! END OF HANDLING OUTPUT FORMATS ! !*********************************************************************** ! UNASSIGNED %C VARIABLE: %RESULT= UNASSIGNED VARIABLE INCOMPATIBLE FORMAT: FAULT 155: ! report non-correspondence between ! I/O item and the format code %RESULT=INCOMPATIBLE FORMAT SCALING INVALID: !Either SCALE<= 0 and SCALE<-DECIMALS ! or SCALE> 0 and SCALE> DECIMALS + 1 ! (ANSI 77 is specific) %RESULT=INVALID SCALING WIDTH TOO SMALL: FILL BUFF(WIDTH,BPTR,STAR) ! ! ! EXIT: BPTR= PTR MAX MAX BPTR=BPTR %IF BPTR>MAX BPTR ! %RESULT=0 !*********************************************************************** ! ! ROUTINES FOR HANDLING OUTPUT FORMATS ! !*********************************************************************** ! %REALFN INTO RANGE (%REAL X) ! ! ! ! A PROCEDURE WHICH BRINGS THE VALUE OF THE GIVEN ! ! PARAMETER INTO THE RANGE 10.0> X >=1.0 ! ! !Additionally, the variable EXP is changed to reflect the ! magnitude (scale of 10) of the parameter. ! ! %INTEGER I; !a work variable %IF X>=10.0 %THENSTART ! ! The value is too large ! %IF X>=TEN TO THE 38 %THEN I=38 %ELSESTART ! {!ELSE } I= 2 {!find the scale of} I=I+1 %WHILE X>= POWERS OF TEN(I) {! the value } I=I-1 %FINISH; X =X/POWERS OF TEN(I) EXP = EXP+I %FINISH %IF X<1.0 %THENSTART ! ! The value is too small ! X=X*10.0 %AND EXP=EXP-1 %WHILE X>1 %IF LENGTH&1\= 0 %THEN -> SECOND DIGIT %FINISH ! ! FIRST DIGIT: IO BUFFER(PTR)= CHAR( IO ITEM(K) >> 4) PTR = PTR+1 SECOND DIGIT: IO BUFFER(PTR)= CHAR( IO ITEM(K) & 15) K = K+1 PTR = PTR+1 %IF PTR < PTR MAX %THEN -> FIRST DIGIT %END; !of OUTPUT Z FORMAT ! ! ! %END; !of OUT FORMAT ! !*********************************************************************** ! ! OPEN and CLOSE and INQUIRE servicing procedures ! !*********************************************************************** ! %STRING(255) %MAP TEXT AT (%INTEGER ADDRESS) ! ! ! ! ! AN AUXILARY ROUTINE WHICH CONVERTS A CHARACTER VARIABLE INTO ! ! AN ISO STRING WITH ALL TRAILING SPACES REMOVED. THE RESULT ! ! IS THE ADDRESS OF THE CONVERTED TEXT. THE PARAMETER POINTS ! ! AT THE WORD PRECEDING A DESCRIPTOR TO THE VARIABLE. ! ! !NOTE that by returning the address of the result rather than the result ! itself the calling procedure has the capability of validating the ! result (ie. the text and its length) before exercising its option ! to save the result. ! ! !NOTE also that the result is also translated to ! upper case if the Lower Case Option is in force ! ! ! %RESULT= " " => the Character variable is all spaces ! %RESULT= "" => the Character variable is unassigned ! %RESULT= Character text otherwise ! ! ! %OWNSTRING(255) RESULT ;!%C RESULT contains the Character text %INTEGER ADR {address of RESULT} %HALFINTEGER DISP { and a word displacement into RESULT} ! %HALFINTEGER CONST {set to 1 if 1st trailing blank is word aligned} {set to 0 if 1st trailing blank is byte aligned} ! %RECORD (Form of a Parameter Pair) %NAME PP PP==RECORD(ADDRESS) ADR= ADDR(RESULT ) ! ! Get a Copy of the Character Text ! %RESULT==UNASSIGNED SPECIFIER %C %IF CHECK\=FALSE %AND BYTE AT(PP_ADDRESS,PP_INC)= NULL COPY(PP_LENGTH,PP_ADDRESS,PP_INC,ADR,1) {into RESULT} ! ! Prepare to Locate Trailing Spaces ! DISP= PP_LENGTH>> 1 ! %IF PP_LENGTH & 1={even} 0 %THENSTART ! ! First Check the Last Byte ! %IF BYTEINTEGER(ADR+DISP)\=BLANK %THEN CONST= 0 %C %AND -> SET LENGTH DISP= -1+DISP %FINISH ! ! Now Locate Any Trailing Spaces ! CONST= 1 %WHILE DISP> 0 %CYCLE ! %IF HALFINTEGER(ADR+DISP) \=X'2020' %THENSTART %IF HALFINTEGER(ADR+DISP)>>4= X'20' %THEN CONST= 0 %EXIT %FINISH DISP= DISP-1 %REPEAT ! ! Finalise the Result ! SET LENGTH: LENGTH(RESULT)=DISP + DISP + CONST ! {IF CASE\= UPPER (only) %THEN Translate Lower Case into Upper Case} ! %RESULT == RESULT %END; !of TEXT AT %HALFINTEGERFN OPEN (%INTEGER PPLIST ADDRESS) ! ! ! ! ! THIS IS THE PROCEDURE RESPONSIBLE FOR SERVICING ! ! A REQUEST TO OPEN A GIVEN CHANNEL. ! ! ! !The parameter points to the Parameter-Pairs List within the Transfer ! Control Table. If there is no list, then the parameter is set zero. !The individual parameter pairs are identified as follows: ! !0 => integer value of RECL= !1 => integer value of NREC= !2 => descriptor to character value of FILE= !3 => descriptor to character value of STATUS= !4 => descriptor to character value of ACCESS= !5 => descriptor to character value of FORM= !6 => descriptor to character value of BLANK= !7 => descriptor to character value of FILETYPE= (or DESC=) %INTEGERFNSPEC VALUE AT (%INTEGER ADDRESS OF VALUE) !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! ! %CONSTSTRING(7) %ARRAY STATUS TEXTS (0:3) %C ="UNKNOWN" , "SCRATCH", %C "NEW" , "OLD" ; !%C these are the valid texts that may be taken by the STATUS= specifier %C they are translated into the following values: ! %CONSTHALFINTEGER UNKNOWN=0 , SCRATCH=1 , NEW=2 , OLD=3 !Values taken by the ACCESS= specifier: ! %CONSTHALFINTEGER SEQUENTIAL=0 %CONSTHALFINTEGER DIRECT=1 !Values taken by the FORM= specifier: ! %CONSTHALFINTEGER UNFORMATTED=0 %CONSTHALFINTEGER FORMATTED=1 !Values taken by the BLANK= specifier: ! %C %CONSTHALFINTEGER NULL=0 %CONSTHALFINTEGER ZEROS=1 !*********************************************************************** ! ! LOCAL VARIABLES ! !*********************************************************************** ! %STRINGNAME SPECIFIER; ! text of the current specifier being evaluated %INTEGER ADDRESS ; !address of the current specifier being evaluated {Extracted } %OWNSTRING(255) FILE NAME ; ! text of FILE= { (and } %OWNSTRING(255) FILE TYPE ; ! text of FILETYPE= { transformed)} %INTEGER RECL ; !value of RECL= { values } %INTEGER NREC ; !value of NREC= { of } %HALFINTEGER FORM ; !value of FORM= { the } %HALFINTEGER ACCESS ; !value of ACCESS= { various } %HALFINTEGER BLANKS ; !value of BLANKS= { specifiers} %HALFINTEGER STATUS ; !value of STATUS= ! %OWNINTEGERARRAY SPECIFIER ADDRS (0:7); !%C SPECIFIER ADDRS is a list of addresses which point %C to the corresponding entry in the %C Parameter-Pairs List (zero=>not given) %RECORD (Form of a Parameter Pair List) %NAME PP %INTEGER VALUE; !value of current specifier if it's an Integer %HALFINTEGER FAULT; !reported by this routine %INTEGER TEXT ID; !utility variable %INTEGER I ; !utility variable (another one) ! ! ! Examine the Parameter-Pairs List ! ! %CYCLE I=0,1,7 ! SPECIFIER ADDRS(I)= NOT SET ! %REPEAT {initialising the array of ptrs (to each specifier given)} %IF PPLIST ADDRESS\=NOT SET %THENSTART ! ! Prepare to Scan the Parameter-Pairs List ! PP==RECORD(PPLIST ADDRESS) ! ! Extract the 1st/next Specifier Address ! %WHILE PP_ID>= 0 %CYCLE ! SPECIFIER ADDRS(PP_ID)= ADDR(PP_ID) PP== PP_NEXT PP PAIR %REPEAT %FINISH !Extract and Validate the STATUS Specifier ! STATUS = UNKNOWN ADDRESS=SPECIFIER ADDRS(3) %UNLESS ADDRESS=NONE %THENSTART; ! STATUS= was specified ! SPECIFIER==TEXT AT (ADDRESS) ! ! Examine STATUS text ! %CYCLE TEXT ID= UNKNOWN,1,OLD STATUS=TEXT ID %ANDEXIT %IF SPECIFIER=STATUS TEXTS (TEXT ID) %REPEAT %UNLESS STATUS=TEXT ID %THEN -> CHECK TYPE OF FAULT %FINISH !Extract and Validate the FILE Specifier ! ADDRESS=SPECIFIER ADDRS(2) %UNLESS ADDRESS=NONE %THENSTART; ! FILE= was specified ! SPECIFIER==TEXT AT (ADDRESS) %IF SPECIFIER<":" %THEN -> CHECK TYPE OF FAULT FILE NAME=SPECIFIER %FINISHELSE FILE NAME="" !Only if it was not specified ! ! Validate the Use made of STATUS= and FILE= ! %IF FILENAME="" %THENSTART %IF STATUS>SCRATCH %THEN -> NO FILENAME GIVEN %FINISHELSESTART %IF STATUS=SCRATCH %THEN -> SPECIFIERS INCONSISTENT %FINISH !Extract and Validate the RECL Specifier ! VALUE=VALUE AT (SPECIFIER ADDRS(0) ) %IF VALUE< 0 %THEN -> ERROR REPORTED ! RECL = VALUE !Extract and Validate the NREC Specifier ! VALUE=VALUE AT (SPECIFIER ADDRS(1) ) %IF VALUE< 0 %THEN -> ERROR REPORTED ! NREC = VALUE !Extract the ACCESS Specifier ! ACCESS =SEQUENTIAL ADDRESS=SPECIFIER ADDRS(4) %UNLESS ADDRESS=NONE %THENSTART; ! ACCESS= was specified ! SPECIFIER== TEXT AT (ADDRESS) %IF SPECIFIER ="DIRECT" %THEN ACCESS=DIRECT %ELSESTART %IF SPECIFIER\="SEQUENTIAL" %THEN -> CHECK TYPE OF FAULT %FINISH; %FINISH ! ! Validate Use made of ACCESS=, and RECL= and NREC= ! %IF ACCESS=SEQUENTIAL %THENSTART %IF RECL\=NOT SET %OR %C NREC\=NOT SET %THEN -> SPECIFIERS INCONSISTENT %FINISHELSESTART %IF RECL =NOT SET %THEN -> RECORD LENGTH MISSING %FINISH !Extract and Validate the FORM Specifier ! ADDRESS=SPECIFIER ADDRS(5) %UNLESS ADDRESS=NONE %THENSTART; ! FORM= was specified ! SPECIFIER== TEXT AT (ADDRESS) %IF SPECIFIER ="UNFORMATTED" %THEN FORM=UNFORMATTED %ELSESTART %IF SPECIFIER ="FORMATTED" %THEN FORM= FORMATTED %C %ELSE -> CHECK TYPE OF FAULT; %FINISH %FINISHELSE FORM=1-ACCESS; ! FORM= was not specified !Extract and Validate the BLANK Specifier ! BLANKS =NULL ADDRESS=SPECIFIER ADDRS(6) %UNLESS ADDRESS=NONE %THENSTART; ! BLANK= was specified ! SPECIFIER== TEXT AT (ADDRESS) %IF SPECIFIER ="ZERO" %THEN BLANKS=ZEROS %ELSESTART %IF SPECIFIER\="NULL" %THEN -> CHECK TYPE OF FAULT %FINISH ! ! Validate Use made of FORM= and BLANK= ! %IF FORM=UNFORMATTED %THEN -> SPECIFIERS INCONSISTENT %FINISH !Extract the FILETYPE (DESC) Specifier ! ADDRESS=SPECIFIER ADDRS(7) %UNLESS ADDRESS=NONE %THENSTART ! SPECIFIER==TEXT AT (ADDRESS) %IF SPECIFIER<"*" %THEN -> CHECK TYPE OF FAULT FILE TYPE = SPECIFIER %FINISHELSE FILE TYPE = "" !(ie. not given) ! !Now perform the Machine Dependencies ! ! FAULT= F77OPEN(DSNUM,STATUS, ACCESS,FORM, BLANKS,RECL,NREC, FILE NAME,FILE TYPE) %IF FAULT> 0 %THEN -> REPORT FAULT %RESULT={0} 125 ! ! ! !*********************************************************************** ! ! REPORT ERRORS DETECTED ! !*********************************************************************** ! ! CHECK TYPE OF FAULT: !when some specifier was not recognised, either the ! character variable was unassigned, or the ! character value was invalid ! %RESULT=SPECIFIER NOT RECOGNISED %IF SPECIFIER\=UNASSIGNED SPECIFIER %RESULT=UNASSIGNED VARIABLE ERROR REPORTED: !while extracting an integer value from a specifier ! %RESULT=-VALUE; !reported by VALUE AT RECORD LENGTH MISSING : %RESULT=RECORD LENGTH MISSING SPECIFIERS INCONSISTENT: %RESULT=SPECIFIERS INCONSISTENT NO FILENAME GIVEN : %RESULT=NO FILENAME GIVEN ! REPORT FAULT : %RESULT= FAULT %INTEGERFN VALUE AT (%INTEGER ADDRESS) ! ! ! ! A local function to establish the integer value of a ! ! specifier. The parameter points at the value bar a word. ! ! %INTEGER VALUE; !as specified in the parameter-pairs list ! %RESULT= NOT SET %IF ADDRESS =NONE VALUE =INTEGER(ADDRESS+1) %RESULT= VALUE %IF VALUE >NONE %RESULT=-UNASSIGNED VARIABLE %IF CHECK\=FALSE %AND VALUE=X'80808080' %RESULT=-ILLEGAL SPECIFIER VALUE ! %END; !of VALUE AT %END; !of OPEN %HALFINTEGERFN CLOSE (%INTEGER PPLIST ADDRESS) ! ! ! ! ! THIS PROCEDURE IS RESPONSIBLE FOR SERVICING A ! ! REQUEST TO DISCONNECT A GIVEN CHANNEL. ! ! !The parameter is the address of the parameter-pairs list within the ! Transfer Control Table. If there is no list then the address is ! set to zero. ! ! ! %HALFINTEGER STATUS; !set to indicate the value of the ! STATUS= specifier as follows: ! %C %CONSTHALFINTEGER NOT SPECIFIED= 0 %CONSTHALFINTEGER DELETE = 1 %CONSTHALFINTEGER KEEP = 2 %STRINGNAME STATUS TEXT; !acquired from TEXT AT ! via the parameter-pairs list %IF PPLIST ADDRESS\=NOT SET %THENSTART ! ! Extract and Evaluate the STATUS specifier ! STATUS TEXT==TEXT AT (PPLIST ADDRESS) %IF STATUS TEXT="KEEP" %THEN STATUS= KEEP %ELSESTART %IF STATUS TEXT="DELETE" %THEN STATUS= DELETE %C %ELSE ->REPORT A FAULT %FINISH; %FINISHELSE STATUS=NOT SET !if not specified ! ! Perform the CLOSE ! %RESULT= {F77CLOSE (DSNUM,STATUS)} 125 ! ! Report Invalid STATUS text ! REPORT A FAULT: !when the STATUS text was not recognised ! %RESULT=SPECIFIER NOT RECOGNISED %IF STATUS TEXT\=UNASSIGNED SPECIFIER %RESULT=UNASSIGNED VARIABLE ! %END; !of CLOSE %HALFINTEGERFN INQUIRE (%INTEGER PPLIST ADDRESS) ! ! ! ! ! THIS PROCEDURE IS RESPONSIBLE FOR SERVICING AN INQUIRE ! ! REQUEST, EITHER ON A GIVEN UNIT OR ON A GIVEN FILE. ! ! !The parameter is the address of the Parameter-Pairs list located within !the Transfer Control Table. If there is no list then PPLIST ADDRESS is !then set to zero. ! !The individual parameter pairs are identified as follows: ! ! 1 => descriptor to EXIST specifier (type Logical) ! 2 => descriptor to OPENED specifier (type Logical) ! 3 => descriptor to NUMBER specifier (type Integer) ! 4 => descriptor to NAMED specifier (type Logical) !12 => descriptor to RECL specifier (type Integer) !13 => descriptor to NEXTREC specifier (type Integer) !16 => descriptor to NREC specifier (type Integer) !64 => descriptor to FILE specifier (type Character) !69 => descriptor to NAME specifier (type Character) !70 => descriptor to ACCESS specifier (type Character) !71 => descriptor to SEQUENTIAL specifier (type Character) !72 => descriptor to DIRECT specifier (type Character) !73 => descriptor to FORM specifier (type Character) !74 => descriptor to FORMATTED specifier (type Character) !75 => descriptor to UNFORMATTED specifier (type Character) !78 => descriptor to BLANK specifier (type Character) !79 => descriptor to FILETYPE specifier (type Character) ! !Note that the identifiers corresponding to Specifiers of type ! Character have had 64 added to their true identification ! to differentiate them from word-aligned specifiers. !-------------------------------LOCAL---------------------------------- !----------------------------DECLARATIONS------------------------------- ! %INTEGER C ADR; !the address of a Character Specifier %HALFINTEGER C LEN; !the length of a Character Specifier %HALFINTEGER V LEN; !the length of the value to be assigned to a Character %INTEGER VALUE; !the actual value to be assigned to an Integer Specifier ! %INTEGER ADDRESS OF VALUES !the address of a list of values established by F77INQUIRE ! %HALFINTEGER ID ; !id of a current Parameter-Pairs List entry %HALFINTEGER I ; !------a utility variable ! ! %RECORD (Form of a Parameter Pair List) %NAME PP %HALFINTEGER FAULT ! ! Variables Associated with INQUIRE by File ! %OWNSTRING(255) FILE NAME; !name of the given file %INTEGER PTR ; !used in locating name - ptr through the PP-list %IF DSNUM<0 %THENSTART ! ! Extract Filename for INQUIRE by File ! PP==RECORD(PPLIST ADDRESS) ; !locate filename PP==PP_NEXT PP PAIR %WHILE PP_ID\= 64; ! description in the PP-List ! FILENAME=TEXT AT (ADDR(PP_ID)) ; !then extract the filename %IF FILENAME<":" %THEN -> INVALID FILENAME %FINISHELSESTART ! ! Prepare for INQUIRE by Unit ! FILENAME="" %FINISH ! ! Perform the INQUIRE ! FAULT= {F77INQUIRE (DSNUM,FILE NAME,ADDRESS OF VALUES)} 125 %IF FAULT> 0 %THEN -> REPORT FAULT %IF PPLIST ADDRESS\=NOT SET %THENSTART ! ! Prepare to Assign Values to the Various Specifiers ! PP==RECORD(PPLIST ADDRESS) ! ! Assign Values to the Given Specifiers ! NEXT SPECIFIER: ID= PP_ID %IF ID< 0 %THEN -> END OF LIST %IF ID>63 %THEN -> STRING VALUE ! ! Perform an Integer Assignment ! VALUE= INTEGER(ADDRESS OF VALUES + (ID + ID)) %IF VALUE< 0 %THEN -> UNDEFINED VALUE ! %IF PP_LENGTH= 1 %THEN HALFINTEGER(PP_ADDRESS)= VALUE %C %ELSE INTEGER(PP_ADDRESS)= VALUE -> NEXT SPECIFIER ! ! Perform a Character Assignment ! STRING VALUE: PTR= INTEGER(ADDRESS OF VALUES + ((ID-64)<< 1)) %IF PTR=-1 %THEN -> UNDEFINED TEXT ! C ADR= PP_ADDRESS ; !---address of Character scalar C LEN= PP_LENGTH ; !----length of Character scalar V LEN= LENGTH(STRING(PTR)); !----length of string value ! I= C LEN - V LEN %IF I< 0 %THEN V LEN= C LEN COPY (V LEN,PTR,1,C ADR,PP_INC) %IF I> 0 %THEN %C PROPAGATE ( I,C ADR,V LEN + PP_INC, BLANK) ;!%C (append any trailing spaces reqd) ! ! Point to the next Entry in the Parameter-Pairs List ! NEXT ONE: PP== PP_NEXT PP PAIR -> NEXT SPECIFIER ! ! Handle an Undefined Character Value ! UNDEFINED TEXT: %IF CHECK\=FALSE %AND PP_ID\=64 %THENSTART ! PROPAGATE(PP_LENGTH,PP_ADDRESS,PP_INC,0 {zeros}) ! %FINISH -> NEXT ONE ! ! Handle an Undefined Integer Value ! UNDEFINED VALUE: %IF CHECK\=FALSE %THENSTART ! PROPAGATE(PP_LENGTH+PP_LENGTH,PP_ADDRESS,0,X'80') ! %FINISH -> NEXT ONE END OF LIST: %FINISH ! ! RETURN ! %RESULT=0; !if there are no errors ! {otherwise} REPORT FAULT: %RESULT=FAULT ! {or} INVALID FILENAME: ! %RESULT=UNASSIGNED VARIABLE %IF FILE NAME=UNASSIGNED SPECIFIER %RESULT= INVALID FILENAME %END; !of INQUIRE ! !*********************************************************************** ! ! UTILITY PROCEDURES ! !*********************************************************************** ! %ROUTINE FILL BUFF (%INTEGER LENGTH, %HALFINTEGER AT,WITH) ! ! ! ! ! This is a utility procedure to fill a specified number ! ! of bytes in the current I/O buffer with a given character ! ! ! %WHILE LENGTH>0 %CYCLE ! IO BUFFER(AT)= WITH AT = AT+1 LENGTH = LENGTH-1 %REPEAT; %END; !of FILL BUFF %ROUTINE PROPAGATE (%INTEGER LEN,BASE %HALFINTEGER INC,WITH) ! ! ! ! ! This is a utility procedure to fill part of an area which ! ! is usually a CHARACTER variable with a specified number ! ! of a given character. ! ! ! %BYTEINTEGERARRAYNAME AREA AREA==ARRAY(BASE,FORM A) %WHILE LEN> 0 %CYCLE ! AREA(INC)= WITH INC = INC + 1 LEN = LEN - 1 %REPEAT %END; !of PROPAGATE %IF SYSTEM=PERQ %THENSTART ! ! %HALFINTEGERFN BYTE AT (%INTEGER DATA AD, %HALFINTEGER DATA INC) ! ! ! %HALFINTEGER I I=HALFINTEGER(DATA AD + DATA INC>>1) %RESULT= I & 255 %IF (DATA INC&1)= 0 %RESULT= I >> 8 %END; !of BYTE AT !* %ROUTINE COPY(%INTEGER LEN,SBASE,%HALFINTEGER SDISP, %INTEGER TBASE,%HALFINTEGER TDISP) **@TBASE; *LDDW; **TDISP **@SBASE; *LDDW; **SDISP **LEN *STLATE_X'63'; *MVBW %END %INTEGERFN COMPARE ( %INTEGER LENGTH, THIS BASE , %HALFINTEGER THIS DISP , %INTEGER THAT BASE , %HALFINTEGER THAT DISP ) ! ! ! ! ! A Utility Procedure to lexographically compare two texts ! ! of equal length and to return a value which ! ! represents the result of the comparision. ! ! ! At Exit: RESULT= 0 if Text(THIS BASE)=Text(THAT BASE) or LENGTH<=0 ! RESULT= -1 if Text(THIS BASE)Text(THAT BASE) ! ! ! %HALFINTEGER BOOLEAN ! ! **@THAT BASE ; *LDDW ; **THAT DISP **@THIS BASE ; *LDDW ; **THIS DISP **LENGTH ; *STLATE_X'63'; *EQUBYT_0; **=BOOLEAN %IF BOOLEAN=TRUE %THENRESULT= 0 {equal} **@THAT BASE ; *LDDW ; **THAT DISP **@THIS BASE ; *LDDW ; **THIS DISP **LENGTH ; *STLATE_X'63'; *LESBYT_0; **=BOOLEAN %IF BOOLEAN=TRUE %THENRESULT=-1 { less than} %RESULT= 1 {greater than} %END; !of COMPARE ! ! %FINISH; !if PERQ %IF SYSTEM=EMAS %THENSTART ! ! %ROUTINE COPY (%INTEGER LENGTH, FROM BASE {word address} , %HALFINTEGER FROM DISP {byte displacement} , %INTEGER TO BASE {word address again} , %HALFINTEGER TO DISP {byte displacement again} ) %WHILE LENGTH> 0 %CYCLE ! BYTEINTEGER(TO BASE + TO DISP)=BYTEINTEGER(FROM BASE + FROM DISP) TO DISP= TO DISP + 1 FROM DISP=FROM DISP + 1 LENGTH= LENGTH - 1 %REPEAT %END; !of COPY %HALFINTEGERFN BYTE AT (%INTEGER DATA AD {word address} , %HALFINTEGER DATA DISP {byte displacement} ) %RESULT= BYTEINTEGER (DATA AD + DATA DISP) %END; !of BYTE AT %INTEGERFN COMPARE ( %INTEGER LENGTH, THIS BASE , %HALFINTEGER THIS DISP , %INTEGER THAT BASE , %HALFINTEGER THAT DISP ) ! ! ! ! ! A Utility Procedure to lexographically compare two texts ! ! of equal length and to return a value which ! ! represents the result of the comparision. ! ! ! At Exit: RESULT= 0 if Text(THIS BASE)=Text(THAT BASE) or LENGTH<=0 ! RESULT= -1 if Text(THIS BASE)Text(THAT BASE) ! ! ! THIS BASE= THIS BASE + THIS DISP THAT BASE= THAT BASE + THAT DISP %WHILE LENGTH>0 %CYCLE ! %RESULT= 1 {greater than} %C %IF BYTEINTEGER(THIS BASE)>BYTEINTEGER(THAT BASE) %RESULT=-1 { less than} %C %IF BYTEINTEGER(THIS BASE) 25 %THENRESULT= Invalid Unit Number AFD= FDMAP (DSNUM) %IF AFD=Not Set %THENSTART ! ! Get a New File Definition Table ! FAULT=DEFINE FD (DSNUM, FILE TYPE, AFD) %IF FAULT> 0 %THENRESULT=FAULT %FINISH F== RECORD (AFD) CURRENT FD= AFD %FINISH FD ADDRESS= CURRENT FD ! ! Validate the I/O Operation ! %IF ACTION & F_VALID ACTION= 0 %THENSTART ! %IF ACTION= Write %THENRESULT=No Write Permission %C %ELSERESULT=Invalid IO Operation %FINISH %IF ACTION & SIMPLE VALID ACTION(F_CUR STATE) = 0 %THENSTART ! ! Perform Special Actions (or Tests) ! FAULT= SPECIAL ACTION %IF FAULT> 0 %THENRESULT= FAULT %IF FAULT< 0 %THENRESULT= 0 %FINISH ! ! Prepare for Requested I/O Operation ! %IF ACTION=Read %THENSTART F_CUR STATE= After Read %RESULT= 0 %FINISH %IF ACTION=Write %THENSTART F_CUR STATE= After Write %RESULT= 0 %FINISH %RESULT= Facility Not Available {for all others} %HALFINTEGERFN SPECIAL ACTION ! ! ! ! ! A Local Procedure to Perform Detailed Processing ! ! and/or tests for the Requested I/O Operation ! ! ! %HALFINTEGER FAULT %HALFINTEGER OPEN MODE ! %SWITCH STATE(0:9) -> STATE (F_CUR STATE) ! ! OPEN A CHANNEL ! STATE (Not Open): OPEN MODE= ACTION OPEN MODE= Read %UNLESS OPEN MODE=Write FAULT= OPEN (CURRENT FD, OPEN MODE) %IF FAULT> 0 %THENRESULT=FAULT F_CUR STATE= After Open %RESULT= 0 ! ! ALL OTHER SPECIAL ACTIONS ! STATE ( * {all others}): ! %RESULT=Invalid IO Operation ! %END; !of SPECIAL ACTION %END; !of NEW FILE OP %EXTERNALHALFINTEGERFN INREC ! ! ! ! ! A Skeleton Procedure to Read a Record ! ! from the Current File. ! ! ! %HALFINTEGER AMOUNT READ ! %RECORD (File Definition Table) %NAME F F==RECORD(CURRENT FD) ! ! Read the Next Line from the Screen ! GET LINE (F_AREC,AMOUNT READ) ! F_RECSIZE=AMOUNT READ F_TRANSFERS=F_TRANSFERS+1 %RESULT=0 ! %END; !of INREC %EXTERNALHALFINTEGERFN OUTREC (%INTEGER RECORD LENGTH {in bytes}) ! ! ! ! ! A Skeleton Procedure to Output a Record ! ! to the Current File. ! ! ! %RECORD (File Definition Table) %NAME F F==RECORD(CURRENT FD) ! ! Write The Record ! LENGTH(STRING(F_AREC))= RECORD LENGTH PRINT STRING %C ( STRING(F_AREC)); NEWLINE F_TRANSFERS =F_TRANSFERS + 1 ! %RESULT = 0 %END; !of OUTREC ! !*********************************************************************** ! ! GLOBAL UTILITY PROCEDURES ! !*********************************************************************** ! %EXTERNALINTEGERMAP FDMAP (%INTEGER DSNUM) ! ! ! ! ! A Utility Procedure which returns a reference to ! ! the File Definition Table which corresponds ! ! to the given channel number. ! ! ! %RESULT=ADDR(FD ADR(DSNUM)) %END; !of FDMAP %EXTERNALHALFINTEGERFN OPEN (%INTEGER AFD, %HALFINTEGER OPEN MODE) ! ! ! ! ! A Global Procedure to Open a File ! ! ! %SWITCH OPEN (CONSOLE:4) ! %RECORD (File Definition Table) %NAME F F==RECORD(AFD) -> OPEN (F_ACCESS ROUTE) ! ! CONNECT A FILE TO THE SCREEN ! OPEN (Console): F_AREC = ADDR(IO BUFFER)+1 F_MINREC = 1 F_MAXREC = 84 F_TRANSFERS = 0 F_UFD = X'49' {F77 DEFINED and Formatted I/O} F_STATUS = Opened F_CUR STATE = Opened %RESULT= 0 ! ! CONNECT OTHER FILE TYPES ! OPEN (*): %RESULT= Facility Not Available ! %END; !of OPEN ! !*********************************************************************** ! ! LOCAL UTILITY PROCEDURES ! !*********************************************************************** ! %HALFINTEGERFN DEFINE FD (%INTEGER DSNUM, %HALFINTEGER FILETYPE, %INTEGERNAME FD ADR ) ! ! ! ! ! A Utility Procedure which Locates an External File Definition ! ! and which constructs an appropriate File Defintion Table. ! ! !NOTE: The given channel is assumed not to be defined internally. ! ! ! %RECORD (File Definition Table) %NAME F %OWNRECORD (File Definition Table) %ARRAY FDs (0:1) ! %OWNHALFINTEGER FDs USED= None ! %INTEGER AFD %IF FDs USED> 1 %THENRESULT=Too Many Files AFD=ADDR(FDs(FDs USED)) FDs USED= FDs USED + 1 %IF DSNUM=-1 %OR DSNUM=5 %THENSTART ! ! Fill in Entries for Console Input Only ! F==RECORD(AFD) ! F_DSNUM = DSNUM F_VALID ACTION= Read {only} ! -> A; %FINISH %IF DSNUM\=6 %AND DSNUM\=-2 %THENRESULT=Unit Not Defined ! ! Fill in Entries for Console Output only ! F==RECORD(AFD) ! F_DSNUM = DSNUM F_VALID ACTION= Write {only} A: F_MODE OF USE = FILETYPE F_ACCESS ROUTE= Console F_ACCESS TYPE = 0 {sequential I/O} F_F77BLANK = 1 {blanks are significant} F_ID ="Console" FDMAP(DSNUM) = AFD %AND FD ADR= AFD %RESULT=0 %END; !of DEFINE FD ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! %ENDOFFILE