!Modified 14/ 6/82 16.00 !**********************************************************************! !**********************************************************************! ! ! ! ! ! This Module is designed to provide List-Directed Input ! ! ! ! for FORTRAN77 Programs ! ! ! ! on ICL PERQ Machines ! ! ! ! ! !**********************************************************************! !**********************************************************************! !-----Module History-----! ! ! ! ! ! FIO7701Q --------first version (numerous restrictions) ! (derived from FIO7731N) ! ! FIO7731N ---conversion to IMP80 ! ! FIO7730N -----includes reps to B70 release !Conditional Compilation Variables: ! %CONSTINTEGER EMAS= 0 %CONSTINTEGER PERQ= 1 ! {********************} %CONSTINTEGER SYSTEM=PERQ {*********************} ! ! %CONSTINTEGER CURRENT= 0 %CONSTINTEGER FUTURE= 1 ! {********************} %CONSTINTEGER RELEASE=CURRENT {*****************} %CONSTHALFINTEGER FALSE= 0 %CONSTHALFINTEGER TRUE = 1 ! !*********************************************************************** ! ! ENVIRONMENTAL VARIABLES ! !*********************************************************************** ! %CONSTHALFINTEGER OUTPUT LEN= 84; !The record length of the diagnostic ! stream. Should the characteristics ! of the stream change then only this ! variable need be altered. !*********************************************************************** ! ! RECORD FORMATS ! !*********************************************************************** ! %RECORDFORMAT FILE DEFINITION TABLE ( %C %C %INTEGER LINK , BACK {LINK}, %INTEGER DSNUM , %BYTEINTEGER STATUS , CUR STATE , %BYTEINTEGER VALID ACTION , Spare1 , %BYTEINTEGER MODE OF USE , ACCESS TYPE , %HALFINTEGER EXISTENCE , ACCESS ROUTE , %HALFINTEGER RECORD TYPE , %HALFINTEGER RECORD LEN , {of the current record} %HALFINTEGER RECSIZE , %HALFINTEGER MINREC , %HALFINTEGER MAXREC , %INTEGER DA RECNUM , %INTEGER LINES IN , %INTEGER LINES OUT , %HALFINTEGER FILE ID , %HALFINTEGER SCRATCH ID , %HALFINTEGER LAST BLK , MAX BLK , %HALFINTEGER BLK , {the current one} %HALFINTEGER POS , {and position within it} %HALFINTEGER REC POS , %HALFINTEGER UFD , %HALFINTEGER F77BLANK , %HALFINTEGER F77RECL , %HALFINTEGER FLAGS , %INTEGER CUR POS {in bytes from start of file}, %INTEGER CUR LEN {In bytes from start of file}, %INTEGER ID ADDR ) ! ! %C Values That May Be Set in a File Definition Table: ! ! %CONSTINTEGER F77 DEFINED = X'48'; ! Bit Values %CONSTINTEGER FORMATTED BIT = X'01'; ! of the %CONSTINTEGER FREEFMT BIT = X'02'; ! F77UFD field %CONSTINTEGER FMTED FILE BITS= X'49'; !and byte values %CONSTINTEGER FREEFMT FILE BITS= X'4B'; ! of the field %RECORDFORMAT TRANSFER CONTROL TABLE ( %C %C %INTEGER DSNUM , %INTEGER REC NUMBER , %HALFINTEGER COROUTINE INDEX , %HALFINTEGER IOSTAT VALUE , %INTEGER IOSTAT ADDRESS {used only by user code} ) ! !*********************************************************************** ! ! GLOBAL PROCEDURE SPECIFICATIONS ! !*********************************************************************** ! %HALFINTEGERFNSPEC F77 IOC %C (%RECORD (Transfer Control Table) %NAME TCT , %HALFINTEGER KEY , FORM , %HALFINTEGER IO MODE, FLAGS, MARKERS , %HALFINTEGERFN IO ITEM %C (%HALFINTEGER KEY , %INTEGER LEN TYPE ADR, %INTEGERNAME ADDRESS) ) %EXTERNALHALFINTEGERFN F77 IOC ( %C {! }%C {! }%C {! }%C {! }%C {! THIS PROCEDURE IS THE INTERFACE BETWEEN A LIST-DIRECTED INPUT }%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 ) ) ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL ERROR HANDLING ROUTINES ! !*********************************************************************** ! %EXTERNALROUTINESPEC SSMESS (%HALFINTEGER FAULT) %EXTERNALROUTINESPEC F77IOERR (%HALFINTEGER STACK %C TRACEBACK) %EXTERNALREALFNSPEC FLOAT LONG (%INTEGER I) ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL I/O HANDLING ROUTINES ! !*********************************************************************** ! %EXTERNALHALFINTEGERFNSPEC NEW FILE OP (%INTEGER DSNUM , %HALFINTEGER ACTION, FILETYPE, %INTEGERNAME FD TABLE ADDRESS) %EXTERNALHALFINTEGERFNSPEC IN REC %EXTERNALHALFINTEGERFNSPEC IN CHAR (%HALFINTEGER BUFF PTR) %EXTERNALHALFINTEGERFNSPEC IN FIELD (%HALFINTEGER LENGTH, BUFF PTR, %INTEGER TO, TO INC) %EXTERNALHALFINTEGERFNSPEC BSP REC ! !*********************************************************************** ! ! SPECIFICATIONS FOR MAIN UTILITY ROUTINES ! !*********************************************************************** ! %ROUTINESPEC GET EXTRA ERROR INFO %HALFINTEGERFNSPEC INITIALISE EXTERNAL IO OPERATION %HALFINTEGERFNSPEC NEW RECORD %HALFINTEGERFNSPEC IN ITEM %HALFINTEGERFNSPEC IN FORMAT %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 ) %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 INVALID INTEGER = 140 %CONSTHALFINTEGER INVALID REAL = 141 %CONSTHALFINTEGER INVALID COMPLEX = 143 %CONSTHALFINTEGER INVALID CHARACTER = 148 %CONSTHALFINTEGER LITERAL NOT TERMINATED = 150 %CONSTHALFINTEGER CONST NOT REPEATABLE = 198 %CONSTHALFINTEGER INPUT ENDED = 153 %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 FIELD TOO LARGE = 199 %CONSTHALFINTEGER NULL FIELD = 133 %CONSTHALFINTEGER CONNECTION NOT FORMATTED = 194 %CONSTHALFINTEGER ACCESS CONFLICT = 119 %CONSTHALFINTEGER INCOMPATIBLE FORMAT = 155 !*********************************************************************** ! ! 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 Console= 0 {a possible ACCESS ROUTE} !* !* %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)} (0:75) %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' %FINISH; !if not PERQ %IF SYSTEM=PERQ %THENSTART ! ! %CONSTINTEGERARRAY PERQ POWERS OF TEN {(-37:39)} (0:76) %C = X'02081CEA' , X'03AA2425' , X'0554AD2E' , X'0704EC3D' , X'08A6274C' , X'0A4FB11F' , X'0C01CEB3' , X'0DA24260' , X'0F4AD2F8' , {This Table } X'10FD87B6' , X'129E74D2' , X'14461206' , { is } X'15F79688' , X'179ABE15' , X'19416D9A' , { an } X'1AF1C901' , X'1C971DA0' , X'1E3CE508' , { accurate } X'1FEC1E4A' , X'219392EF' , X'233877AA' , { representation} X'24E69595' , X'26901D7D' , X'283424DC' , { of } X'29E12E13' , X'2B8CBCCC' , X'2D2FEBFF' , { the } X'2EDBE6FF' , X'3089705F' , X'322BCC77' , { powers of ten } X'33D6BF95' , X'358637BD' , X'3727C5AC' , { in } X'38D1B717' , X'3A83126F' , X'3C23D70A' , { the } X'3DCCCCCD' , X'3F800000' , X'41200000' , { range } X'42C80000' , X'447A0000' , X'461C4000' , { 10**(-37) } X'47C35000' , X'49742400' , X'4B189680' , { to 10** 38 } X'4CBEBC20' , X'4E6E6B28' , X'501502F9' , { expressed } X'51BA43B7' , X'5368D4A5' , X'551184E7' , { in the } X'56B5E621' , X'58635FA9' , X'5A0E1BCA' , { form of } X'5BB1A2BC' , X'5D5E0B6B' , X'5F0AC723' , { floating } X'60AD78EC' , X'6258D727' , X'64078678' , { point } X'65A96816' , X'6753C21C' , X'69045951' , { numbers } X'6AA56FA6' , X'6C4ECB8F' , X'6E013F39' , { which conform } X'6FA18F08' , X'7149F2CA' , X'72FC6F7C' , { to the } X'749DC5AE' , X'76453719' , X'77F684DF' , { IEEE draft } X'799A130C' , X'7B4097CE' , X'7CF0BDC2' , { standard } X'7E967699' , %C {largest PERQ real--->} X'7F7FFFFF' ! ! Other Floating Point Constants ! %CONSTINTEGER PERQ LARGEST REAL = X'7F7FFFFF' %OWNREALARRAYNAME POWERS OF TEN; !mapped onto PERQ POWERS OF TEN ! %OWNREALNAME LARGEST REAL; !mapped onto POWERS OF TEN (76) ! ! %FINISH; !if PERQ !*********************************************************************** ! ! INTERNAL WORK-AREAS ! !*********************************************************************** ! {---TEMPORARILY----->} %BYTEINTEGERARRAY WORK AREA (0:1025) ! %INTEGER WORKAREA ADDR %BYTEINTEGERARRAYNAME IO BUFFER %BYTEINTEGERARRAYNAME BUFFER ! %C IO BUFFER is an area into which the next value from the input %C stream is copied by IN FORMAT before performing %C conversion on it ! %C BUFFER is an area into which a number is analysed by IN FORMAT !The array formats used are: ! %BYTEINTEGERARRAYFORMAT FORM A (0: 1023) ; !for BUFFER and IO BUFFER %BYTEINTEGERARRAYFORMAT FORM B (0:32767) ; !for literal assignments %REALARRAYFORMAT FORM C (0: 76) ; !for POWERS OF TEN !*********************************************************************** ! ! GLOBAL VARIABLES ! !*********************************************************************** ! !Initialisation Criterion on PERQ is determined via: ! %OWNHALFINTEGER F77IO FLAG= FALSE {= TRUE if F77IO is initialised} %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 ! ! Variables Controlling Access to the File Definition Table ! %RECORD (File Definition Table) %NAME F ! ! Buffer Variables ! %HALFINTEGER BLEN {relative end of buffer +1} %HALFINTEGER BPTR {scanning ptr through the buffer} ! ! Declarations of Variables Extracted from the Parameter list ! %INTEGER DSNUM ! ! Variables Controlling Access to or from a File ! %HALFINTEGER UFD; !copy of F77UFD field of the current I/O channel FD Table ! !its bits are set as follows: ! ! F77 DEFINED= X'48' => details are F77 defined ! FORMATTED BIT= X'01' => connection/file is formatted ! FREEFMT BIT= X'02' => connection/file has !list-directed records ! ! Variables associated with Error Reporting ! %HALFINTEGER ERROR ; !the value to be assigned to the IOSTAT scalar %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 !*********************************************************************** ! ! LIST-DIRECTED INPUT SPECIFIC VARIABLES ! !*********************************************************************** ! ! ! 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 ! %HALFINTEGER PTR ; !scanning pointer through the current input buffer %HALFINTEGER ITEM ; !the type of item being processed in the input buffer %HALFINTEGER DELIM ; !the type of delimiter terminating the last value found %INTEGER COUNT ; !the repetition factor applying to the last value found %HALFINTEGER DATA LEN; !the number of bytes associated with the current I/O item %IF F77IO FLAG= FALSE %THENSTART; ! ! ! ! ! Initialise FIO Itself ! ! ! ! ! RUN MODE={COMREG (42)} 0 FIO MODE= NORMAL MODE ! ! Initialise Real Constants names ! POWERS OF TEN== ARRAY(ADDR(PERQ POWERS OF TEN( 0)),FORM C) LARGEST REAL== POWERS OF TEN(76) F77IO FLAG= TRUE; ! ! !----->END OF INTERNAL INITIALISATION ! %FINISH !Initialise Work-Areas: ! WORKAREA ADDR= ADDR(WORKAREA (0)) BUFFER==ARRAY(WORKAREA ADDR ,FORM A) IO BUFFER==ARRAY(WORKAREA ADDR+1,FORM A) ! ! Analyse The Parameters ! CASE = {FLAGS & 16 for future releases} 1{ie not UPPER} RELAX ANSI = FLAGS & 8 CHECK = FLAGS & 4 ! DSNUM = TCT_DSNUM ! ! Prepare for a New File Operation ! FAULT=INITIALISE EXTERNAL IO OPERATION -> BASIC IO ERROR %IF FAULT\=NONE ! ! Extract the FORM Property of the Connection ! UFD= F_UFD %IF UFD= NOT SET %THENSTART ! ! Set the FORM Property of the File ! UFD= X'49' F_UFD= UFD %FINISH !And now Validate the FORM Property: ! %IF (UFD&FMTEDFILE BITS)\=X'49' %THENSTART ! ! Report a FORM Conflict ! FAULT=CONNECTION NOT FORMATTED -> BASIC IO ERROR %FINISH %IF F_ACCESS TYPE\= 0 {Sequential} %THEN FAULT=ACCESS CONFLICT %C %AND -> BASIC IO ERROR ! ! ! READ THE FIRST RECORD ! ! FAULT = INREC %IF FAULT\= NONE %THEN -> BASIC IO ERROR ! ! INITIALISE THE BUFFER POINTER ! BPTR = 0 ; !-> relative start of buffer ! BLEN =F_RECSIZE !-> IO FORM (FORM) ! ! ! !*********************************************************************** ! ! PERFORM LIST-DIRECTED INPUT ! !*********************************************************************** ! ! ! %IF TCT_COROUTINE INDEX\=NONE %THENSTART ; !There is an I/O list ! ! INITIALISE VARIABLES ! COUNT= NONE; !-no repetition (yet) DELIM= 1 ; !-a comma PTR= BPTR; !-set the scanning ptr %CYCLE ! ! GET THE NEXT (or first) I/O ITEM ! ITEM TYPE=IO ITEM(KEY,ADDR(DATA WORDS),ITEM AD) %IF ITEM TYPE<0 %THENEXIT 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 ! ! ASSIGN THE NEXT INPUT ITEM{s} TO THE I/O ITEM ! FAULT =IN ITEM %IF FAULT\= 0 %THENSTART %IF FAULT> 0 %THEN -> IO ERROR %EXIT %FINISH %REPEAT %FINISH !*********************************************************************** ! ! RETURN (after successful completion) ! !*********************************************************************** ! !Set the IOSTAT field in the Transfer Control Table ! TCT_IOSTAT VALUE= 0 ! %RESULT= 0 !Area Reserved for PATCHing: ! *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; *LDC0; !*********************************************************************** ! ! 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=-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. ! ! ! %IF RELEASE=FUTURE %THENSTART ! ! %BYTEINTEGERARRAY 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 %INTEGER BUFF DISP %INTEGER LENGTH %INTEGER I %RETURN {**FOR NOW} ! ! SEE IF A PRINT OF THE I/O BUFFER WOULD BE HELPFUL ! %IF BPTR>=0 %THENSTART !Helpful if the buffer isn't ! empty and the contents are ! supposed to be characters BUFF DISP= 0 LENGTH = BLEN ! ! 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 ! ! Re-set the buffer variables ! BPTR= 0 BLEN= F_RECSIZE ! %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 %INTEGERFN ARRAY ADDRESS (%INTEGER DATA AD , %HALFINTEGER DATA TYPE) ! ! ! ! ! THIS PROCEDURE DETERMINES THE ADDRESS OF THE FIRST ACTUAL ! ! ARRAY ELEMENT AND THE NUMBER OF ARRAY ELEMENTS ! ! USING THE DOPE VECTOR ADDRESS (Data Ad) AND THE ! ! VARIABLE TYPE (Data Type). ! ! !The Form of a Dope Vector is as follows: ! %C Integer: Address of 1st actual element (word boundary) %C Halfinteger: Increment to start of 1st actual element ---AND %C Halfinteger: Element size if type= CHARACTER Array %C Integer: Number of Array elements ! ! %INTEGER RESULT {returned is address of 1st element} RESULT= INTEGER(DATA AD) ! ! %IF DATA TYPE=A CHARACTER %THENSTART ! ! Extract CHARACTER Dependent Information ! DATA INC = HALFINTEGER(DATA AD + 2) DATA BYTES= HALFINTEGER(DATA AD + 3) DATA WORDS= DATA BYTES DATA AD = DATA AD + 4 %FINISHELSE %C DATA BYTES= DATA WORDS + DATA WORDS NUM DATA ITEMS= INTEGER(DATA AD + 2) %RESULT= RESULT ! %END; !of ARRAY ADDRESS !*********************************************************************** ! ! 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 %OWNHALFINTEGER 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 LINES READ; !a record of the number of records currently ! read when a repetition factor was found !LINES READ is used by IN LITERAL for example ! %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= IN FIELD (WIDTH, BPTR , ADDR(IO BUFFER(0)), 0) %IF FAULT= NONE %THEN %C FAULT= TO INTEGER (ADDR(COUNT), 2{words}, ADDR(IO BUFFER(0)),WIDTH, 0, FIO PLUS MODE) %UNLESS FAULT= NONE %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} ! LINES READ=F_LINES IN; !also remember where we are in ! the file in case we have ! to backspace to rescan a ! repeated constant %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' or 'f','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(17), 8 , 9(13), 8 , 9(11) ! ! %HALFINTEGER CLASS %HALFINTEGER CHAR %IF PTR>=BLEN %THEN CLASS=END OF RECORD %ELSESTART CHAR= IN CHAR (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. ! ! ! A repeated complex constant is evaluated without copying it into ! a workarea. This means that we are not able to handle a repeated ! constant which crosses a record boundary when the input is coming ! from the Console Screen and when the constant has to be evaluated ! for more than one I/O item. If such a case should arise then the ! fault CONSTANT CANNOT BE REPEATED is given and we return upwards. ! ! !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 if no record boundary has been crossed meantime. ! ! ! ! ! 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 %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 ITEM=SCANNED COMPLEX %THENSTART ! ! ! RE-EVALUATE THE CONSTANT (for a different precision) ! ! %IF LINES READ=F_LINES IN %THENSTART ! ! Re-Format the Complex Constant ! -> INCOMPATIBLE CONSTANT %UNLESS DATA TYPE=A COMPLEX ! 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 %FINISHELSESTART ! ! Re-Read the Record containing the start of the Complex Constant ! FAULT= BSP REC %IF FAULT= NONE %THEN FAULT=NEW RECORD %IF FAULT> NONE %THEN -> REPORT ! BPTR= R PTR; !set pointers PTR= R PTR; ! to the opening bracket ! %FINISH ;!%C and fall through to re-analyse the constant %FINISH ! ! ! ANALYSE AND EVALUATE THE CONSTANT ! ! %IF DATA TYPE\= A COMPLEX %THEN -> INCOMPATIBLE CONSTANT ! ! 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 {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 !continue the analysis as we may have to cope with the eventuality that !the constant is repeated and it may have to be re-evaluated for an I/O !item of different length (and possibly type). ! %IF F_ACCESS ROUTE=Console %AND %C COUNT>NUM DATA ITEMS %THEN -> CONSTANT NOT REPEATABLE 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 the Various Errors Detected ! ! INVALID COMPLEX: FAULT=INVALID COMPLEX %AND -> REPORT CONSTANT NOT REPEATABLE: FAULT=CONST NOT REPEATABLE BPTR=R PTR %AND -> REPORT VALUE SEPARATOR MISSING: BPTR= BPTR+WIDTH NO VALUE SEPARATOR : FAULT=VALUE SEPARATOR MISSING; -> REPORT INCOMPATIBLE CONSTANT: FAULT=INCOMPATIBLE FORMAT; -> REPORT FAULT REPORTED: %IF FAULT=INPUT ENDED %THEN BPTR=BLEN %C %AND FAULT=INVALID COMPLEX REPORT : ! ! 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 evaluated directly into the I/O item without ! using an intermediate workarea. This means that we are not ! able to handle a repeated literal which crosses a record ! boundary when the input is coming from the Console Screen ! and when the literal has to be evaluated for more than one ! I/O item. If such a case should arise then we report the ! fault CONSTANT CANNOT BE REPEATED and return. ! ! ! %HALFINTEGER DATA LEN {amount of I/O item currently not assigned} %INTEGER ITEM PTR {scanning ptr through the I/O item } %HALFINTEGER X {the next character from the input buffer } %HALFINTEGER FAULT ! %OWNHALFINTEGER COPY LEN; !copy of original DATA BYTES --- may be used %OWNINTEGER COPY AD ; ! DATA AD --- for repeated %OWNINTEGER COPY INC; ! DATA INC --- constants ! %BYTEINTEGERARRAYNAME IO ITEM ;!%C IO ITEM is mapped onto the current I/O item IO ITEM == ARRAY (DATA AD, FORM B) DATA INC= 0 %UNLESS DATA TYPE=A CHARACTER %IF ITEM\=SCANNED LITERAL %THENSTART ! ! ! EVALUATE THE LITERAL IN THE INPUT STREAM ! ! SCAN THE LITERAL: DATA LEN= DATA BYTES; !Initialise ITEM PTR= DATA INC ; ! Variables !Get the next character: ! %CYCLE %IF PTR>=BLEN %THENSTART {at end of record} ! %RESULT= CONST NOT REPEATABLE %C %IF COUNT>NUM DATA ITEMS %AND F_ACCESS ROUTE=Console ! FAULT=NEW RECORD -> FAULT REPORTED %UNLESS FAULT=NONE PTR= BPTR %FINISH X=IN CHAR (PTR) %AND PTR=PTR+1 !Examine the next character: ! %IF X=QUOTE %THENSTART ! ! Look at the following character ! %IF PTR>=BLEN %OR IN CHAR(PTR)\=QUOTE %THENEXIT {if quote is not repeated} ! PTR=PTR + 1 %FINISH !Save the next character: ! IO ITEM (ITEM PTR)= X %AND %C ITEM PTR = ITEM PTR + 1 %AND %C DATA LEN = DATA LEN - 1 %UNLESS DATA LEN= 0 {Go and get} { next one} %REPEAT ! ! TIDY UP THE EVALUATION ! %IF DATA LEN=DATA BYTES %THEN -> NULL LITERAL INVALID %IF DATA LEN> 0 %THENSTART ! PROPAGATE (DATA LEN,DATA AD,ITEM PTR, BLANK{s}) %FINISH ! ! Check if Literal is likely to be repeated ! %IF COUNT>NUM DATA ITEMS %THENSTART ! COPY LEN= DATA BYTES COPY INC= DATA INC COPY AD = DATA AD ITEM= SCANNED LITERAL %FINISH %FINISHELSESTART; !---input item is a scanned literal ! ! ! CHECK IF LITERAL JUST SCANNED CAN BE USED FOR CURRENT I/O ITEM ! ! %IF DATA BYTES<=COPY LEN %THENSTART ! !-----it can ! COPY (COPY LEN,COPY AD,COPY INC,DATA AD,DATA INC) %FINISHELSESTART; %IF LINES READ 0 %THENRESULT=FAULT LINES READ=LINES READ + 2 %REPEAT ! {!Now read the } FAULT=NEW RECORD {LINES READ should now equal F_LINES IN} {! record } %IF FAULT>0 %THENRESULT=FAULT ! F_CUR STATE= 2 {After Read} %FINISH ! PTR=R PTR+1 {point to the start of the literal} -> SCAN THE LITERAL %FINISH %FINISH ! ! Now Return (and report success) ! LAST DATA INC=DATA INC {in case the constant is repeated} ! %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 %HALFINTEGERFN IN FORMAT ! ! ! ! ! ! %HALFINTEGERFNSPEC ANALYSE ! ! {Input Field } %HALFINTEGER PTR {---scanning ptr through field} { Pointers} %HALFINTEGER PTR MAX {---ptr to the end of field} {Parms to TO REAL} %INTEGER INT LEN {---len and displacement of } { and TO INTEGER} %INTEGER INT PTR {--- number analysed into BUFFER} { Utility } %HALFINTEGER C ; !a character from the IO BUFFER { } { Variables } %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 %HALFINTEGER SCALE FACTOR %HALFINTEGER DECS ! ! %RESULT= FIELD TOO LARGE %IF WIDTH>1024 ! ! INITIALISE VARIABLES ! LENGTH= WIDTH ! FAULT = IN FIELD (LENGTH,BPTR,ADDR(IO BUFFER(0)),0) %IF FAULT\=NONE %THENRESULT= FAULT ! PTR=0 %AND PTR MAX=LENGTH VARIABLE TYPE= DATA TYPE BYTE COUNT = DATA BYTES !*********************************************************************** ! ! HANDLE FREE FORMAT (for list-directed input) ! !*********************************************************************** ! %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 'D' FORMAT AND 'E' FORMAT AND 'F' FORMAT AND 'Q' FORMAT ! !*********************************************************************** ! F FORMAT: DECS = NONE SCALE FACTOR= NONE {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 ! !*********************************************************************** ! 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 'L' FORMAT ! !*********************************************************************** ! 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>=PTR MAX C=IO BUFFER(PTR) %AND PTR=PTR+1 %IF C ='.' %AND PTR< PTR MAX ! ! Now look for a T or F ! %IF C\= TRUE SIGN %AND (C\='t' %OR CASE=UPPER) %THENSTART %IF C\=FALSE SIGN %AND (C\='f' %OR CASE=UPPER) %THEN -> INVALID LOGICAL ! C = FALSE %FINISH %ELSE 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 ! !*********************************************************************** ! ! ERROR REPORTING ! !*********************************************************************** ! INVALID LOGICAL: !reported by L format FAULT= INVALID LOGICAL; -> RETURN SYNTAX FAULT: PTR = 1 %IF PTR<= 0 -> RETURN FAULT REPORTED: !report a detected error and set the error ptr (BPTR) ! PTR= PTR + 1 RETURN : BPTR=(PTR - 1) + BPTR %RESULT= FAULT ! !*********************************************************************** ! ! END OF HANDLING INPUT FORMATS ! !*********************************************************************** ! ! ! EXIT: ! HERE NORMALLY ! BPTR= BPTR + PTR MAX %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 BASE ; !--always 10 to overcome a compiler fault with ** ** %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 ! {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 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 ! BASE=10 MULT=BASE ** ** (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 ) %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 %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 BASE ; !always set to 10 to overcome a compiler fault with ** ** %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 ! BASE= 10 MULT=-BASE ** ** (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 %HALFINTEGER 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 BASE ; !always set to 10 to overcome a compiler fault with ** ** %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 BASE=10 ! !Initialise variables %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=BASE ** ** (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=BASE ** ** (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= FLOAT LONG (SUM) * POWERS OF TEN (EXP+37); %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 ! !*********************************************************************** ! ! UTILITY PROCEDURES ! !*********************************************************************** ! %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 ! ! %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 %UNLESS BOOLEAN= 0 %THENRESULT= 0 {equal} **@THAT BASE ; *LDDW ; **THAT DISP **@THIS BASE ; *LDDW ; **THIS DISP **LENGTH ; *STLATE_X'63'; *LESBYT_0; **=BOOLEAN %IF BOOLEAN= 0 %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 %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)