! MODIFIED 7/May/82 11.00 %EXTERNALROUTINE QFDIAG (%INTEGER LOCAL POINTER , %INTEGER GLOBAL POINTER , %INTEGER PCOUNT , %INTEGER ACTIVITY CONTROL BLOCK , %INTEGER SYMTABLE BASE , %INTEGER SYMTABLE DISP , %INTEGER MODE,DIAG , %INTEGER ASIZE,FIRST , %INTEGERNAME NEXT ) ! ! ! ! !*********************************************************************%C !*********************************************************************%C %C %C a PROCEDURE %C %C which provides diagnostic information pertaining to a %C %C single FORTRAN77 code component on ICL PERQs %C (version 1.0) %C --IMP80 %C !*********************************************************************%C !*********************************************************************%C ! ! !----CONDITIONAL-----! !----COMPILATION-----! !---- VARIABLES -----! ! ! %CONSTINTEGER PERQ= 0 %CONSTINTEGER EMAS= 1 {EMAS=> running outside the simulator} ! ! %CONSTINTEGER SYSTEM= PERQ %IF SYSTEM=EMAS %THENSTART ! ! ! EMAS Specific Byte Displacements ! ! %CONSTINTEGER ONE {halfword }= 2 {bytes} %CONSTINTEGER TWO {halfwords}= 4 {bytes} %CONSTINTEGER THREE {halfwords}= 6 {bytes} %CONSTINTEGER FOUR {halfwords}= 8 {bytes} %CONSTINTEGER FIVE {halfwords}= 10 {bytes} %FINISHELSESTART ! ! ! PERQ Specific Word {16 bits} Displacements ! ! %CONSTHALFINTEGER ONE = 1 {word } %CONSTHALFINTEGER TWO = 2 {words} %CONSTHALFINTEGER THREE = 3 {words} %CONSTHALFINTEGER FOUR = 4 {words} %CONSTHALFINTEGER FIVE = 5 {words} ! ! %FINISH; !declaring system dependent displacements %IF SYSTEM=EMAS %THENSTART {When values are extracted from store } ! { and are used as displacements } ! { by adding them to an address, } %CONSTINTEGER K= 1 {EMAS} {Then on EMAS they have to be changed } %FINISHELSESTART { from halfword to byte quantities} ! { by shifting them left one place } ! { } %CONSTHALFINTEGER K= 0 {PERQ} {-----Hence this constant } %FINISH ! !*********************************************************************** ! ! SPECIFICATIONS FOR MAIN UTILITY ROUTINES ! !*********************************************************************** ! %ROUTINESPEC SORT AND PRINT NAMES(%INTEGER SYMTABS,NO OF NAMES) %INTEGERFNSPEC LINE NO FROM PCOUNT %HALFINTEGERFNSPEC UNASSIGNED (%INTEGER DATA AD, DATA LEN {in words}) %HALFINTEGERFNSPEC NOT A REAL (%INTEGER DATA AD, DATA LEN {in words}) %HALFINTEGERFNSPEC BYTE AT ( %INTEGER DATA AD , %HALFINTEGER DATA INC {in bytes}) %ROUTINESPEC PROPAGATE (%HALFINTEGER LENGTH , %BYTEINTEGERARRAYNAME AREA , %HALFINTEGER AREA PTR, WITH) %ROUTINESPEC COPY ( %INTEGER LENGTH , FROM BASE , %HALFINTEGER FROM DISP , %INTEGER TO BASE , %HALFINTEGER TO DISP ) !*********************************************************************** ! ! CONSTANTS ! !*********************************************************************** ! %CONSTHALFINTEGER DOT = '.' %CONSTHALFINTEGER EBCDIC ZERO = C'0' %CONSTHALFINTEGER PLUS = '+' %CONSTHALFINTEGER BLANK = ' ' %CONSTHALFINTEGER QUOTE = '''' %CONSTHALFINTEGER MINUS = '-' %CONSTHALFINTEGER NOUGHT= '0' !* !* !* %CONSTHALFINTEGER NONE = 0 %CONSTHALFINTEGER NOT SET= 0 %CONSTHALFINTEGER NIL = 0 %CONSTHALFINTEGER FALSE = 0 %CONSTHALFINTEGER TRUE = 1 %CONSTHALFINTEGER GIVEN = 1, NOT GIVEN= 0 ! !Values taken by 'boolean' variables ! (ie. Integers used as flags) %IF SYSTEM=PERQ %THENSTART ! ! ! ! PERQ Floating Point Constants ! %CONSTINTEGERARRAY PERQ REAL CONSTANTS (0:4) %C %C = X'3DCCCCCD' { Point One } , X'03AA2425' {Ten to the -36} , X'7E967699' {Ten to the 38} , X'4B189680' {Ten to the 7} , X'58635FA9' {Ten to the 15} %OWNREALARRAYNAME POWERS OF TEN %REALARRAYFORMAT POWERS OF TEN FORM (2:6) ! %OWNREALNAME POINT ONE %OWNREALNAME TEN TO THE 38 %OWNREALNAME TEN TO THE MINUS 36 %FINISHELSESTART ! ! ICL2900 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 EMAS %CONSTHALFINTEGER OUTPUT LEN= 84 ;!%C OUTPUT LEN= the record length of the diagnostic %C stream. If the record length of %C this stream changes then only %C this variable need be altered %OWNSTRING(12) NOT ASSIGNED TEXT= "Not Assigned" ! !used when a value being ! output is not assigned %OWNSTRING(12) NOT A NUMBER TEXT= "Not A Number" ! !used when a floating-point ! number being output is illegal ! ! Types of FORTRAN Procedures ! %CONSTSTRING(13) %ARRAY SUBPROG TYPES(0:3)= " " , "MAIN PROGRAM " , "Function " , "Subroutine " %CONSTSTRING(10) %ARRAY FUNCTION TYPES(0:5)= "" , "Integer " , "Real " , "Complex " , "Logical " , "Character " !Text of FORTRAN77: ! %CONSTSTRING(10) COMPILER= "FORTRAN77 " !*********************************************************************** ! ! RECORD FORMATS ! !*********************************************************************** ! %RECORDFORMAT HEADER OF SYMBOL TABLES ( %C %C %HALFINTEGER LINE NO DISP {from start of LP}, %HALFINTEGER OPTIONS , %HALFINTEGER unused , %BYTEINTEGER SUBPROG SIZETYPE , %BYTEINTEGER SUBPROG TYPE , %STRING(32) SUBPROG NAME ) %RECORD (HEADER OF SYMBOL TABLES) %NAME SYMBASE %RECORDFORMAT FORM OF AN IDENTIFIER RECORD ( %C %C %BYTEINTEGER SIZE TYPE , %BYTEINTEGER FLAGS , (%HALFINTEGER DISPLACEMENT, %STRING(32) IDENTIFIER) %C %C %OR {if an extension} %INTEGER LARGE DISPLACEMENT) !*********************************************************************** ! ! GLOBAL VARIABLES ! !*********************************************************************** ! ! ! Addresses of Internal Data Areas ! %INTEGER GLA ADDR ; !GLA address of failing routine %INTEGER BASE ; !Default base address of identifiers %INTEGER SYMTABS ; !Ptr to Local identifier table %INTEGER PTR TO NEXT TABLE; !Ptr to start of (next) Common Block ! Identifier records ! ! Variables associated with the failing line number ! %INTEGER LINE NO TABLE ; !=1 if PC/Line No Mapping Table given %INTEGER LINE NO DISP ; !>0 if line number is somewhere %INTEGER LINE NO ; !the failing line number ! ! Values set in the Symbol Table Header ! %HALFINTEGER OPTIONS ; !copy of the language dependent bits %HALFINTEGER SUBPROG TYPE; !set to indicate the type of FORTRAN procedure !as follows: ! =1 =>Main Program ! =2 =>Function ! =3 =>Subroutine %INTEGER NO OF NAMES; !number of Local identifiers or Common identifiers ! ! Utility Variables ! %INTEGER STATE ; !set as follows: !=-1 =>Local variables to be/being printed != 0 =>Common variables to be printed != 1 =>Common variables being printed %INTEGER I ; !work variable ! ! String variables ! %OWNSTRING(32) MODULE NAME; !name of the procedure %OWNSTRING(51) SUBPROG NAME; !descriptive text of the procedure ! ! ! !Initialise Variables: ! GLA ADDR=GLOBAL POINTER SYMTABS = SYMTABLE BASE + (SYMTABLE DISP<< K) SYMBASE== RECORD(SYMTABS) ! ! COLLECT SUBPROGRAM TYPE (AND NAME) ! MODULE NAME= SYMBASE_SUBPROG NAME SUBPROG TYPE= SYMBASE_SUBPROG TYPE SUBPROG NAME= SUBPROG TYPES (SUBPROG TYPE) %IF SUBPROG TYPE= 1 %THEN{START} -> A ! SUBPROG NAME= SUBPROG NAME . MODULE NAME SUBPROG NAME= FUNCTION TYPES(SYMBASE_SUBPROG SIZETYPE &15) %C . SUBPROG NAME %IF SUBPROG TYPE=2 A:{%FINISH} ! ! PICK UP THE LANGUAGE DEPENDENT BITS ! LINE NO DISP= SYMBASE_LINE NO DISP OPTIONS= SYMBASE_OPTIONS ! LINE NO TABLE = OPTIONS & X'8000' ! ! PICK UP THE LINE NUMBER (AT POINT OF FAILURE) ! %IF LINE NO TABLE=NOT GIVEN %THENSTART ! %IF LINE NO DISP=NOT SET %C %THEN LINE NO=NOT SET %C %ELSE LINE NO=HALFINTEGER(LOCAL POINTER+ LINE NO DISP<0 %THEN %C PRINT STRING (" Line ") %AND WRITE(LINE NO,1) %FINISHELSESTART %IF DIAG< 0 %THENSTART ! ! Return Procedure Name and Line Number ! STRING(ASIZE)= SUBPROG NAME NEXT = LINE NO %RETURN %FINISH ! ! OR PRINT DIAGNOSTIC BLURB IF IN STAND-ALONE MODE ! PRINT STRING (COMPILER. SUBPROG NAME) ! %IF MODE\= 0 %ANDC DIAG = 1 %ANDC ASIZE\= 0 %THEN PRINT STRING (" (Module ".STRING(ASIZE).")") %IF LINE NO> 0 %THEN PRINT STRING (" At Line ") %C %AND WRITE (LINE NO,1 ) NEWLINE %ANDRETURN %IF DIAG=1 %FINISH ! ! POINT TO START OF LOCAL IDENTIFIER RECORDS ! SYMTABS= SYMTABS + (( LENGTH(MODULE NAME)+2) >> 1)<< K + FIVE ! BASE= GLA ADDR STATE= -1 ! ! Initialise Real Constant names ! POWERS OF TEN== ARRAY(ADDR(PERQ REAL CONSTANTS(0)), POWERS OF TEN FORM ) POINT ONE == POWERS OF TEN (2) TEN TO THE 38 == POWERS OF TEN (4) TEN TO THE %C MINUS 36 == POWERS OF TEN (3) ! !All this is to overcome an IMP compiler fault ! which assumes that R'abcdef' type constants ! are ICL 2900 representations. ! ! Determine the Number of Local Names ! NEXT SECTION: ! NO OF NAMES= HALFINTEGER(SYMTABS) - {for efficiency only} 1 SYMTABS= SYMTABS + ONE NEWLINE ! ! ! SORT AND PRINT THE IDENTIFIERS IN ALPHABETIC ORDER ! ! %IF NO OF NAMES 3 %THENSTART ! ! ! HANDLE A(nother) COMMON BLOCK ! ! %IF INTEGER(PTR TO NEXT TABLE)>0 %THENSTART SYMTABS = PTR TO NEXT TABLE + TWO BASE = INTEGER(GLOBAL POINTER + HALFINTEGER(SYMTABS)<< K) SUBPROG NAME= STRING(SYMTABS+ONE) SYMTABS = SYMTABS + (( LENGTH(SUBPROG NAME) +2) >> 1)<< K + ONE STATE = 0 !=>a COMMON to be printed -> NEXT SECTION %FINISH; %FINISH ! ! Determine the next (earlier) stack frame ! %IF SUBPROG TYPE=1 %THENSTART; ! MAIN PROGRAM I=NONE %FINISHELSESTART; ! SUBROUTINE or FUNCTION I=HALFINTEGER(ACTIVITY %C CONTROL BLOCK + TWO) %FINISH ! NEXT = I %ANDRETURN %INTEGERFN LINE NO FROM PCOUNT ! ! ! ! ! THIS IS A LOCAL ROUTINE TO DETERMINE THE LINE NUMBER ! ! FROM THE P-COUNTER AT THE POINT OF FAILURE WHEN ! ! A STORE MAP HAS BEEN PROVIDED. ! ! ! %INTEGER TABLE BEGIN; !Start address of Line Number Store Map Table %INTEGER TABLE START; !Addr of first entry in Store Map Table (variable) %INTEGER TABLE END ; !Addr of last entry in Store Map Table (variable) %INTEGER MOD PCOUNT ; !PCOUNT adjusted to look like entries in Table ! %INTEGER PTR; !Scanning pointer through Table %INTEGER I,J; !Entries of Table currently under examination %INTEGER PC ; !Relative PCOUNT from start of code %IF SYSTEM= EMAS %OR %C SYSTEM= PERQ %THENRESULT= 0 %C %C %ELSESTART {comment out the code below} ! ! INITIALISE VARIABLES ! TABLE BEGIN= SYMTABS + LINE NO DISP TABLE END = (INTEGER(TABLE BEGIN)<<2) + TABLE BEGIN TABLE START= TABLE BEGIN + 4 %IF MODE=0 %THEN PCOUNT= PCOUNT - INTEGER(OLD LNB +20) PC = PCOUNT & X'0003FFFF' MOD PCOUNT= PC << 13 ! ! CHECK VALIDITY OF P-COUNTER ! %IF MOD PCOUNT<=INTEGER(TABLE START) %THENRESULT= 0 %IF MOD PCOUNT>=INTEGER(TABLE END) & X'7FFFE000' %C %THEN I= INTEGER(TABLE END) & X'1FFF' %AND -> CHECK LINE SIZE -> START SEARCH ! ! SCAN TABLE USING A BINARY SEARCH PATTERN ! LOOP: ! I= INTEGER(PTR) %IF IMOD PCOUNT %THENSTART %IF J&X'7FFFE000'LINE IN J %C %ELSE ->LINE IN I %FINISH START SEARCH: PTR= TABLE START + ((((TABLE END - TABLE START)>>1) %C + 3) & X'FFFFFFFC') -> LOOP %FINISH ! %IF I>MOD PCOUNT %THENSTART TABLE END= PTR - 4 J = INTEGER(TABLE END) %IF JMOD PCOUNT %THEN ->LINE IN J %C %ELSE ->LINE IN I %FINISH PTR= TABLE END - ((((TABLE END - TABLE START) >> 1) %C + 3) & X'FFFFFFFC' ) -> LOOP %FINISH LINE IN I: I= I & X'1FFF'; -> CHECK LINE SIZE LINE IN J: I= J & X'1FFF' ! ! TEST IF THE CAPABILITY EXISTS TO MAP LINE NUMBERS > 8192 ! CHECK LINE SIZE: ! %IF OPTIONS&X'04000000'>0 %THENSTART ! ! ADD ON LINE NUMBERING BASE ! I= I + INTEGER(TABLE BEGIN-4) %FINISH %RESULT=I %FINISH; !commenting out the above code %END; !of LINE NO FROM PCOUNT %ROUTINE SORT AND PRINT NAMES(%INTEGER SYMTABS,NO OF NAMES) ! ! ! ! ! A routine to construct a list of addresses of ! ! the variable names, and then to sort the ! ! names into alphabetic order. Each name ! ! is then printed. ! ! ! %INTEGERFNSPEC ARRAY ADDRESS (%INTEGER DV ADDR,DATA TYPE) %ROUTINESPEC PRINT NAME (%STRINGNAME NAME) %ROUTINESPEC SET NAME ! %INTEGERARRAY ADDRESS(0:NO OF NAMES) ! !Each entry in this array is to be set to the address ! of each variable name. These entries will then ! be sorted, so that the names appear in ! alphabetic order. ! ! ! Control Variables ! %INTEGER NAME CNT ; !cycle control variable through ! the identifier records ! ! Variables used for sorting the variable names ! %INTEGER MIN ADDR ; !ptr to smallest name found so far %INTEGER MAX ADDR ; !ptr to largest name found so far %INTEGER PTR ADDR ; !ptr to name currently under examination %INTEGER SAVE ADDR; !save area for an address %HALFINTEGER MIN PTR ; !ptr to entry in array ADDRESS to smallest name %HALFINTEGER MAX PTR ; !ptr to entry in array ADDRESS to largest name %HALFINTEGER PTR ; !ptr to entry in array ADDRESS to current name ! %STRINGNAME MIN ; !smallest name found so far %STRINGNAME MAX ; !largest name found so far %STRINGNAME PTR NAME ; !current name under examination %STRINGNAME SAVE NAME; !temporary save area for a name ! ! Variables for identifying the next variable to output ! %INTEGER DISP ; !displacement of variable from a nominated base %HALFINTEGER STACK; !>0 if variable is on the stack %HALFINTEGER GLA ; !>0 if variable is in the GLA %HALFINTEGER GST ; !>0 if variable is a scalar in the GST area %HALFINTEGER AN ARRAY; !>0 if variable is an array ! %RECORD (Form of an Identifier Record) %NAME R ! ! Characteristics of next name to be printed ! %INTEGER DATA AD ; !store address of the item %HALFINTEGER DATA INC ; !start of Character variable relative to DATA AD %HALFINTEGER DATA TYPE ; !FORTRAN type of the item, which may !be one of the following: ! : %constinteger AN INTEGER = 1, A REAL = 2, A COMPLEX = 3, A LOGICAL = 4, A CHARACTER= 5 ! %HALFINTEGER DATA LEN ; !the length attribute of the item in bytes or words %HALFINTEGER DATA SIZE ; !the length attribute of the item ! as follows: ! 4 => 1 word, 5 => 2 words ! 6 => 4 words ! %INTEGER NUM DATA ITEMS; !number of values associated with the item ! %STRINGNAME NAME ! ! SET UP THE LIST OF ADDRESSES ! R==RECORD(SYMTABS); %FOR NAME CNT = 0,1,NO OF NAMES %CYCLE ! ADDRESS(NAME CNT)= ADDR(R_IDENTIFIER) R==RECORD(ADDR(R_IDENTIFIER) + (( LENGTH(R_IDENTIFIER)+2) >> 1)<< K) ! %REPEAT PTR TO NEXT TABLE= ADDR(R) ! ! ! INITIALISE VARIABLES FOR THE SORT OPERATION ! ! MAX PTR= NO OF NAMES MIN PTR= 0 ! ! INITIALISE VARIABLES FOR (NEXT) SCAN THROUGH THE LIST ! NEW SCAN: ! MIN ADDR= ADDRESS(MIN PTR); MIN==STRING(MIN ADDR) MAX ADDR= ADDRESS(MAX PTR); MAX==STRING(MAX ADDR) %IF MIN>MAX %THENSTART SAVE ADDR= MIN ADDR; MIN ADDR= MAX ADDR MAX ADDR= SAVE ADDR SAVE NAME==MIN ; MIN ==MAX MAX ==SAVE NAME %FINISH PTR=MIN PTR + 1 %WHILE PTRPTR NAME %THENSTART MIN ==PTR NAME ADDRESS(PTR)= MIN ADDR MIN ADDR = PTR ADDR %FINISHELSESTART ! ! TEST IF THE NEW NAME SHOULD BE THE MAXIMUM ! %IF MAX NEW SCAN ! START OUTPUTTING THE VARIABLE NAMES AND VALUES: ! {!Initialise} NUM DATA ITEMS= 1 NAME CNT = 0 %CYCLE ! ! GET THE CHARACTERISTICS OF THE NEXT VARIABLE ! SET NAME; ! Establish Area of the Identifier ! ! %UNLESS STACK=NOT SET %THEN DATA AD=DISP +LOCAL POINTER %ELSESTART %UNLESS GLA=NOT SET %THEN DATA AD=DISP + GLA ADDR %ELSESTART %UNLESS GST=NOT SET %THENSTART %IF AN ARRAY=NOT SET %THEN DATA AD=INTEGER(GLA ADDR+DISP) %C %ELSE DATA AD= GLA ADDR+DISP %FINISHELSE DATA AD= BASE+DISP %FINISH %FINISH %UNLESS AN ARRAY=FALSE %THENSTART ! ! ! Handle an Array ! ! %IF ASIZE=NOT SET %OR DIAG<3 %C %OR (DIAG=3 %AND STATE>=0) %THEN -> NEXT NAME ! DATA AD= ARRAY ADDRESS(DATA AD,DATA TYPE) ! NUM DATA ITEMS=ASIZE %IF ASIZECOMMON name printed PRINT NAME (NAME) NEXT NAME: NAME CNT= NAME CNT + 1 %REPEAT %UNTIL NAME CNT>NO OF NAMES %ROUTINE SET NAME ! ! ! ! A UTILITY ROUTINE TO PICK UP THE NEXT SCALAR NAME, ! ! AND TO DETERMINE ITS CHARACTERISTICS. ! ! ! %HALFINTEGER FLAGS ! R==RECORD(ADDRESS(NAME CNT)-TWO) ! NAME==R_IDENTIFIER DATA TYPE= R_SIZE TYPE & 15 %IF DATA TYPE= NONE %THENSTART ! ! Process an Extension to the Identifier Record ! R==RECORD(ADDR(R) + R_DISPLACEMENT<> 4 FLAGS= R_FLAGS STACK= FLAGS & X'80' GLA = FLAGS & X'40' AN ARRAY= FLAGS & X'20' GST = FLAGS & X'10' ! %IF DATA TYPE\=A CHARACTER %THEN DATA LEN {words}= 1 << (DATA SIZE -4) ! %END; !of SET NAME %INTEGERFN ARRAY ADDRESS (%INTEGER DATA AD , 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 + TWO) DATA LEN= HALFINTEGER(DATA AD + THREE) DATA AD = FOUR + DATA AD %FINISH NUM DATA ITEMS= INTEGER(DATA AD + TWO) %RESULT= RESULT ! %END; !of ARRAY ADDRESS %ROUTINE PRINT NAME (%STRINGNAME NAME) ! ! ! ! ! This local routine is used to output the name of a ! ! variable together with its associated value(s). ! ! ! %ROUTINESPEC OUTPUT CHARACTER %ROUTINESPEC OUTPUT LOGICAL %ROUTINESPEC OUTPUT NUMERIC ! !Field Widths for Various Item Types: ! %CONSTHALFINTEGERARRAY INTEGER WIDTHS (4:6)= 6, 11, 20 %CONSTHALFINTEGERARRAY COMPLEX WIDTHS (5:7)= 29, 45, 75 %CONSTHALFINTEGERARRAY REAL WIDTHS (5:7)= 14, 22, 37 %CONSTHALFINTEGERARRAY DECS PER SIZE (5:7)= 7, 15, 30 ! ! %OWNBYTEINTEGERARRAY BUFFER (0:OUTPUT LEN); !%C BUFFER is used either as a workarea for %C printing a character value or as %C a buffer when outputting floating %C point values. ! {Note that BUFFER(0) is always } { reserved as a string length} !Buffer Pointers: ! ! %OWNINTEGER BSTART; !address of the buffer %OWNINTEGER BPTR; !relative ptr through the buffer %OWNINTEGER BLEN; !relative end of the buffer %HALFINTEGER LINE LEN ; !length of unused part of the output buffer %HALFINTEGER INDENT; !number of spaces reqd at the start of ! a continuation line %HALFINTEGER I ; !utility variable ! ! Format Control Variables ! %HALFINTEGER FMTCODE ; !type of formatting to be performed on a value %HALFINTEGER WIDTH ; !maximum number of digits to output %HALFINTEGER EXP WIDTH ; !number of trailing spaces to follow the value %HALFINTEGER DECIMALS; !number of digits reqd to the right of the '.' ! %SWITCH PRINT VALUE OF (AN INTEGER:A CHARACTER) ! ! FIRST PRINT 'NAME=' ! PRINT STRING ( NAME) I=LENGTH ( NAME); %IF I<8 %THEN SPACES (8-I) %AND I=8 INDENT= I+3 LINE LEN=OUTPUT LEN - INDENT PRINT STRING (" = "); {Then check data item address is valid} %IF DATA AD=X'80808080' %C %C %OR DATA AD=-1 %THEN PRINT STRING ("Not Defined") %C %AND NUM DATA ITEMS= 1 %C %AND -> RETURN {Then go and output its value(s)} BSTART=ADDR(BUFFER(0)) ! -> PRINT VALUE OF (DATA TYPE) ! ! PRINT THE VALUE OF A CHARACTER SCALAR OR ARRAY ! PRINT VALUE OF (A CHARACTER): ! OUTPUT CHARACTER ; -> RETURN ! ! PRINT THE VALUE OF A LOGICAL SCALAR OR ARRAY ! PRINT VALUE OF (A LOGICAL): ! OUTPUT LOGICAL ; -> RETURN ! ! PRINT THE VALUE OF AN INTEGER SCALAR OR ARRAY ! PRINT VALUE OF (AN INTEGER): EXP WIDTH=NONE ! FMTCODE='I' WIDTH= INTEGER WIDTHS (DATA SIZE) %IF WIDTH< 12 %AND AN ARRAY\=FALSE %THEN WIDTH= 12 ! !Ensure that an unassigned array element does ! not upset the columns in which the ! array is output -> USE OUTPUT NUMERIC ! ! PRINT THE VALUE OF A COMPLEX SCALAR OR ARRAY ! PRINT VALUE OF (A COMPLEX): ! EXP WIDTH= NONE WIDTH= COMPLEX WIDTHS (DATA SIZE) %AND -> PRINT A REAL ! ! PRINT THE VALUE OF A REAL SCALAR OR ARRAY ! PRINT VALUE OF (A REAL): ! %UNLESS AN ARRAY=FALSE %THEN EXP WIDTH= 4 %C %ELSE EXP WIDTH= NONE WIDTH= REAL WIDTHS (DATA SIZE) PRINT A REAL: DECIMALS=DECS PER SIZE (DATA SIZE) FMTCODE = 'G' ! USE OUTPUT NUMERIC: ! BPTR= 1 %AND BLEN= BPTR + LINE LEN ! OUTPUT NUMERIC RETURN: NEWLINE %ROUTINE OUTPUT CHARACTER ! ! ! ! ! A local procedure to output the value ! ! of a Character scalar or array. ! ! ! (Values are output using PRINT STRING's). ! ! ! %HALFINTEGER WIDTH ; !amount of output line still unused %HALFINTEGER LEN ; !amount of current variable still to output %INTEGER VALUE LENGTH; !length of the complete value to output %HALFINTEGER SPACES REQD ; !number of spaces to preceed each value %INTEGER DATA PTR ; !relative scanning ptr through a Character variable ! (scalar or array) ! ! Initialise Variables ! VALUE LENGTH= DATA LEN + {for opening quote} 1 %C + {for closing quote} 1 %IF VALUE LENGTH< 12 %AND %C AN ARRAY\= FALSE %THENSTART ! SPACES REQD = 12 - VALUE LENGTH VALUE LENGTH= 12 {As arrays are output in columns we must ensure that any} { unassigned texts do not upset this format, and hence} { a minimum of 12 character positions are reserved for} { each array element with SPACES REQD filling what is } { not used } %FINISHELSE SPACES REQD= NONE DATA PTR= DATA INC; !relative ptr through a Character array ! ! Acquire the (next) Character Value ! AT START OF LINE: WIDTH= LINE LEN ! ! set length of current line available NEXT VALUE: ! ! Check for an Unassigned Character Variable ! %IF BYTE AT(DATA AD,DATA PTR)= X'80' %THENSTART ! PRINT STRING ( NOT ASSIGNED TEXT) %IF AN ARRAY= FALSE %OR WIDTH< VALUE LENGTH %C %THEN WIDTH= WIDTH - 12 %C %ELSE WIDTH= WIDTH - VALUE LENGTH %C %AND SPACES (VALUE LENGTH-12) DATA PTR= DATA PTR + DATA LEN %FINISHELSESTART ! ! Prepare to Output the (next) Character Value ! %IF SPACES REQD\=NONE %THEN SPACES(SPACES REQD) ! PRINT SYMBOL (QUOTE) WIDTH =WIDTH - SPACES REQD - {for the quote} 1 LEN = DATA LEN {= characters of variable still to output} ! ! Output the Character Value while it is longer than a line ! %WHILE LEN>=WIDTH %CYCLE ! COPY(WIDTH,DATA AD,DATA PTR,BSTART,1) {copy WIDTH bytes of I/O item } { into the buffer} BUFFER(0)=WIDTH ; !Write out PRINT STRING(STRING(BSTART)); ! one NEWLINE ; ! line's SPACES(INDENT) ; ! worth ! DATA PTR= DATA PTR + WIDTH ; !point to the next chunk LEN= LEN - WIDTH ; ! and adjust bytes left to output WIDTH= LINE LEN ; ! and reset line width available %REPEAT ! ! Output (the rest of) the Character Value if it is shorter than a line ! COPY(LEN,DATA AD,DATA PTR,BSTART,1) ! BUFFER(0)= LEN PRINT STRING(STRING(BSTART)) PRINT SYMBOL(QUOTE) DATA PTR= DATA PTR + LEN WIDTH= WIDTH - LEN - {for the quote} 1 %FINISH; !Outputting the Character Value ! ! Test if there are more values ! %IF NUM DATA ITEMS<=1 %THENRETURN NUM DATA ITEMS = NUM DATA ITEMS - 1 ! ! Prepare for the next Character Value ! %IF WIDTH> 0 %THEN PRINT SYMBOL(',') %AND WIDTH=WIDTH-1 %IF WIDTH>VALUE %C LENGTH %THEN -> NEXT VALUE ! ! Get a new record ! NEWLINE SPACES (INDENT) -> AT START OF LINE ! %END; !of OUTPUT CHARACTER %ROUTINE OUTPUT LOGICAL ! ! ! ! ! A utility procedure to output the value ! ! of a logical scalar or array. ! ! ! (Values are written out using PRINT STRING's) ! ! ! %OWNSTRING(12) VALUE; %HALFINTEGER BOOLEAN VALUE ! %HALFINTEGER PTR; !a note of where we are within the current output line ! BEGIN: PTR= INDENT; DATA AD=DATA AD + DATA LEN %IF SYSTEM=EMAS %C %AND DATA LEN= 2 LOOP: !Perform unassigned checking ! VALUE=NOT ASSIGNED TEXT %AND -> PRINT %C %IF UNASSIGNED(DATA AD, DATA LEN)= TRUE EXAMINE VALUE: BOOLEAN VALUE= HALFINTEGER(DATA AD) & TRUE ! %IF AN ARRAY\= FALSE %THEN SPACES(BOOLEAN VALUE + 7) ! %IF BOOLEAN VALUE = FALSE %THEN VALUE="FALSE" %C %ELSE VALUE="TRUE" PRINT: PRINT STRING (VALUE); %RETURN %IF NUM DATA ITEMS<=1 ! ! Select the next Logical array element ! NUM DATA ITEMS= NUM DATA ITEMS - 1 DATA AD = DATA LEN< LOOP ! {and output the current line} NEWLINE SPACES (INDENT) -> BEGIN %END; !of OUTPUT LOGICAL %ROUTINE OUTPUT NUMERIC ! ! ! ! ! A utility procedure to output the value of ! ! a Real, Integer, or Complex scalar or array. ! ! ! (Values of an array are accumulated in a record) ! ( before they are output. ) ! ! ! %ROUTINESPEC OUTPUT REAL %ROUTINESPEC OUTPUT COMPLEX ! ! %STRINGNAME FAULT TEXT {might be mapped onto NOT ASSIGNED TEXT} ! or NOT A NUMBER TEXT} %IF SYSTEM=EMAS %THENSTART ! %CONSTREALARRAY POWERS OF TEN (5:7)= %C %C R'46989680' , R'4D38D7EA' , R'59C9F2CA' ! !These constants represent 10.0 ** 7 %C 10.0 **15 %C 10.0 **30 respectively ! !The values are used to determine whether a REAL*4 or REAL*8 ! or REAL*16 constant will be output in E format or F format. ! %FINISHELSESTART {if PERQ} ! !The POWERS OF TEN array is declared ! at the top level due to an IMP ! compiler fault associated with R' type constants ! %FINISH; !if PERQ ! ! %INTEGER LENGTH LENGTH= WIDTH; !copy field width (for complex values) CYCLE: !through each element of the current I/O item ! and output each in turn ! WIDTH=LENGTH PROPAGATE (LENGTH,BUFFER,BPTR,BLANK) {space-fill the output} { field } ! ! Test for an unassigned INTEGER or REAL or COMPLEX (real part only) ! %IF UNASSIGNED (DATA AD,DATA LEN)=TRUE %THEN -> UNASSIGNED VARIABLE ! %IF DATA TYPE\=AN INTEGER %AND NOT A REAL (DATA AD,DATA LEN)= TRUE%C %THEN -> NOT A REAL %IF DATA TYPE=A COMPLEX %THENSTART ! ! Test for an unassigned imaginary part ! -> UNASSIGNED COMPLEX %IF UNASSIGNED(DATA AD+DATA LEN<< K,DATA LEN)= 1 -> NOT A COMPLEX %IF NOT A REAL(DATA AD+DATA LEN<< K,DATA LEN)= 1 ! OUTPUT COMPLEX {otherwise} %FINISHELSESTART ! ! Output an Integer or Real Value ! OUTPUT REAL %FINISH NEXT VALUE: -> RETURN %IF NUM DATA ITEMS<=1 !-> if there are no more values to print ! ! Select the next value ! NUM DATA ITEMS= NUM DATA ITEMS - 1 DATA AD = DATA LEN< CYCLE ! ! BUFFER(0)= BPTR-1 PRINT STRING (STRING(BSTART)) NEWLINE; SPACES (INDENT) ! BPTR= 1 %AND -> CYCLE NOT A COMPLEX: !Report an Illegal NOT A REAL: ! Floating Point Number ! FAULT TEXT== NOT A NUMBER TEXT -> PRINT TEXT UNASSIGNED VARIABLE: !Report an Unassigned UNASSIGNED COMPLEX : ! Real, Integer, or Complex ! FAULT TEXT== NOT ASSIGNED TEXT PRINT TEXT: %IF AN ARRAY= FALSE %THEN PRINT STRING(FAULT TEXT)%C %ANDRETURN ! {For an Array Element:} COPY (12,ADDR(FAULT TEXT),1, BSTART,BPTR+LENGTH-12) DATA AD=DATA AD + DATA LEN< NEXT VALUE ! ! TIDY UP --- PRINT THE (final) LINE ! RETURN: BUFFER (0)= BPTR-1 PRINT STRING (STRING(BSTART)) %RETURN %ROUTINE OUTPUT COMPLEX ! ! ! ! A LOCAL PROCEDURE WHICH OUTPUTS A COMPLEX VALUE ! ! ! ! %HALFINTEGERFNSPEC WIDTH FOR (%INTEGER DATA AD) ! %HALFINTEGER WIDTH1; !field width reserved for the real part %HALFINTEGER WIDTH2; !field width reserved for the imaginary part %HALFINTEGER WIDTH3; !least width required for the complex value ! !Note that, if possible, the field width used is twice the ! field required for a real value plus space for the ! opening and closing bracket and the separating comma ! %HALFINTEGER SPACES REQD !to right-justify the value within the determined field ! ! Determine the field widths for each complex part ! WIDTH1= WIDTH FOR (DATA AD) WIDTH2= WIDTH FOR (DATA AD + DATA LEN<=POINT ONE %AND A I FORMAT %FINISH ! ! HANDLE A NEGATIVE VALUE ! %IF A<0.0 %THEN A=-A %AND SIGN=MINUS %AND LENGTH=LENGTH-1 %C %ELSE SIGN= NONE {last bit of } AREA PTR= 0 { initialisation } {currently REALS only} EXP= 1 ! ! !FINISH; !preparing for numeric formatting !*********************************************************************** ! ! HANDLE 'G' FORMAT ! !*********************************************************************** ! G FORMAT: DECS= DECIMALS ! %IF POINT ONE<=A=10.0 %THENSTART A= A/10.0; !apply correction if rounding put EXP=EXP+1 ; ! the value back out of range %FINISH ! ! Determine actual WIDTH and DECIMALS to use ! LENGTH= LENGTH - EXP WIDTH; !reduce LENGTH by spaces reqd on the right DECS= DECS - EXP ; !reduce DECS by digits reqd left of '.' ! -> COLLECT DIGITS ! ! %FINISH ! ! OUTPUT THE NUMBER WITH AN EXPONENT ! !%C -> E FORMAT ; !GO AND LET 'E' FORMATING ! DO ALL THE WORK !*********************************************************************** ! ! HANDLE 'E' FORMAT ! !*********************************************************************** ! E FORMAT: ! {!Initialise variables} DECS=DECS-1 ! %IF A=0.0 %THEN EXPONENT=NONE %AND EXP=NONE %ELSESTART !Bring the value into the range: 10.0> A >=1.0 ! A= INTO RANGE (A) + 5.0/POWERS OF TEN (DATA SIZE) %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-1 ; !determine the value of the exponent part EXP=1 ; %FINISH ! ! PRODUCE THE DECIMAL PART ! LENGTH= LENGTH - 4; FORMAT= 'E' ! -> 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: ! %UNLESS EXPONENT<0 %THEN SIGN=PLUS %C %ELSE SIGN=MINUS %AND EXPONENT=-EXPONENT {Format } N = EXPONENT//10 { the } BUFFER(PTR )= 'E' { exponent} BUFFER(PTR+1)= SIGN {of the } BUFFER(PTR+2)= N + NOUGHT { value } BUFFER(PTR+3)= (EXPONENT - N*10) + NOUGHT {!} BPTR=PTR+4 %RETURN !*********************************************************************** ! ! Perform formatting of Real values ! !*********************************************************************** ! COLLECT DIGITS: ! ! ! DETERMINE THE VARIABLES WHICH CONTROL FORMATTING ! ! MAX INT DIGITS= LENGTH - DECS - 1 ; != number of digits that ! may be output left ! of the decimal pt. INT DIGITS= EXP ! !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 ! 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 !%C GENERATE LEADING ZEROS: !in the work area ! PROPAGATE (LEADING ZEROS, OUTPUT AREA, 0, NOUGHT) AREA PTR= LEADING ZEROS %FINISHELSESTART; ! ! Determine total number of numerals required if value>=1.0 ! TOTAL CHARS= INT DIGITS + DECS %FINISH FORMAT DIGITS: ! ! ! CONVERT VALUE TO CHARACTERS (using machine ! independent code) ! %WHILE TOTAL CHARS> 0 %CYCLE TOTAL CHARS= TOTAL CHARS - 1 ! N = INT PT (A) A = 10.0*(A - N) OUTPUT AREA(AREA PTR)= NOUGHT + N AREA PTR = AREA PTR + 1 ! %REPEAT ! ! ! FORM THE FORMATTED VALUE IN THE OUTPUT FIELD ! ! %UNLESS AN ARRAY= FALSE %THEN PTR= PTR + (MAX INT DIGITS - INT DIGITS) ! !point to where the first significant char should go ! (at the beginning if the variable is a scalar) %IF SIGN\=NONE %THENSTART ! ! Move in a Sign ! BUFFER(PTR)= SIGN PTR =PTR+1 %FINISH ! ! Write out the digits to the left of the decimal point ! COPY(INT DIGITS,ADDR(OUTPUT AREA(0)),0,BSTART, PTR) AREA PTR= INT DIGITS PTR= PTR + INT DIGITS ! ! Write out the decimal point ! BUFFER(PTR)=DOT PTR =PTR+1 ! ! Write out the digits to the right of the decimal point ! %IF DECS>0 %THENSTART COPY(DECS,ADDR(OUTPUT AREA(0)),AREA PTR,BSTART,PTR) PTR=DECS+PTR %FINISH {FINALISE FORMATTING} ! ! %IF FORMAT='E' %THEN -> OUTPUT THE EXPONENT ! !Jump if format code is 'E' and continue ! to format the exponent characteristic -> EXIT ! ! !*********************************************************************** ! ! HANDLE 'I' FORMAT ! !*********************************************************************** ! I FORMAT: ! %IF I=0 %THEN -> OUTPUT A ZERO INTEGER %IF I<0 %THEN SIGN=MINUS %AND LENGTH= LENGTH-1 %C %ELSE SIGN= NONE %AND I=-I ! ! Determine the Scale of the Value ! EXP= 1 EXP=EXP+1 %WHILE I EXIT OUTPUT A ZERO INTEGER: ! OUTPUT A ZERO INTEGER: ! OUTPUT A ZERO INTEGER: ! %IF AN ARRAY=FALSE %THEN BUFFER (PTR) = NOUGHT %AND PTR= PTR+1 %C %ELSE BUFFER (PTR MAX-1)= NOUGHT %AND PTR= PTR MAX !*********************************************************************** ! ! END OF HANDLING OUTPUT FORMATS ! !*********************************************************************** ! EXIT: BPTR= PTR + EXP WIDTH ! %RETURN !*********************************************************************** ! ! 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. ! ! %REAL Y %REAL Z ! %HALFINTEGER I; !a work variable %IF X>=10.0 %THENSTART ! ! The value is too large ! %IF X=Y ! X=X/Z %AND EXP=EXP+ I %FINISHELSE EXP=EXP+38 %AND X=X/TEN TO THE 38 %FINISH %IF X<1.0 %THENSTART ! ! The value is too small ! X=X*10.0 %AND EXP=EXP-1 %WHILE X 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 ! ! %FINISH; !if EMAS %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 ! ! %FINISH; !if PERQ %ROUTINE PROPAGATE (%HALFINTEGER LENGTH , %BYTEINTEGERARRAYNAME AREA , %HALFINTEGER AREA PTR, WITH) ! ! ! ! ! A Procedure to fill part of an area with a specified character ! ! ! %WHILE LENGTH> 0 %CYCLE ! AREA(AREA PTR)= WITH AREA PTR = AREA PTR + 1 LENGTH = LENGTH - 1 %REPEAT; %END; !of PROPAGATE ! ! ! ! ! ! ! ! ! ! %END; !of QFDIAG ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! %ENDOFFILE