!Modified 26/ 4/82 12.00 !**********************************************************************! !**********************************************************************! ! ! ! ! ! This Module is designed to provide Formatted Output ! ! ! ! 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 IOB %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 IOB ( %C {! }%C {! }%C {! }%C {! }%C {! THIS PROCEDURE IS THE INTERFACE BETWEEN A FORMATTED OUTPUT }%C {! }%C {! STATEMENT IN THE USER PROGRAM AND THE UNDERLYING }%C {! }%C {! SYSTEM-DEPENDENT PROCEDURES OF THE FORTRAN77 }%C {! }%C {! RUN-TIME SYSTEM. }%C {! }%C {! }%C {! At Exit: RESULT= 1 if the END= label is to be used }%C {! RESULT= 2 if the ERR= label is to be used }%C {! RESULT= 0 otherwise }%C {! }%C {!-Parameters: }%C {! ! }%C {parm1} %RECORD (Transfer Control Table) %NAME TCT , {parm2} %HALFINTEGER KEY , {parm3} %HALFINTEGER FORM , {parm4} %HALFINTEGER IO MODE , {parm5} %HALFINTEGER FLAGS , {parm6} %HALFINTEGER SPECIFIER FLAGS , %C {parm7} %HALFINTEGERFN IO ITEM (%HALFINTEGER KEY , %INTEGER SIZE TYPE ADR, %INTEGERNAME ADDRESS ) ) !The Parameters have the following meanings: ! ! %C DSNUM the FORTRAN channel number, IO MODE classifies the I/O statement ! X'5x' if Internal File I/O, X'6x' if Sequential File I/O, X'7x' if Direct-Access File I/O {where x=1 if input } { or x=2 if output} !also X'04' if Rewind and X'20' if Open, X'08' if Backspace X'40' if Close, X'10' if Endfile X'80' if Inquire, %C FILE TYPE defines the type of file access {5 if an Internal File } {6 if a Sequential File } {7 if a Direct-Access File} !%C FORM classifies the processing required, as follows: %CONSTINTEGERC UNFORMATTED IO = 0 , FORMAT IO = 1 , FORMAT IN ARRAY= 2 , LIST DIRECTED IO= 3 , REWIND = 7 , BACKSPACE = 7 , ENDFILE = 7 , OPEN CLOSE AND INQUIRE= 8 ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL ERROR HANDLING ROUTINES ! !*********************************************************************** ! %EXTERNALROUTINESPEC SSMESS (%HALFINTEGER FAULT) %EXTERNALROUTINESPEC F77IOERR (%HALFINTEGER STACK %C TRACEBACK) ! !*********************************************************************** ! ! SPECIFICATIONS FOR EXTERNAL I/O HANDLING ROUTINES ! !*********************************************************************** ! %EXTERNALHALFINTEGERFNSPEC NEW FILE OP (%INTEGER DSNUM , %HALFINTEGER ACTION, FILETYPE, %INTEGERNAME FD TABLE ADDRESS) %EXTERNALHALFINTEGERFNSPEC OUT CHAR (%HALFINTEGER CHAR, AT) %EXTERNALHALFINTEGERFNSPEC OUT FILL (%HALFINTEGER LENGTH, AT, WITH) %EXTERNALHALFINTEGERFNSPEC OUT FIELD (%HALFINTEGER LENGTH, %INTEGER FROM ADR, %INTEGER FROM INC, %HALFINTEGER BUFF PTR) %EXTERNALHALFINTEGERFNSPEC OUT REC %EXTERNALHALFINTEGERFNSPEC POSITION DA FILE (%HALFINTEGER ACTION, %INTEGER RECORD ID) ! !*********************************************************************** ! ! 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 OUT FORMAT %INTEGERFNSPEC ARRAY ADDRESS ( %INTEGER DV ADDR , %HALFINTEGER DATA TYPE ) %HALFINTEGERFNSPEC UNASSIGNED CHECK (%INTEGER ADR, %HALFINTEGER LEN) %HALFINTEGERFNSPEC BYTE AT (%INTEGER ADR, %HALFINTEGER INC) %ROUTINESPEC FILL BUFF (%INTEGER LENGTH, %HALFINTEGER AT INC, WITH) %ROUTINESPEC PROPAGATE (%INTEGER LENGTH, %INTEGER BASE, %HALFINTEGER AT INC, WITH) %ROUTINESPEC COPY (%INTEGER LENGTH, %INTEGER FROM, %HALFINTEGER FROM DISP , %INTEGER TO , %HALFINTEGER TO DISP ) %INTEGERFNSPEC COMPARE (%INTEGER LENGTH, %INTEGER THIS BASE, %HALFINTEGER THIS INC , %INTEGER THAT BASE, %HALFINTEGER THAT INC ) !*********************************************************************** ! ! ERROR MESSAGES ! !*********************************************************************** ! %CONSTHALFINTEGER UNASSIGNED VARIABLE = 401 %CONSTHALFINTEGER RECORD TOO SMALL = 154 %CONSTHALFINTEGER INCOMPATIBLE FORMAT = 155 %CONSTHALFINTEGER RECORD OUT OF RANGE = 158 %CONSTHALFINTEGER NO FMT FOR IO ITEM = 159 %CONSTHALFINTEGER FILE FULL = 169 %CONSTHALFINTEGER FMT TOO LARGE = 184 %CONSTHALFINTEGER INVALID SCALING = 134 %CONSTHALFINTEGER CONNECTION NOT FORMATTED = 194 %CONSTHALFINTEGER ACCESS CONFLICT = 119 !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! %CONSTHALFINTEGER DOT = '.' %CONSTHALFINTEGER STAR = '*' %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 POINT ONE = R'4019999A' %CONSTREAL TEN TO THE 38= R'604B3B4D' %CONSTREAL TEN TO THE %C MINUS 36= R'23154485' %FINISH; !if not PERQ %IF SYSTEM=PERQ %THENSTART ! ! %CONSTINTEGERARRAY PERQ POWERS OF TEN (-37:38) %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' ! ! Other Floating Point Constants ! %CONSTINTEGER PERQ POINT ONE = X'3DCCCCCD' %CONSTINTEGER PERQ TEN TO THE 38= X'7E967699' %CONSTINTEGER PERQ TEN TO THE %C MINUS 36= X'03AA2425' %OWNREALARRAYNAME POWERS OF TEN; !mapped onto PERQ POWERS OF TEN ! %OWNREALNAME POINT ONE ; !mapped onto PERQ POINT ONE %OWNREALNAME TEN TO THE 38; !mapped onto PERQ TEN TO THE 38 %OWNREALNAME TEN TO THE %C MINUS 36; !mapped onto PERQ TEN TO THE MINUS 36 ! ! %FINISH; !if PERQ !*********************************************************************** ! ! INTERNAL WORK-AREAS ! !*********************************************************************** ! {---TEMPORARILY----->} %BYTEINTEGERARRAY IO FIELD (0:1023) ! %INTEGER FIELD ADDR; !address of IO FIELD !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 file I/O} {using the format} %BYTEINTEGERARRAYFORMAT FORM B (0:32767) {for internal file I/O} %REALARRAYFORMAT FORM C (-37:38 ) {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} ! ! 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 %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 end of buffer +1} , BPTR {scanning ptr through the buffer} , MAX BPTR { maximum value of BPTR achieved} ! while writing to an output buffer ! %INTEGER BUFF LENGTH; !length of the current record %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 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 %HALFINTEGER PLUS SIGN {='+' if a sign is mandatory, else set to zero} %INTEGER SCALE %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 ! %INTEGER TEXT LEN ; !Descriptor to a %INTEGER TEXT AD ; ! holerith store location ! ! FORMAT TABLE PROCESSING VARIABLES ! %INTEGER POSITIONING; !As is defined by an nX or Tc or TLc or TRc format ! and applied to the buffer pointer before any I/O %INTEGER COUNT ; !Repeat specification of an edit descriptor %INTEGER PTR ; !Pointer into the current I/O buffer %INTEGER I,J ; !Entries in the Format Table %SWITCH FMT TYPE ('A':REPETITION) ! ! VARIABLES ASSOCIATED WITH AN I/O LIST ! %HALFINTEGER MORE IO ITEMS ; !boolean variable: 0=> End of List ! else=> More Items %INTEGER VARIABLE ADDRESS ; !address of the next I/O item %HALFINTEGER NOS PER ITEM ; !set 2 for Complex variables !set 1 for other variable types %HALFINTEGER ITEM TYPE; !the result from !the coroutine as follows: -1 if no more items ! 0 if a scalar ! 1 if an array ! 2 if a Character scalar %IF F77IO FLAG= FALSE %THENSTART; ! ! ! ! ! Initialise FIO Itself ! ! ! ! ! RUN MODE={COMREG (42)} 0 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(-37)),FORM C) !! POINT ONE == POWERS OF TEN(- 1) TEN TO THE 38== POWERS OF TEN( 38) TEN TO THE %C MINUS 36== POWERS OF TEN(-36) F77IO FLAG= TRUE; ! (for EMAS or PERQ) ! !----->END OF INTERNAL INITIALISATION ! %FINISH !Initialise FIELD ADDR: ! FIELD ADDR= ADDR(IO FIELD(0)) ! ! Analyse The Parameters ! 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 ( 2{write},TCT_REC NUMBER) %UNLESS FAULT= NONE %THEN -> BASIC IO ERROR %FINISH ! ! ! PREPARE FOR PROCESSING OUTPUT ! ! %IF FILE TYPE=7 %THEN BUFF LENGTH= F_RECSIZE %C %ELSE BUFF LENGTH= F_MAXREC %FINISH; !preparing external file I/O ! ! INITIALISE THE BUFFER POINTERS ! BPTR = BINC ; !-> relative start of buffer MAX BPTR = BINC ; !-> maximum value of BPTR BLEN = BUFF LENGTH + BINC; !-> relative end of buffer !-> IO FORM (FORM) ! ! ! !*********************************************************************** ! ! PERFORM FORMAT STATEMENT OUTPUT FORMATTING ! !*********************************************************************** ! %C FORM (FORMAT IN ARRAY ) %C FORM (FORMAT STATEMENT) SCALE= NONE %AND EXP WIDTH= NONE PLUS SIGN = NONE %AND WIDTH= UNDEFINED !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): -> NEXT FORMAT !**************************** S - SP - SS ****************************** ! %C FMT TYPE (S) : %C FMT TYPE (SP): FMT TYPE (SS): PLUS SIGN= FMT_VALUE %IF PLUS SIGN= 0 %THEN PLUS SIGN= PLUS %C %ELSE PLUS SIGN= NONE -> NEXT FORMAT !**************************** TRc - nX ********************************* ! ! FMT TYPE ('X'): FMT TYPE (TR) : POSITIONING= POSITIONING + FMT_VALUE ! ! NOTE that the 'T' format does not cause data to ! be transmitted. Also note that ANSI does ! not define the effect of positioning after ! the end of a record. ! ! ANSI specifically states that 'X' positioning ! beyond the end of an input record is ! allowed BUT no mention is made of output -> NEXT FORMAT !**************************** TLc ************************************** ! ! FMT TYPE (TL): POSITIONING= FMT_VALUE - POSITIONING POSITIONING= BPTR-BINC %IF POSITIONING>=BPTR-BINC POSITIONING=-POSITIONING !NOTE that TL may cause ! positioning which preceeds the buffer, and as per ANSI ! such positioning is forced onto the start of the buffer -> NEXT FORMAT !**************************** Tc *************************************** ! ! FMT TYPE ('T'): POSITIONING= (FMT_VALUE - 1) - (BPTR-BINC) -> NEXT FORMAT !**************************** nP *************************************** ! ! FMT TYPE (POSITIVE SCALE): SCALE= FMT_VALUE ; -> NEXT FORMAT FMT TYPE (NEGATIVE SCALE): SCALE= -(FMT_VALUE) ; -> NEXT FORMAT !**************************** a repeated format ************************ ! ! FMT TYPE (REPETITION): COUNT= FMT_VALUE -> NEXT FORMAT !****************************** Iw.m *********************************** ! ! FMT TYPE ( I SPECIAL): WIDTH= FMT_VALUE ; FMT==FMT_NEXT ENTRY INT WIDTH= FMT_VALUE2 -> DO FORMATTING !********** Dw.d - Ew.d - Fw.d - Gw.d - Qw.d - Ew.dEe - Gw.dEe ********* ! ! FMT TYPE ('D'): FMT TYPE ('E'): FMT TYPE ('F'): FMT TYPE ('G'): FMT TYPE ('Q'): WIDTH= FMT_VALUE %AND FMT==FMT_NEXT ENTRY EXP WIDTH= FMT_VALUE1 DECIMALS = FMT_VALUE2 ! -> DO FORMATTING !*********************** A - Aw - Iw - Lw - Zw ************************* ! ! FMT TYPE ('I'): INT WIDTH= 0 FMT TYPE ( A SPECIAL): FMT TYPE ('A'): FMT TYPE ('L'): FMT TYPE ('Z'): WIDTH= FMT_VALUE -> DO FORMATTING !************** SINGLE CHARACTER HOLERITHS AND LITERALS **************** ! ! FMT TYPE ('C'): TEXT LEN= 1 TEXT AD = ADDR(FMT_VALUE) ! -> HOLERITHS !**************************** nHliteral - 'literal' ******************** ! ! FMT TYPE ('H'): TEXT LEN= FMT_VALUE TEXT AD = ADDR(FMT_NEXT ENTRY) ! FMT==RECORD( (TEXT AD-2) + ( (TEXT LEN + 3) & X'FFFC') >> 1) !==addr of holerith address ! + holerith length rounded up to an integer boundary ! and converted to a word displacement ! !*********************************************************************** ! ! PERFORM HOLERITH OUTPUT ! !*********************************************************************** ! HOLERITHS: ! %IF POSITIONING\=0 %THEN BPTR=BPTR+POSITIONING %AND POSITIONING= NONE %IF BPTR>BLEN %THEN ->RECORD TOO SMALL ! %IF BPTR> MAX BPTR %THENSTART ! ! The 'T' or 'X' edit code has been used to re-specify ! the position of the buffer pointer in a ! forwards direction. Now is the time to move ! spaces into the unfilled positions. ! %UNLESS FILETYPE=5 %THENSTART ! ! Space-Fill the (External) Record ! FAULT= OUT FILL(BPTR-MAXBPTR,MAXBPTR,BLANK) %IF FAULT> 0 %THEN -> IO ERROR %FINISHELSE FILL BUFF(BPTR-MAXBPTR,MAXBPTR,BLANK) MAX BPTR=BPTR %FINISH ! PTR =BPTR + TEXT LEN %IF PTR >BLEN %THEN -> RECORD TOO SMALL ! ! MOVE HOLERITH INTO THE OUTPUT BUFFER ! %IF FILETYPE\= 5 %THENSTART ! !---for an External File ! FAULT=OUT FIELD (TEXT LEN,FMT AD, (TEXT AD -FMT AD)<<1,BPTR) -> IO ERROR %IF FAULT\= 0 %FINISHELSESTART ! !---for an Internal File ! COPY (TEXT LEN,FMT AD, (TEXT AD-FMT AD)<<1, ADDR(IO BUFFER (0)) , BPTR) %FINISH ! ! Move onto the next format item ! BPTR= PTR MAX BPTR=BPTR %IF BPTR>MAX BPTR ! !Update current buffer position and also ! 'last position written' if applicable ! -> NEXT FORMAT RECORD TOO SMALL: BPTR=MAX BPTR %AND FAULT=RECORD TOO SMALL %C %AND -> IO ERROR DO FORMATTING: ! !*********************************************************************** ! ! CHECK FOR COMPLETION OF I/O OPERATION ! !*********************************************************************** ! %IF MORE IO ITEMS=FALSE %THENSTART TIDY UP: %IF FILE TYPE\=5 %THENSTART ! ! Output the Last Record ! FAULT= NEW RECORD %IF FAULT> 0 %THEN -> IO ERROR %FINISH -> RETURN %FINISH ! !*********************************************************************** ! ! CALL THE OUTPUT FORMATTING ROUTINE ! !*********************************************************************** ! %IF POSITIONING\=NONE %THEN BPTR=BPTR+POSITIONING %AND POSITIONING=NONE ! %IF BPTR>MAXBPTR %AND BPTR IO ERROR %UNLESS FAULT=NONE ! %FINISH; MAX BPTR= BPTR %FINISH ! FAULT= OUT FORMAT %UNLESS FAULT=NONE %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} ! TCT_IOSTAT VALUE= ERROR {first set the IOSTAT value} ! ! Check Label Exits ! %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 %AND 0OUTPUT 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 IO BUFFER== ARRAY(FIELD ADDR,FORM A) BINC=0 %RESULT=0 %END; !of INITIALISE EXTERNAL IO OPERATION %HALFINTEGERFN INITIALISE INTERNAL IO OPERATION ! ! ! ! ! A Procedure that prepares for an Internal File ! ! Operation. If a Read Request is to be serviced ! ! then the first record is 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/Output (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 output ! FILL BUFF (BUFF LENGTH, BINC, BLANK) {Pre-fill the } { character output buffer} { with ISO spaces} %RESULT=0 %END; !of INITIALISE INTERNAL IO OPERATION %HALFINTEGERFN NEW RECORD ! ! ! ! ! A PROCEDURE TO ACQUIRE A NEW RECORD FOR EITHER A READ OPERATION ! ! OR FOR A WRITE OPERATION. THE FILE MAY BE EITHER AN INTERNAL ! ! FILE OR AN EXTERNAL FILE. ! ! ! %INTEGER BUFF LENGTH ; !the length of the current record %HALFINTEGER MINREC ; !the minimum length required of an output record %HALFINTEGER FAULT ; !the result variable %IF FILE TYPE=5 %THENSTART; BUFF LENGTH= CHAR IO BUFF LEN ! ! ! 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= FILE FULL -> REPORT FAULT %FINISH {Point to the next record} BINC= BINC + BUFF LENGTH BLEN= BINC + BUFF LENGTH ! ! Prepare a new record for an Internal File ! FILL BUFF (BUFF LENGTH, BINC, BLANK) %FINISHELSESTART !process an external file ! ! ! Write a record to an External File ! ! BPTR= MAX BPTR %IF MAX BPTR>BPTR BUFF LENGTH= BPTR %IF BUFF LENGTH= 0 %THENSTART ! ! Put a Blank in the Buffer ! FAULT= OUT CHAR (BLANK,0) %IF FAULT> 0 %THENRESULT=FAULT ! BUFF LENGTH= 1 %FINISH MINREC=F_MINREC %IF MINREC>BUFF LENGTH %THENSTART ! FAULT= OUT FILL (MINREC-BUFF LENGTH,BUFF LENGTH,BLANK{s}) %RESULT=FAULT %UNLESS FAULT=NONE %FINISH ! ! NOW WRITE THE RECORD OUT ! FAULT = OUTREC -> REPORT FAULT %IF FAULT\= NONE ! ! Tidy up after the output operation ! %IF FILE TYPE=7 %THEN BLEN= F_RECSIZE %C %ELSE BLEN= F_MAXREC %FINISH; !external file output ! ! Re-set the buffer variables ! MAX BPTR= BINC BPTR= BINC ! %RESULT= 0 !REPORT FAULT: REPORT FAULT: !REPORT FAULT: BPTR=UNDEFINED ; %RESULT=FAULT {Inhibit error handling} { from displaying a } { non-existant buffer} %END; !of NEW RECORD %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 UNASSIGNED CHECK ( %INTEGER DATA AD , %HALFINTEGER DATA BYTES ) ! ! ! ! ! THIS IS A UTILITY PROCEDURE TO PERFORM UNASSIGNED ! ! VARIABLE CHECKING IN A MACHINE-INDEPENDENT FORM. ! ! !Note: The data type is assumed NOT to be of type CHARACTER ! ! ! %IF DATA BYTES = 2 %THENSTART ! %RESULT=FALSE %IF HALFINTEGER(DATA AD)\=X'8080' %FINISHELSESTART; %RESULT=FALSE %IF INTEGER(DATA AD)\=X'80808080' %FINISH; %RESULT= TRUE ! ! %END; !of UNASSIGNED CHECK %HALFINTEGERFN OUT FORMAT ! ! ! ! ! %ROUTINESPEC OUTPUT Z FORMAT %REALFNSPEC INTO RANGE (%REAL VALUE) ! ! ! %CONSTINTEGERARRAY MIN PER WIDTH (0:10)= 0, -9, -99, -999, -9999, -99999, -999999, -9999999, -99999999, -999999999, X'80000000' ! !Each array element corresponds to a value of ! WIDTH, and denotes the largest negative ! integer that may be formatted given that ! value of WIDTH ! %OWNBYTEINTEGERARRAY OUTPUT AREA (0:1023); !%C OUTPUT AREA is used to save the generated %C digits while formatting a value ! ! POINTERS ! %INTEGER AREA PTR ; !Ptr used to save numerals in the work-area %INTEGER PTR ; !Ptr used to construct a value in the output field %INTEGER PTR MAX ; !addresses the end of the output field (+1) %HALFINTEGER IO ITEM {FORTRAN type of } %HALFINTEGER DATA LEN { the I/O item} %HALFINTEGER FORMAT {Variables } %HALFINTEGER DECS { describing } %HALFINTEGER SCALE FACTOR { the format } %HALFINTEGER LENGTH { code} %REAL A {REAL value to format } %HALFINTEGER SIGN {='+' or '-' or NONE } %HALFINTEGER EXP {scale of the value to be formatted } %HALFINTEGER ROUNDING {scale of the rounding to be applied} %INTEGER I {INTEGER value to format} %INTEGER M {a scale factor} %INTEGER Q {a quotient } %HALFINTEGER N {a utility variable} %HALFINTEGER MAX INT DIGITS {max digits allowed left of '.'} %HALFINTEGER INT DIGITS {no of digits reqd left of '.' } %HALFINTEGER LEADING ZEROS {no of zeros reqd left of '.' } %HALFINTEGER TOTAL CHARS {no of digits reqd on both sides of '.'} %HALFINTEGER EXPONENT {value of an exponent } %HALFINTEGER EXP TYPE {='D' or 'E' or 'Q' or NONE} %HALFINTEGER EXP LENGTH {no of digits reqd in formatted exponent} ! %HALFINTEGER FAULT ! %CONSTHALFINTEGER MAX SCALE= 36 !=the highest power of ten that may ! be applied to a rounding factor %SWITCH FORMAT TYPE('A':'Z') ! ! INITIALISE VARIABLES ! LENGTH = WIDTH LENGTH = DATA BYTES %IF LENGTH=NIL ! %IF BPTR+LENGTH>BLEN %THENSTART %IF BPTR>BLEN %THEN BPTR=MAX BPTR ! %RESULT=RECORD TOO SMALL %FINISH %IF FILETYPE=5 %THEN PTR=BPTR %C %ELSE PTR= 0 PTR MAX= PTR+LENGTH {copy details of the I/O item} IO ITEM= DATA TYPE DATA LEN = DATA BYTES ! ! SPACE FILL THE OUTPUT BUFFER ! FILL BUFF (LENGTH,PTR,BLANK) %IF FMTCODE\='A' %C %AND FMTCODE\= A SPECIAL %IF CHECK\=FALSE %AND FMTCODE\='Z' %THENSTART ! ! PERFORM UNASSIGNED CHECKING ! %IF IO ITEM=A CHARACTER %THENSTART ! -> UNASSIGNED VARIABLE %IF BYTE AT (DATA AD , DATA INC)=X'80' %FINISHELSESTART ! ! Test for an unassigned INTEGER or REAL or COMPLEX or LOGICAL ! %IF UNASSIGNED CHECK(DATA AD,DATA LEN)=TRUE %THEN -> UNASSIGNED VARIABLE ! %FINISH %FINISH FORMAT =FMTCODE ! %IF 'D'<=FORMAT<='J' %OR %C FORMAT ='Q' %THENSTART; !NUMERIC FORMATTING IS REQUIRED %IF FORMAT ='G' %THENSTART ! %IF RELAX ANSI\=FALSE %THENSTART ! %IF IO ITEM= A CHARACTER %THEN -> A FORMAT %IF IO ITEM= A LOGICAL %THEN -> L FORMAT %IF IO ITEM=AN INTEGER %THEN FORMAT='I' %FINISHELSESTART %IF IO ITEM\=A REAL %THEN -> FAULT 155 %FINISH %FINISHELSESTART; %IF IO ITEM=A CHARACTER %THEN -> FAULT 155 %FINISH ! ! ! PICK UP THE VALUE TO BE FORMATTED NUMERICALLY ! ! %IF IO ITEM=A REAL %THENSTART ! A= REAL(DATA AD) + 0.0 {to normalise} %FINISHELSESTART ! %IF IO ITEM=AN INTEGER %THENSTART ! ! Get an INTEGER*4 or INTEGER*2 ! %IF DATA LEN=2 %THEN I=HALFINTEGER(DATA AD) %C %ELSE I= INTEGER(DATA AD) -> I FORMAT %IF FORMAT='I' %C %OR FORMAT= I SPECIAL -> INCOMPATIBLE FORMAT {otherwise} %FINISHELSE -> INCOMPATIBLE FORMAT %FINISH ! ! HANDLE A NEGATIVE VALUE ! %IF A<0.0 %THEN A=-A %AND SIGN=MINUS %C %ELSE SIGN=PLUS SIGN LENGTH= LENGTH -1 %UNLESS SIGN=NONE ! ! INITIALISE WORK-AREA VARIABLES ! AREA PTR= 0 {displacement into OUTPUT AREA} EXP= 1 %FINISH; !preparing for numeric formatting -> FORMAT TYPE (FORMAT) !*********************************************************************** ! ! HANDLE 'A' FORMAT (with or without a WIDTH) ! !*********************************************************************** ! FORMAT TYPE ( A SPECIAL): FORMAT TYPE ('A'): DATA INC= 0 %IF DATA TYPE\=A CHARACTER ! A FORMAT: !%C A FORMAT writes directly into the I/O Buffer without going through the%C intermediate area IO FIELD (for efficency, and IO FIELD may %C be too small). Hence it has to be aware of the file type, -be%C it an internal or external file. N=LENGTH - DATA LEN %IF N>0 %THENSTART ! ! Place some leading blanks in the buffer ! %IF FILETYPE=5 %THENSTART ! FILL BUFF (N,BPTR, BLANK{s}) %FINISHELSESTART FAULT= OUT FILL (N,BPTR, BLANK{s}) %IF FAULT> 0 %THENRESULT=FAULT %FINISH BPTR = BPTR+N %FINISHELSE DATA LEN=LENGTH %IF FILETYPE=5 %THENSTART ! ! Output Characters to an Internal File ! COPY(DATA LEN,DATA AD,DATA INC , ADDR(IO BUFFER(0)),BPTR) %FINISHELSESTART ! ! Output Characters to an External File ! FAULT= OUT FIELD (DATA LEN,DATA AD,DATA INC,BPTR) %IF FAULT> 0 %THENRESULT=FAULT %FINISH PTR MAX=BPTR + DATA LEN -> EXIT !*********************************************************************** ! ! HANDLE 'D' FORMAT AND 'E' FORMAT AND 'Q' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('D'): FORMAT TYPE ('E'): FORMAT TYPE ('Q'): %IF IO ITEM\=A REAL %THEN -> INCOMPATIBLE FORMAT D FORMAT: ! {!Examine the scale factor} DECS= DECIMALS ! SCALE FACTOR= SCALE %IF SCALE FACTOR> 0 %THENSTART {adjust the } ROUNDING= DECS + 1 { DECIMALS} DECS= ROUNDING - SCALE FACTOR { field } %IF DECS< 0 %THEN -> SCALING INVALID %FINISHELSESTART ;!%C %IF SCALE FACTOR<=0 %THENSTART {determine } ROUNDING = DECS + SCALE FACTOR { the } %IF ROUNDING<= NONE %THENSTART { rounding} ! { factor } -> SCALING INVALID %IF SCALE FACTOR\=NONE %FINISH ; %FINISH ! %IF IMOD(ROUNDING)>MAX SCALE %THEN ROUNDING=MAX SCALE ! %IF A=0.0 %THEN EXPONENT=NONE %C %AND EXP =NONE %ELSESTART !Bring the value into the range: 10.0> A >=1.0 ! A= INTO RANGE (A) + 5.0/POWERS OF TEN(ROUNDING) %IF A> 10.0 %THENSTART ; !apply rounding A=A/10.0; !apply correction EXP=EXP+1 ; ! if rounding took value back out of range %FINISH EXPONENT= EXP-SCALE FACTOR; !determine the value of the exponent part EXP=SCALE FACTOR; %FINISH ! ! Determine the sub-field required for the exponent ! %IF EXP WIDTH>0 %THEN EXP LENGTH= EXP WIDTH + 2 %C %ELSE EXP LENGTH= 4 != number of characters required ! to represent the exponent ! ! PRODUCE THE DECIMAL PART ! LENGTH= LENGTH - EXP LENGTH; FORMAT= 'D' ! -> COLLECT DIGITS !expect a return with DR pointing to ! the remainder of the output field !OUTPUT THE EXPONENT: OUTPUT THE EXPONENT: {ANALYSE THE EXPONENT TO FORMAT} !OUTPUT THE EXPONENT: I= EXPONENT %IF I< 0 %THEN SIGN= MINUS %C %ELSE SIGN= PLUS %AND I= -I %IF EXP WIDTH>0 %THENSTART ! !---the edit code is of the form Ew.dEe ! -> WIDTH TOO SMALL %IF EXP WIDTH < 10 %C %AND MIN PER WIDTH (EXP WIDTH+1)> I %FINISHELSESTART ! ! edit code is of the form Ew.d ! %IF I<-99 %THENSTART %IF I < -999 %THEN -> WIDTH TOO SMALL -> SKIP EXP TYPE %FINISH ! !IF 994 %THENSTART %IF DATA LEN>8 %THEN EXP TYPE= 'Q' %C %ELSE EXP TYPE= 'D' %FINISHELSE EXP TYPE= 'E' {and write it into the field} IO BUFFER(PTR)=EXP TYPE PTR= PTR +1 ! EXP LENGTH= EXP LENGTH -1 SKIP EXP TYPE: !only if the exponent form is '+zzz' or '-zzz' ! ! Determine formatting control variables ! EXP= EXP LENGTH -1 %IF EXP> 9 %THEN LEADING ZEROS= EXP-9 %AND EXP= 9 %C %ELSE LEADING ZEROS=NONE {PERFORM FORMATTING} -> FORMAT AN EXPONENT; !(see Iw.m) !*********************************************************************** ! ! HANDLE 'F' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('F'): ! %IF IO ITEM\=A REAL %THEN -> INCOMPATIBLE FORMAT DECS=DECIMALS; %IF A\= 0.0 %THENSTART ! ! !Initialise Variables! ! ! SCALE FACTOR = SCALE ROUNDING = SCALE FACTOR + DECS %IF IMOD(ROUNDING)> MAX SCALE %THEN ROUNDING=MAX SCALE ! ! APPLY ROUNDING AND BRING THE VALUE INTO THE RANGE 10.0> A >=1.0 ! A = INTO RANGE( A + 0.5/POWERS OF TEN(ROUNDING) ) EXP = EXP +SCALE %C FACTOR %FINISHELSE EXP=0; !if A=0.0 COLLECT DIGITS: ! %IF EXP<=(-DECS) %AND SIGN=MINUS %THENSTART ! !----only zeros will be printed, !------so ensure that no minus will be printed too ! SIGN= PLUS SIGN LENGTH=LENGTH+1 %IF SIGN= NONE %FINISH ! ! ! DETERMINE THE VARIABLES WHICH CONTROL FORMATTING ! ! MAX INT DIGITS= LENGTH - DECS - 1 ; != number of digits that %IF MAX INT DIGITS< 0 %THEN -> WIDTH TOO SMALL; ! may be output left ! of the decimal pt. INT DIGITS= EXP %IF INT DIGITS> MAX INT DIGITS %THEN -> WIDTH TOO SMALL ! !INT DIGITS is the number of digits that are ! required to the left of the decimal point %IF INT DIGITS<=0 %THENSTART ! ! Determine how many leading zeros are required if value is < 1.0 ! %IF MAX INT DIGITS=NONE %THENSTART ! %IF INT DIGITS=DECS %THEN -> WIDTH TOO SMALL ! (otherwise no significant digits ! will be produced in the field) ! LEADING ZEROS= -INT DIGITS %AND INT DIGITS= NONE %FINISHELSE LEADING ZEROS=1-INT DIGITS %AND INT DIGITS= 1 TOTAL CHARS= INT DIGITS - LEADING ZEROS + DECS GENERATE LEADING ZEROS: !in the work area ! PROPAGATE (LEADING ZEROS,ADDR(OUTPUT AREA(0)),0,NOUGHT) AREA PTR= LEADING ZEROS %FINISHELSESTART; ! ! Determine total number of numerals required if value>=1.0 ! TOTAL CHARS= INT DIGITS + DECS %FINISH ! ! ! CONVERT VALUE TO CHARACTERS (using machine ! independent code) ! %WHILE TOTAL CHARS> 0 %CYCLE TOTAL CHARS= TOTAL CHARS - 1 ! N = INT PT (A) A = 10.0*(A - N) OUTPUT AREA(AREA PTR)= NOUGHT + N AREA PTR = AREA PTR + 1 ! %REPEAT ! ! ! FORM THE FORMATTED VALUE IN THE OUTPUT FIELD ! ! PTR= PTR + (MAX INT DIGITS - INT DIGITS) ! !point to where the first significant char should go %IF SIGN\=NONE %THENSTART ! ! Move in a Sign ! IO BUFFER(PTR)= SIGN PTR =PTR+1 %FINISH ! ! Write out the digits to the left of the decimal point ! COPY(INT DIGITS,ADDR(OUTPUT AREA(0)),0,ADDR(IO BUFFER(0)),PTR) AREA PTR= INT DIGITS PTR= PTR + INT DIGITS -> FINALISE FORMATING %IF FORMAT>='I' ! ! Write out the decimal point ! IO BUFFER(PTR)=DOT PTR =PTR+1 ! ! Write out the digits to the right of the decimal point ! %IF DECS>0 %THENSTART COPY(DECS,ADDR(OUTPUT AREA(0)),AREA PTR, ADDR(IO BUFFER(0)) , PTR) PTR=DECS+PTR %FINISH FINALISE FORMATING: ! %IF FORMAT='D' %THEN -> OUTPUT THE EXPONENT ! !Jump if format code is 'D' or 'E' or 'Q' and continue ! to format the exponent characteristic -> RETURN !*********************************************************************** ! ! HANDLE 'G' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('G'): DECS= DECIMALS ! %IF DECS>MAX SCALE+1 %OR POINT ONE<=A 0 %AND DECS<=MAX SCALE %THENSTART A = A + 5.0/POWERS OF TEN(DECS) %IF A>=10.0 %THENSTART A= A/10.0; !apply correction if rounding put EXP=EXP+1 ; ! the value back out of range %FINISH; %FINISH; %FINISH; ! ! Determine actual WIDTH and DECIMALS to use ! %IF EXP WIDTH>0 %THEN EXP LENGTH= EXP WIDTH + 2 %C %ELSE EXP LENGTH= 4 N =LENGTH - DECS - 1 !number of surplus characters in the field %IF N>=EXP LENGTH %THEN LENGTH = LENGTH - EXP LENGTH %C %ELSE -> WIDTH TOO SMALL ! !The formatted value should be left-justified by EXP LENGTH spaces ! which have to come from N (number of surplus characters). ! If these spaces are not available a fault is reported. ! DECS= DECS - EXP FORMAT= 'F' -> COLLECT DIGITS ! ! %FINISH ! ! OUTPUT THE NUMBER WITH AN EXPONENT ! -> D FORMAT ; !GO AND LET 'D' FORMATING ! DO ALL THE WORK !*********************************************************************** ! ! HANDLE 'I' FORMAT -----INCLUDING Iw.m ! !*********************************************************************** ! FORMAT TYPE ( I SPECIAL): FORMAT TYPE ('I'): ! %IF IO ITEM\=AN INTEGER %THEN -> INCOMPATIBLE FORMAT I FORMAT: ! %IF I=0 %THEN -> OUTPUT A ZERO INTEGER %IF I<0 %THEN SIGN =MINUS %C %ELSE SIGN = PLUS SIGN %AND I=-I %IF SIGN\= NONE %THEN LENGTH= LENGTH-1 ! ! Determine the Scale of the Value ! EXP= 1 EXP=EXP+1 %WHILE I LENGTH %THEN -> WIDTH TOO SMALL %IF FORMAT=I SPECIAL %THENSTART ! ! Determine Form of Iw.m Formatting ! LEADING ZEROS= INT WIDTH - TOTAL CHARS %IF LEADING ZEROS> 0 %THENSTART %IF INT WIDTH> LENGTH %THEN -> WIDTH TOO SMALL %FINISHELSE LEADING ZEROS = NONE ! %FINISHELSE LEADING ZEROS = NONE ! ! Prepare the Output Field (for an Exponent as well) ! PTR=PTR +(LENGTH - LEADING ZEROS - EXP) FORMAT AN %C EXPONENT: IO BUFFER(PTR)=SIGN %C %AND PTR = PTR + 1 %UNLESS SIGN=NONE %IF LEADING ZEROS\=NONE %THEN FILL BUFF(LEADING ZEROS,PTR,NOUGHT) %C %AND PTR=LEADING ZEROS+PTR ! ! NOW PERFORM INTEGER FORMATTING ! M = MIN PER WIDTH (EXP-1) - 1 {initial value of Multiplier} ! %CYCLE; Q = I// M ; !extract the next digit I = I -(M*Q) ; ! and adjust the Value accordingly M = M// 10 ; ! and adjust the Multiplier too IO BUFFER(PTR)= Q + NOUGHT ; !insert the digit into PTR =PTR+ 1 ; ! the output field %REPEAT %UNTIL M = 0 ; ! and repeat 'til all digits are acquired ! ! -> RETURN OUTPUT A ZERO INTEGER: ! OUTPUT A ZERO INTEGER: ! OUTPUT A ZERO INTEGER: ! %IF FORMAT\=I SPECIAL %THENSTART %IF PLUS SIGN\=0 %THENSTART ! ! A leading '+' is required ! %IF WIDTH= 1 %THEN -> WIDTH TOO SMALL IO BUFFER(PTR MAX-2)= PLUS SIGN %FINISH IO BUFFER(PTR MAX-1)= NOUGHT %AND -> RETURN %FINISH {for Iw.m} %IF INT WIDTH>0 %THEN -> INITIALISE FOR I FORMAT -> RETURN !*********************************************************************** ! ! HANDLE 'L' FORMAT ! !*********************************************************************** ! ! FORMAT TYPE ('L'): ! %IF IO ITEM\=A LOGICAL %THEN -> INCOMPATIBLE FORMAT ! !test correspondence of format and I/O item L FORMAT: %IF DATA LEN=4 %THENSTART %IF INTEGER(DATA AD)&1= FALSE %C %THEN SIGN= FALSE SIGN %C %ELSE SIGN= TRUE SIGN %FINISHELSE %IF HALFINTEGER(DATA AD)&1= FALSE %C %THEN SIGN= FALSE SIGN %C %ELSE SIGN= TRUE SIGN IO BUFFER(PTR MAX-1)= SIGN -> RETURN !*********************************************************************** ! ! HANDLE 'Z' FORMAT ! !*********************************************************************** ! FORMAT TYPE ('Z'): ! OUTPUT Z FORMAT -> RETURN !*********************************************************************** ! ! END OF HANDLING OUTPUT FORMATS ! !*********************************************************************** ! UNASSIGNED %C VARIABLE: %RESULT= UNASSIGNED VARIABLE INCOMPATIBLE FORMAT: FAULT 155: ! report non-correspondence between ! I/O item and the format code %RESULT=INCOMPATIBLE FORMAT SCALING INVALID: !Either SCALE<= 0 and SCALE<-DECIMALS ! or SCALE> 0 and SCALE> DECIMALS + 1 ! (ANSI 77 is specific) %RESULT=INVALID SCALING WIDTH TOO SMALL: FILL BUFF(WIDTH,PTR MAX-WIDTH,STAR) RETURN: %IF FILETYPE\=5 %THENSTART ! ! Copy the I/O Field into the Record ! FAULT=OUT FIELD (PTR MAX,FIELD ADDR,0,BPTR) %IF FAULT>0 %THENRESULT=FAULT ! PTR MAX=PTR MAX + BPTR %FINISH ! ! ! EXIT: BPTR= PTR MAX MAX BPTR=BPTR %IF BPTR>MAX BPTR ! %RESULT=0 !*********************************************************************** ! ! ROUTINES FOR HANDLING OUTPUT FORMATS ! !*********************************************************************** ! %REALFN INTO RANGE (%REAL X) ! ! ! ! A PROCEDURE WHICH BRINGS THE VALUE OF THE GIVEN ! ! PARAMETER INTO THE RANGE 10.0> X >=1.0 ! ! !Additionally, the variable EXP is changed to reflect the ! magnitude (scale of 10) of the parameter. ! ! %INTEGER I; !a work variable %IF X>=10.0 %THENSTART ! ! The value is too large ! %IF X>=TEN TO THE 38 %THEN I=38 %ELSESTART ! {!ELSE } I= 2 {!find the scale of} I=I+1 %WHILE X>= POWERS OF TEN(I) {! the value } I=I-1 %FINISH; X =X/POWERS OF TEN(I) EXP = EXP+I %FINISH %IF X<1.0 %THENSTART ! ! The value is too small ! X=X*10.0 %AND EXP=EXP-1 %WHILE X>1 %IF LENGTH&1\= 0 %THEN -> SECOND DIGIT %FINISH ! ! FIRST DIGIT: IO BUFFER(PTR)= CHAR( IO ITEM(K) >> 4) PTR = PTR+1 SECOND DIGIT: IO BUFFER(PTR)= CHAR( IO ITEM(K) & 15) K = K+1 PTR = PTR+1 %IF PTR < PTR MAX %THEN -> FIRST DIGIT %END; !of OUTPUT Z FORMAT ! ! ! %END; !of OUT FORMAT ! !*********************************************************************** ! ! UTILITY PROCEDURES ! !*********************************************************************** ! %ROUTINE FILL BUFF (%INTEGER LENGTH, %HALFINTEGER AT,WITH) ! ! ! ! ! This is a utility procedure to fill a specified number ! ! of bytes in the current I/O buffer with a given character ! ! ! %WHILE LENGTH>0 %CYCLE ! IO BUFFER(AT)= WITH AT = AT+1 LENGTH = LENGTH-1 %REPEAT; %END; !of FILL BUFF %ROUTINE PROPAGATE (%INTEGER LEN,BASE %HALFINTEGER INC,WITH) ! ! ! ! ! This is a utility procedure to fill part of an area which ! ! is usually a CHARACTER variable with a specified number ! ! of a given character. ! ! ! %BYTEINTEGERARRAYNAME AREA AREA==ARRAY(BASE,FORM B) %WHILE LEN> 0 %CYCLE ! AREA(INC)= WITH INC = INC + 1 LEN = LEN - 1 %REPEAT %END; !of PROPAGATE %IF SYSTEM=PERQ %THENSTART ! ! %HALFINTEGERFN BYTE AT (%INTEGER DATA AD, %HALFINTEGER DATA INC) ! ! ! %HALFINTEGER I I=HALFINTEGER(DATA AD + DATA INC>>1) %RESULT= I & 255 %IF (DATA INC&1)= 0 %RESULT= I >> 8 %END; !of BYTE AT %ROUTINE COPY(%INTEGER LEN,SBASE,%HALFINTEGER SDISP, %INTEGER TBASE,%HALFINTEGER TDISP) **@TBASE; *LDDW; **TDISP **@SBASE; *LDDW; **SDISP **LEN *STLATE_X'63'; *MVBW %END %INTEGERFN COMPARE ( %INTEGER LENGTH, THIS BASE , %HALFINTEGER THIS DISP , %INTEGER THAT BASE , %HALFINTEGER THAT DISP ) ! ! ! ! ! A Utility Procedure to lexographically compare two texts ! ! of equal length and to return a value which ! ! represents the result of the comparision. ! ! ! At Exit: RESULT= 0 if Text(THIS BASE)=Text(THAT BASE) or LENGTH<=0 ! RESULT= -1 if Text(THIS BASE)Text(THAT BASE) ! ! ! %HALFINTEGER BOOLEAN ! ! **@THAT BASE ; *LDDW ; **THAT DISP **@THIS BASE ; *LDDW ; **THIS DISP **LENGTH ; *STLATE_X'63'; *EQUBYT_0; **=BOOLEAN %IF BOOLEAN=TRUE %THENRESULT= 0 {equal} **@THAT BASE ; *LDDW ; **THAT DISP **@THIS BASE ; *LDDW ; **THIS DISP **LENGTH ; *STLATE_X'63'; *LESBYT_0; **=BOOLEAN %IF BOOLEAN=TRUE %THENRESULT=-1 { less than} %RESULT= 1 {greater than} %END; !of COMPARE ! ! %FINISH; !if PERQ %IF SYSTEM=EMAS %THENSTART ! ! %ROUTINE COPY (%INTEGER LENGTH, FROM BASE {word address} , %HALFINTEGER FROM DISP {byte displacement} , %INTEGER TO BASE {word address again} , %HALFINTEGER TO DISP {byte displacement again} ) %WHILE LENGTH> 0 %CYCLE ! BYTEINTEGER(TO BASE + TO DISP)=BYTEINTEGER(FROM BASE + FROM DISP) TO DISP= TO DISP + 1 FROM DISP=FROM DISP + 1 LENGTH= LENGTH - 1 %REPEAT %END; !of COPY %HALFINTEGERFN BYTE AT (%INTEGER DATA AD {word address} , %HALFINTEGER DATA DISP {byte displacement} ) %RESULT= BYTEINTEGER (DATA AD + DATA DISP) %END; !of BYTE AT %INTEGERFN COMPARE ( %INTEGER LENGTH, THIS BASE , %HALFINTEGER THIS DISP , %INTEGER THAT BASE , %HALFINTEGER THAT DISP ) ! ! ! ! ! A Utility Procedure to lexographically compare two texts ! ! of equal length and to return a value which ! ! represents the result of the comparision. ! ! ! At Exit: RESULT= 0 if Text(THIS BASE)=Text(THAT BASE) or LENGTH<=0 ! RESULT= -1 if Text(THIS BASE)Text(THAT BASE) ! ! ! THIS BASE= THIS BASE + THIS DISP THAT BASE= THAT BASE + THAT DISP %WHILE LENGTH>0 %CYCLE ! %RESULT= 1 {greater than} %C %IF BYTEINTEGER(THIS BASE)>BYTEINTEGER(THAT BASE) %RESULT=-1 { less than} %C %IF BYTEINTEGER(THIS BASE)