!Modified 8/ 5/82 9.30 !**********************************************************************! !**********************************************************************! ! ! ! ! ! This Module is designed to provide Formatted 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 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 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 ) ! !*********************************************************************** ! ! GLOBAL PROCEDURE SPECIFICATIONS ! !*********************************************************************** ! %HALFINTEGERFNSPEC F77 IOA %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 IOA ( %C {! }%C {! }%C {! }%C {! }%C {! THIS PROCEDURE IS THE INTERFACE BETWEEN A FORMATTED 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 ) ) !The Parameters have the following meanings: ! ! %C DSNUM the FORTRAN channel number, %C 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 ! !*********************************************************************** ! ! 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 FIELD (%HALFINTEGER LENGTH, BUFF PTR, %INTEGER TO, TO INC) %EXTERNALHALFINTEGERFNSPEC POSITION %C DA FILE (%HALFINTEGER ACTION, %INTEGER REC NUMBER ) ! !*********************************************************************** ! ! 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 ! !*********************************************************************** ! %ROUTINESPEC GET EXTRA ERROR INFO %HALFINTEGERFNSPEC INITIALISE EXTERNAL IO OPERATION %HALFINTEGERFNSPEC INITIALISE INTERNAL IO OPERATION %HALFINTEGERFNSPEC NEW RECORD %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 UNASSIGNED VARIABLE = 401 %CONSTHALFINTEGER LITERAL IN INPUT FMT = 111 %CONSTHALFINTEGER INVALID INTEGER = 140 %CONSTHALFINTEGER INVALID REAL = 141 %CONSTHALFINTEGER INVALID CHARACTER = 148 %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 FMT TOO LARGE = 184 %CONSTHALFINTEGER INVALID LOGICAL = 135 %CONSTHALFINTEGER NULL FIELD = 133 %CONSTHALFINTEGER CONNECTION NOT FORMATTED = 194 %CONSTHALFINTEGER ACCESS CONFLICT = 119 !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! %CONSTHALFINTEGER DOT = '.' %CONSTHALFINTEGER PLUS = '+' %CONSTHALFINTEGER TRUE SIGN = 'T' %CONSTHALFINTEGER FALSE SIGN = 'F' %CONSTHALFINTEGER BLANK = ' ' %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' %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 BUFFER; !used by IN FORMAT while ! analysing a number !In Addition: ! ! Access to the current ! I/O buffer is as follows: ! ! %BYTEINTEGERARRAYNAME IO BUFFER {using the format} %BYTEINTEGERARRAYFORMAT FORM A (0: 1023) {for external files} {using the format} %BYTEINTEGERARRAYFORMAT FORM B (0:32767) {for internal files} %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 %IF RELEASE=FUTURE %THENSTART ! ! ! ! ! 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} ! ! %FINISH; !if not the current release ! ! Variables Controlling Access to the File Definition Table ! %RECORD (File Definition Table) %NAME F ! ! Buffer Variables ! %INTEGER BLEN {relative (from BSTART+BINC) end of buffer +1} , BPTR {scanning ptr through the buffer} ! ! %INTEGER BUFF LENGTH; !length of the current record %INTEGER BINC ;!%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 ! %INTEGER CHAR IO BUFF LEN; !Length of the current character I/O buffer %INTEGER CHAR IO BUFF CNT; !Number of buffers (records/array elements) ! that are still unused by the ! current internal file I/O operation ! ! Declarations of Variables Extracted from the Parameter list ! %HALFINTEGER FILE TYPE {see the PARAMETERS above } { for the values taken } { by these variables } %INTEGER DSNUM ! ! Variables Controlling Access to or from a File ! %HALFINTEGER BLANKS ATTRIBUTE; !%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 %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 %HALFINTEGER EXP WIDTH %HALFINTEGER INT WIDTH %HALFINTEGER DECIMALS %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' !*********************************************************************** ! ! FORMAT STATEMENT SPECIFIC VARIABLES ! !*********************************************************************** ! ! ! ! %IF RELEASE=FUTURE %THENSTART ! ! 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} %FINISHELSESTART {for the Current Release} ! ! Declare a Local Array for the Format Table ! %INTEGERARRAY FORMAT TABLE (0:255) ! %FINISH {Types } !CONSTHALFINTEGER A SPECIAL = X'59'; !ie. cA (no width) { } !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 ! %HALFINTEGERARRAY 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 ! ! 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 %HALFINTEGER COUNT ; !Repeat specification of an edit descriptor %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 %IF F77IO FLAG= FALSE %THENSTART; ! ! ! ! ! Initialise FIO Itself ! ! ! ! ! RUN MODE={COMREG (42)} 0 FIO MODE= NORMAL MODE START OF RT FMTS= NOT SET %AND %C RT == RECORD(NULL) %UNLESS RELEASE=CURRENT ! ! forget any area acquired for Run-Time formats ! and any record of the last format saved ! ! 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 Area: ! WORKAREA ADDR= ADDR(WORKAREA (0)) BUFFER==ARRAY(WORKAREA ADDR,FORM A) ! ! Analyse The Parameters ! CASE = {FLAGS & 16 for future releases} 1{ie. not UPPER} RELAX ANSI = FLAGS & 8 CHECK = FLAGS & 4 ! FILE TYPE = IO MODE >> 4 ! DSNUM = TCT_DSNUM %IF FILE TYPE= 5 %THENSTART FAULT=INITIALISE INTERNAL IO OPERATION %IF FAULT>0 %THEN -> BASIC IO ERROR %FINISHELSESTART 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 (FILE TYPE-6)\=F_ACCESS TYPE %THEN FAULT=ACCESS CONFLICT %C %AND -> BASIC IO ERROR %IF FILE TYPE=7 %THENSTART ! ! Perform Direct-Access Initialisation ! %UNLESS 0 BASIC IO ERROR ! FAULT= POSITION DA FILE ( 1{read},TCT_REC NUMBER) %UNLESS FAULT= NONE %THEN -> BASIC IO ERROR %FINISH ! ! ! READ THE FIRST RECORD ! ! FAULT = INREC %IF FAULT\= NONE %THEN -> BASIC IO ERROR ! !---AND NOW INITIALISE FOR PROCESSING INPUT ! BUFF LENGTH= F_RECSIZE ! !prepare to handle formatted records ! BLANKS ATTRIBUTE= F_F77BLANK; !=> a property of the connection ! IO BUFFER==ARRAY(WORKAREA ADDR+1,FORM A) %FINISH ! ! INITIALISE THE BUFFER POINTERS ! BPTR = BINC ; !-> relative start of buffer BLEN = BUFF LENGTH + BINC; !-> relative end of buffer !-> IO FORM (FORM) ! ! ! !*********************************************************************** ! ! PERFORM FORMAT STATEMENT INPUT FORMATTING ! !*********************************************************************** ! %C FORM (FORMAT IN ARRAY ) %C FORM (FORMAT STATEMENT) SCALE=NONE %AND EXP WIDTH= NONE %C %AND WIDTH= UNDEFINED BLANKS=BLANKS ATTRIBUTE !The 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. ! ! ! %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 %IF RELEASE=FUTURE %THENSTART ! ! FAULT=FMT TOO LARGE %AND %C -> BASIC IO 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 ! FAULT=125; !OUTFILE(RT FMT AREA NAME,RT FORMAT SIZE, MAX RT FORMAT SIZE,0, START OF RT FMTS,FAULT) -> BASIC IO ERROR %UNLESS FAULT=NONE %FINISH ! {Convert the Format} {!} FMT AD=START OF RT FMTS FAULT= FORMATCD(TXT ADR,TXT INC, FMT AD, TXT LEN, RT FORMAT SIZE, RELAX ANSI,1,FMT LEN,I) %UNLESS FAULT= NONE %THEN -> BASIC IO 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,FAULT) FAULT = 125 -> BASIC IO ERROR %IF FAULT\= 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))) ! FAULT= FORMATCD (TXT ADR,TXT INC,FMT AD , TXT LEN,FMT MAX,RELAX ANSI,1,FMT LEN,I) %IF FAULT\= 0 %THENSTART ! ! Throw away the Work-Area ! RT==RECORD(NULL) -> BASIC IO 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 ! ! ! Encode the Format for the Current Release ! ! FMT AD= ADDR (FORMAT TABLE(0)) FAULT= FORMATCD (TXT ADR,TXT INC, FMT AD ,TXT LEN, 255 {integers+1}, RELAX ANSI, 1 , I , J ) -> BASIC IO ERROR %UNLESS FAULT=NONE %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 ! FAULT=NO FMT FOR IO ITEM %AND -> IO ERROR %C %IF WIDTH=UNDEFINED FMT==RESTART POINT !**************************** END OF RECORD **************************** ! ! FMT TYPE (SLASH): FAULT= NEW RECORD %IF FAULT>0 %THEN -> IO ERROR 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): -> 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'): -> HOLERITHS !**************************** nHliteral - 'literal' ******************** ! ! FMT TYPE ('H'): -> HOLERITHS ! !*********************************************************************** ! ! PERFORM HOLERITH OUTPUT ! !*********************************************************************** ! HOLERITHS: ! FAULT=LITERAL IN INPUT FMT %AND -> IO ERROR DO FORMATTING: ! !*********************************************************************** ! ! CHECK FOR COMPLETION OF I/O OPERATION ! !*********************************************************************** ! %IF MORE IO ITEMS=FALSE %THENSTART TIDY UP: -> RETURN %FINISH ! !*********************************************************************** ! ! CALL THE INPUT FORMATTING ROUTINE ! !*********************************************************************** ! %IF POSITIONING\=NONE %THEN BPTR=BPTR+POSITIONING %AND POSITIONING=NONE ! FAULT= IN FORMAT %IF FAULT> 0 %THEN -> IO ERROR ! !*********************************************************************** ! ! 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 DATA TYPE = A REAL %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 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. ! ! ! %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= BINC 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> %C (FILE TYPE-5),AFD) %IF FAULT\=NONE %THENRESULT=FAULT ! F==RECORD(AFD); !map address of file definition table ! onto the corresponding record fmt BINC= 0 %RESULT= 0 %END; !of INITIALISE EXTERNAL IO OPERATION %HALFINTEGERFN INITIALISE INTERNAL IO OPERATION ! ! ! ! ! A Procedure that prepares for an Internal File ! ! Operation. The First record is also read. ! ! ! %RECORD (Form of an Internal File Desc{ription}) %C {!} %C %NAME IF; !mapped onto the description of the Character ! I/O buffer in the Transfer Control Table ! ! ! Initialise for Internal File Input (core I/O) ! ! IF==TCT_INTERNAL FILE DESC{ription} ! CHAR IO BUFF CNT = IF_COUNT CHAR IO BUFF LEN = IF_LENGTH BUFF LENGTH= CHAR IO BUFF LEN BINC = IF_INC IO BUFFER== ARRAY(IF_ADDRESS,FORM B) ! ! Prepare for Internal File input ! %IF CHECK\=FALSE %AND IO BUFFER(BINC)=X'80' %C %THEN %RESULT =UNASSIGNED VARIABLE !The buffer is ! useless as it is unassigned BLANKS ATTRIBUTE=TRUE %RESULT=0 %END; !of INITIALISE INTERNAL IO OPERATION %HALFINTEGERFN NEW RECORD ! ! ! ! ! A PROCEDURE TO ACQUIRE A NEW RECORD EITHER FROM AN ! ! INTERNAL FILE OR AN EXTERNAL FILE. ! ! ! %HALFINTEGER FAULT ; !the result variable %IF FILE TYPE=5 %THENSTART ! ! ! Get a new record from an Internal File ! ! CHAR IO BUFF CNT = CHAR IO BUFF CNT-1 %IF CHAR IO BUFF CNT<= NONE %THENSTART; !end-of-file violation ! FAULT= INPUT ENDED -> REPORT FAULT %FINISH {Point to the next record} BINC= BINC + CHAR IO BUFF LEN BLEN= BINC + CHAR IO BUFF LEN ! ! 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 !process an external file ! ! ! Read another record from an External File ! ! FAULT= INREC %IF FAULT\= NONE %THEN -> REPORT FAULT {%ELSE extract the record length} ! BLEN=F_RECSIZE %FINISH; !external file I/O ! ! Re-set the buffer ptr ! 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 %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 %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} ! %INTEGER END OF FIELD {end of field relative to buffer start} %INTEGER PTR MAX {end of field relative to field start} {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('D':'Z') !NOTE that should a field extend over a record boundary then we will ! not report RECORD TOO SMALL so long as we are not reading from ! an Internal File and as long as the user does not assume that ! the record is longer than 84 (the screen width). Under these ! circumstances the input field will be padded out by as many ! spaces as required using the following variables: ! %HALFINTEGER SPACES REQD %HALFINTEGER INPUT LEFT {in the actual record} !Initialise Variables: ! VARIABLE TYPE = DATA TYPE ; LENGTH= WIDTH BYTE COUNT= DATA BYTES; FORMAT= FMTCODE %IF FORMAT= A SPECIAL %THEN LENGTH=BYTE COUNT %AND FORMAT= 'A' ! ! Validate the Field Length ! END OF FIELD= BPTR + LENGTH %IF END OF FIELD> BLEN %THENSTART ! -> RECORD TOO SMALL %IF END OF FIELD>84 %C %OR FILETYPE= 5 {Determine } { input available} INPUT LEFT=BLEN - BPTR {and } INPUT LEFT=NONE%IF INPUT LEFT< NONE { spaces required } SPACES REQD= END OF FIELD - BPTR %C - INPUT LEFT %FINISHELSE SPACES REQD= NONE %C %AND INPUT LEFT= LENGTH ! ! Initialise the I/O Field Variables ! %IF FILETYPE= 5 %THEN PTR=BPTR %AND PTR MAX=END OF FIELD %C %ELSE PTR= 0 %AND PTR MAX=LENGTH %IF FORMAT='A' %OR (FORMAT='G' %AND VARIABLE TYPE=5) %THENSTART ! !*********************************************************************** ! ! HANDLE 'A' FORMAT ! !*********************************************************************** ! DATA INC=0 %UNLESS DATA TYPE=A CHARACTER ! %UNLESS LENGTH=BYTE COUNT %THENSTART N=LENGTH - BYTE COUNT %IF N>0 %THENSTART ! ! Handle too much input ! INPUT LEFT= INPUT LEFT - N %IF INPUT LEFT< 0 %THEN SPACES REQD=SPACES REQD + INPUT LEFT %C %AND INPUT LEFT=NONE PTR=PTR + N %AND LENGTH=BYTE COUNT ! %FINISHELSESTART ! ! Handle too little input ! SPACES REQD=NONE PROPAGATE(BYTE COUNT,DATA AD,DATA INC,BLANK) %FINISH %FINISH %IF FILETYPE= 5 %THENSTART ! ! Assign the Variable from Internal File Input ! COPY(LENGTH,ADDR(IO BUFFER(0)),PTR,DATA AD,DATA INC) %FINISHELSESTART ! ! Assign the Variable from External File Input ! %IF INPUT LEFT>NONE %THENSTART ! FAULT= IN FIELD (INPUT LEFT,BPTR+PTR,DATA AD,DATA INC) %IF FAULT> 0 %THENRESULT= FAULT %FINISH %IF SPACES REQD>0 %THEN PROPAGATE(SPACES REQD,DATA AD , INPUT LEFT+DATA INC,BLANK) %FINISH %FINISHELSESTART %IF FILE TYPE\=5 %THENSTART ! ! ! Get a Copy of the Input Field for all other formats ! ! %IF INPUT LEFT>0 %THENSTART FAULT=IN FIELD(LENGTH,BPTR,ADDR(IO BUFFER(0)),0) %IF FAULT> 0 %THENRESULT=FAULT %FINISH PROPAGATE(SPACES REQD,ADDR(IO BUFFER(0)),INPUT LEFT,BLANK) %C %IF SPACES REQD> NONE %FINISH ! COPY OF PTR= PTR %AND -> FORMAT TYPE (FORMAT) !*********************************************************************** ! ! HANDLE 'G' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('G'): ! %IF VARIABLE TYPE=4 %THEN -> L 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 ! 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 '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>=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 !*********************************************************************** ! ! 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 < PTR MAX %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 : %UNLESS FILETYPE= 5 %THEN BPTR= BPTR + (PTR-1) %C %ELSE BPTR= PTR - 1 %RESULT=FAULT %FINISH ! !*********************************************************************** ! ! END OF HANDLING INPUT FORMATS ! !*********************************************************************** ! ! ! EXIT: ! HERE NORMALLY ! BPTR= END OF FIELD %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 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 %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 ! 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 %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 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 %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 BASE ; !set to 10 to overcome 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 B) %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)