! Modified 22/November/83 12.00
!----------Conditional Compilation Constants:
!
!
CONSTINTEGER EMAS= 0
CONSTINTEGER VME = 1
CONSTINTEGER SYSTEM= EMAS
SYSTEMROUTINE FDIAG (INTEGER OLD LNB, PCOUNT ,
INTEGER MODE , DIAG , ASIZE ,
INTEGERNAME FIRST , NEW LNB)
!
!
!
!
!*********************************************************************%C
!*********************************************************************%C
C
C
a PROCEDURE common to FORTRAN(G), FORTRAN(J), and FORTRAN77 C
C
which provides diagnostic information pertaining to a C
C
single FORTRAN code component C
(version 3.0) C
--IMP80 C
!*********************************************************************%C
!*********************************************************************%C
!
!
!it takes over the function performed by S#FDIAG 1/2/78
!it takes over the function performed by S#FIO1 1/3/81
!it takes over the function performed by S#FIO2 1/3/81
!The Parameters have the following uses:
! %C
OLD LNB ptr to the stack of the failing routine C
PCOUNT PC at the point of failure C
MODE set as: 0=> EMAS or JOBBER
! 1=> VME and error is not software detected
! 2=> VME and error is software detected
! DIAG diagnostic level control variable %C
ASIZE number of array elements to output C
FIRST variable to be set to one if this C
is the 1st call on FDIAG C
NEW LNB variable to be set at exit to the C
address of the next stack frame
!History: %C
C
FDIAG12 upgraded to handle subprograms which were C
compiled using the option OPT3. C
C
FDIAG10 modified from FDIAG8 replacing OWN variables into local C
name space so that FDIAG can be linked within the C
'System Gla' sharing EMAS subsystem.
RECORDFORMAT SYMBOL TABLE HEADER ( C
C
INTEGER LINE NO DISP ,
INTEGER OPTIONS ,
INTEGER SUBPROG TYPE ,
C
{OPT3 Only}(INTEGER NEXT SYMTABS , {OPT3 Only}
{OPT3 Only} INTEGER FIRST PCOUNT , {OPT3 Only}
{OPT3 Only} INTEGER PTR TO RETURN ADDR, {OPT3 Only}
C
STRING (32) SUBPROG NAME OR STRING (32) SUBPROG ID))
RECORD (Symbol Table Header) NAME S,T
RECORDFORMAT FORM OF GLA ( C
C
INTEGER Word0 ,
INTEGER Word1 ,
INTEGER GST ADDR ,
INTEGER SYMTABS BASE ,
INTEGER FLAGS ,
INTEGERARRAY WORDS (5:17) ,
C
INTEGER CODE BASE {at GLA+72} )
RECORD (Form of GLA) NAME GLA
!
!***********************************************************************
!
! SPECIFICATIONS FOR MAIN UTILITY ROUTINES
!
!***********************************************************************
!
ROUTINESPEC PHEX (INTEGER VALUE )
ROUTINESPEC DUMP (INTEGER START,FINISH )
ROUTINESPEC SORT AND PRINT NAMES(INTEGER SYMTABS,NO OF NAMES)
INTEGERFNSPEC LINE NO FROM PCOUNT
!***********************************************************************
!
! CONSTANTS
!
!***********************************************************************
CONSTINTEGER DOT = '.'
CONSTINTEGER EBCDIC ZERO = C'0'
CONSTINTEGER PLUS = '+'
CONSTINTEGER QUOTE = ''''
CONSTINTEGER MINUS = '-'
CONSTINTEGER NOUGHT= '0'
!*
!*
!*
CONSTINTEGER NONE = 0
CONSTINTEGER NOT SET= 0
CONSTINTEGER NIL = 0
CONSTINTEGER FALSE = 0
CONSTINTEGER TRUE = 1
!Values taken by 'boolean' variables
! (ie. Integers used as flags)
!
! Descriptors
!
CONSTINTEGER STRING DESC= X'58000000'
CONSTINTEGER BYTE DESC= X'19000000'; !(bound check inhibited)
!
!these constants represent the basic form of %C
a descriptor for accessing C
a string of bytes.
!
! Floating Point Constants
!
CONSTLONGLONGREAL POINT ONE = R'40199999999999993299999999999999'
CONSTLONGLONGREAL TEN TO THE 11= R'4A174876E80000003C00000000000000'
CONSTLONGLONGREAL TEN TO THE 12= R'4AE8D4A5100000003C00000000000000'
CONSTLONGLONGREAL TEN TO THE 75= R'7F235FADD81C282271BB3F07877973CC'
CONSTLONGLONGREAL TEN TO THE C
MINUS 75= R'0273CAC65C39C96174615B058E891876'
CONSTINTEGER OUTPUT LEN= 120; !The record length -1 of the diagnostic
! stream. Should the characteristics
! of the stream change then only this
! variable need be altered.
!
! Types of FORTRAN Procedures
!
CONSTSTRING (13) ARRAY SUBPROG TYPES(1:3)= "MAIN PROGRAM " ,
"FUNCTION " ,
"SUBROUTINE "
CONSTSTRING (10) ARRAY FUNCTION TYPES(1:5)= "INTEGER " , "REAL " ,
"COMPLEX " , "LOGICAL " ,
"CHARACTER "
!Texts of FORTRAN77, FORTRAN(G), and FORTRAN(J):
!
CONSTSTRING (11) ARRAY COMPILER(0:2)= "FORTRAN77 " ,
"FORTRAN(G) " ,
"FORTRAN(J) "
!***********************************************************************
!
! GLOBAL VARIABLES
!
!***********************************************************************
!
!
! Address of an External Workarea
!
INTEGER DESC OF EXTERNAL AREA
INTEGER ADDR OF EXTERNAL AREA
!
!address of a large (>32771 bytes) area which may be used
! for long (>256 bytes) CHARACTER values (F77 only)
!%C
NOTE:
!for EMAS EXTERNAL AREA NAME= "T#FIOAREA"
!for VME = "FIOAREA"
!
!and EXTERNAL AREA SIZE= 33792 bytes
!
! Addresses of Internal Data Areas
!
INTEGER GLA ADDR ; !GLA address of failing routine
INTEGER GST ADDR ; !Address of the Array Area
INTEGER BASE ; !Base address of local variables
!
! Pointers to the Symbol Tables
!
INTEGER ADR SYMTABS; !ptr to the start of the Symbol Tables for current module
INTEGER CUR SYMTABS; !ptr to the start of the Symbol Tables for current procedure
INTEGER SYMTABS; !ptr through the Symbol Tables for the current procedure
INTEGER PTR TO NEXT TABLE; !ptr to start of (next) set of Common Block 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
!
!The failing line number is located in one of three ways:
!RELEASE 55 and later:
! BYTES 10-11 of the symbol tables set to the stack
! displacement of the line number.
! BYTES 4- 7 set to the displacement from GLA of
! the PC/line number mapping table if present.
!
!RELEASE 50 and earlier:
! Bit 1 in BYTE 8 set if a PC/line number mapping
! table is to be used to extract the line number.
! It is located at GLA + (BYTES 4-7) of symbol tables
! Otherwise BYTES 4-7 contain the displacement of the
! line number on the stack.
!
! Values set in the Symbol Table Header
!
INTEGER OPTIONS ; !copy of the language dependent bits
INTEGER VERSION ; !set to indicate the FORTRAN version
!as follows:
constinteger F77= 0,
FG = 1,
FJ = 2
INTEGER DEBUG FLAG; !set +ve if PARM(DEBUG) was specified, or
!set +ve if ITS code is included , else= 0
INTEGER OPT3 FLAG; !set +ve if PARM(OPT3) was specified, else= 0
INTEGER EBCDIC MODE; !set +ve if PARM(EBCDIC) was specified, else= 0
INTEGER SUBPROG TYPE; !set to indicate the type of FORTRAN procedure
!as follows:
! =1 =>Main Program
! =2 =>Function
! =3 =>Subroutine
INTEGER NAME CNT GIVEN; !set +ve if Symbol Table includes a count
! of the number of identifier names
INTEGER NO OF NAMES; !number of Local identifiers or Common identifiers
INTEGER C
ITEMS OFF STACK; !In RELEASE 70 and later, there may be no
! Initialised Stack, but rather an external
! area whose use and appearence is similar
! to an Initialised Stack
! %C
ITEMS OFF STACK= false if this is not the case C
ITEMS OFF STACK> zero if there is no Initialised Stack
!
! 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 PTR ; !scanning pointer through the identifier records
INTEGER I,J ; !work variables
INTEGER USER LNB; !address of the stack frame (copied from 1st parameter)
INTEGER STRING LEN; !length of the procedure's name
!
! Local Variables which could be OWNs
!
STRING (12) NOT ASSIGNED TEXT
! assigned value "NOT ASSIGNED" and used
! when a value is not assigned
INTEGER BAD CHAR BYTES ; !assigned 4
INTEGER BAD DESC OF PARM ; !assigned X'18000004'
INTEGER BAD ADDR OF PARM ; !assigned -1
INTEGER BAD NUM OF ITEMS; !assigned 0
! %C
The area above is used as an alternative descriptor/dope vector C
when a REF(NAME) parameter is undefined and triggers a trap in C
the routine PRINT NAME.
IF SYSTEM= VME THENSTART
!
! VME String Variables
!
OWNSTRING (32) MODULE NAME; !name of the procedure
OWNSTRING (51) SUBPROG NAME; !descriptive text of the procedure
FINISHELSESTART
!
! EMAS String Variables
!
STRING (32) MODULE NAME; !name of the procedure
STRING (51) SUBPROG NAME; !descriptive text of the procedure
!
!
FINISH ; !if EMAS
{Inhibit Floating Point Underflow:} *MPSR_ X'40C0'
!Get the GLA address
!
OLD LNB= OLD LNB & X'FFFFFFFC'
USER LNB= OLD LNB AND GLA ADDR= INTEGER(USER LNB+16)
GLA== RECORD(GLA ADDR)
!
! Determine if there is an Initialised Stack (Items On Stack=Yes)
!
ITEMS OFF STACK = GLA_FLAGS & 2
IF ITEMS OFF STACK¬= FALSE THEN OLD LNB= INTEGER(USER LNB+12)
!
!NOTE that if items are off stack then any
! such items will be in a pseudo-stack
! which has the same appearence as a
! static stack frame.
!
! INITIALISE VARIABLES
!
SYMTABS= INTEGER(OLD LNB + 12) & X'FFFFFF'
!=displacement of Symbol Tables from the start of the Table Area
IF SYMTABS=NOT SET THENSTART
IF DIAG<0 THEN NEW LNB =-1 C
ELSESTART
*STSF_ I
J= USER LNB + 256
IF J>I THEN J = I
PRINT STRING("
SUBPROGRAM COMPILED WITHOUT DIAGNOSTICS
STACK FRAME
"); DUMP (USER LNB , J)
NEW LNB = INTEGER(USER LNB)
FINISH
RETURN
FINISH
GST ADDR= GLA_GST ADDR
SYMTABS = GLA_SYMTABS BASE + SYMTABS
CUR SYMTABS = SYMTABS
!Note: SYMTABS is a pointer which is moved through the current Symbol Tables
! CUR SYMTABS is a pointer to the start of the current Symbol Tables
! ADR SYMTABS is a pointer to the start of the module's Symbol Tables
ADR SYMTABS= SYMTABS
S== RECORD(SYMTABS)
!
! PICK UP THE LANGUAGE DEPENDENT BITS
!
OPTIONS = S_OPTIONS
EBCDIC MODE = OPTIONS & X'80000000' ; !set if PARM(EBCDIC)
LINE NO TABLE = OPTIONS & X'40000000' ; !set if PARM(NOCHECK,NODIAG)
NAME CNT GIVEN = OPTIONS & X'20000000'
DEBUG FLAG = OPTIONS & X'08000000'
OPT3 FLAG = OPTIONS & X'01000000'
IF OPTIONS & X'02000000'> 0 THEN VERSION= F77 ELSESTART
IF OPTIONS & X'10000000'> 0 THEN VERSION= FJ C
ELSE VERSION= FG; FINISH
IF OPT3 FLAG¬=False THENSTART
!
PCOUNT = PCOUNT - GLA_CODE BASE IF MODE=0
!
{!} Locate the Appropriate Symbol Tables:
!
IF S_FIRST PCOUNT > PCOUNT THEN CUR SYMTABS= ADR SYMTABS C
AND S==RECORD(CUR SYMTABS)
A: IF S_NEXT SYMTABS= Not Set THENSTART
-> NEXT OPT3 PROC IF S_SUBPROG TYPE=Not Set
!
! Jump if PCOUNT points to 'Transfer Code'
! ie if PCOUNT points to code which converts a
! JLK into a call on an external procedure
FINISHELSESTART
T== RECORD(S_NEXT SYMTABS + ADDR(S))
IF T_FIRST PCOUNT < PCOUNT THEN S==T AND -> A
FINISH
CUR SYMTABS= ADDR(S)
SYMTABS= ADDR(S_SUBPROG NAME)
MODULE NAME= S_SUBPROG NAME
FINISHELSE MODULE NAME= S_SUBPROG ID C
AND SYMTABS= ADDR(S_SUBPROG ID)
LINE NO DISP= S_LINE NO DISP & X'FFFF'
!
! PICK UP THE LINE NUMBER (AT POINT OF FAILURE)
!
IF DEBUG FLAG¬=FALSE AND MODE=1 THEN LINE NO=LINE NO FROM PCOUNT C
ELSESTART
I= OPTIONS & X'FFFF'
IF I> 0 THEN LINE NO= INTEGER(OLD LNB + I) C
ELSESTART
IF LINE NO TABLE¬=0 THEN LINE NO= LINE NO FROM PCOUNT C
ELSESTART
IF LINE NO DISP=NOT SET C
THEN LINE NO=NOT SET C
ELSE LINE NO=INTEGER(OLD LNB C
+ LINE NO DISP)
FINISH
FINISH
FINISH
NEWLINE
IF LINE NO<0 THEN LINE NO= 0
!
! COLLECT SUBPROGRAM TYPE (AND NAME)
!
I = S_SUBPROG TYPE
SUBPROG TYPE= I & X'FF'
SUBPROG NAME= SUBPROG TYPES (SUBPROG TYPE)
IF SUBPROG TYPE>1 THENSTART
SUBPROG NAME= SUBPROG NAME . MODULE NAME
IF SUBPROG TYPE=2 C
THEN SUBPROG NAME= FUNCTION TYPES ((I>>8) & 15)C
. SUBPROG NAME
FINISH
IF MODE=0 THENSTART
!
! PRINT 'DIAGNOSTICS ENTERED FROM .....' IF IN JOBBER OR EMAS MODE
!
IF FIRST¬=FALSE THEN FIRST=FALSE AND C
PRINT STRING ("DIAGNOSTICS ")
PRINT STRING ("ENTERED FROM ".SUBPROG NAME)
IF LINE NO>0 THEN C
PRINT STRING (" LINE ") AND WRITE(LINE NO,1)
FINISHELSESTART
IF DIAG<0 THENSTART
!
! PICK UP ROUTINE NAME AND LINE NUMBER FOR OPEH PRE-AMBLE
!
FIRST = ADDR(MODULE NAME)
NEW LNB= LINE NO
RETURN
FINISH
!
! OR PRINT DIAGNOSTIC BLURB IF IN STAND-ALONE MODE
!
PRINT STRING (COMPILER (VERSION) . 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 )
IF DIAG=1 THENSTART
NEWLINE
UNLESS OPT3 FLAG= False THENSTART
!
! Check for more Procedures to Report on in this Module
!
IF S_PTR TO RETURN ADDR¬= Not Set THENSTART
NEXT OPT3 PROC:
J= INTEGER(S_PTR TO RETURN ADDR + OLD LNB) - 4
{link address stored by current routine at entry - 4}
PCOUNT= J - GLA_CODE BASE
{relative displacement within the calling procedure}
-> Locate the Appropriate Symbol Tables
FINISH
FINISH
RETURN {if DIAG=1}
FINISH
FINISH
!
! POINT TO START OF LOCAL IDENTIFIER RECORDS
!
STRING LEN= LENGTH(MODULE NAME)
IF STRING LEN>15 THEN STRING LEN= (STRING LEN + 4) & X'3C' C
ELSE STRING LEN= 16
SYMTABS = SYMTABS + STRING LEN
SYMTABS = SYMTABS + 4 IF NAME CNT GIVEN¬=FALSE; !skip around any
! TOTAL ID COUNT
BASE = GLA ADDR; STATE= -1
!
ADDR OF EXTERNAL AREA= NOT SET
!Initialise 'Local OWN's
!
NOT ASSIGNED TEXT = "NOT ASSIGNED"
BAD CHAR BYTES = 4
BAD DESC OF PARM = X'18000004'
BAD ADDR OF PARM = -1
BAD NUM OF ITEMS= 0
!
! DETERMINE NUMBER OF LOCAL NAMES
!
NEXT SECTION: IF NAME CNT GIVEN=FALSE THENSTART
!
NO OF NAMES= NOT SET
PTR = SYMTABS
CYCLE
I= INTEGER(PTR)
IF I=-1 OR I=M'****' THEN -> SORT
NO OF NAMES= NO OF NAMES + 1
PTR= (PTR + 8 + BYTEINTEGER(PTR+4)) & X'FFFFFFFC'
REPEAT
FINISHELSE NO OF NAMES= INTEGER(SYMTABS) C
AND SYMTABS= 4 + SYMTABS
!
!
! SORT AND PRINT NAMES IN ALPHABETIC ORDER
!
!
SORT: NEWLINE
!
IF NO OF NAMES>0 THEN SORT AND PRINT NAMES(SYMTABS,NO OF NAMES) C
ELSE PTR TO NEXT TABLE = SYMTABS
IF DIAG> 3 THENSTART
!
! HANDLE A(NOTHER) COMMON BLOCK
!
IF INTEGER(PTR TO NEXT TABLE)>0 THENSTART
SYMTABS = PTR TO NEXT TABLE + 4
BASE = INTEGER(OLD LNB + INTEGER(SYMTABS))
SUBPROG NAME= STRING(SYMTABS+4)
SYMTABS = (SYMTABS + 8 + BYTEINTEGER(SYMTABS+4)) & X'FFFFFFFC'
STATE = 0
!=>a COMMON to be printed
-> NEXT SECTION
FINISH ; FINISH
-> NEXT OPT3 PROC IF OPT3 FLAG¬= False AND S_PTR TO RETURN ADDR¬= Nil
!
! Determine the next (earlier) stack frame
!
IF SUBPROG TYPE=1 THENSTART ; ! MAIN PROGRAM
I=NONE
FINISHELSESTART ; ! SUBROUTINE or FUNCTION
I=INTEGER(USER LNB)
I=INTEGER(I) IF ITEMS OFF STACK=FALSE
FINISH
!
NEW LNB= 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
!
! INITIALISE VARIABLES
!
TABLE BEGIN= CUR SYMTABS + LINE NO DISP
TABLE END = (INTEGER(TABLE BEGIN)<<2) + TABLE BEGIN
TABLE START= TABLE BEGIN + 4
IF MODE=0 AND OPT3 FLAG=False 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 I<MOD PCOUNT THENSTART
TABLE START= PTR + 4
J = INTEGER(TABLE START)
IF J>MOD PCOUNT THENSTART
IF J&X'7FFFE000'<MOD PCOUNT THEN ->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 J<MOD PCOUNT THENSTART
IF I&X'7FFFE000'>MOD 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 S_OPTIONS&X'04000000'>0 THENSTART
!
! ADD ON LINE NUMBERING BASE
!
I= I + INTEGER(TABLE BEGIN-4)
FINISH
RESULT =I
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 ADDRESS1 (INTEGER DV ADDR)
INTEGERFNSPEC ARRAY ADDRESS2 (INTEGER DV ADDR)
ROUTINESPEC PRINT NAME (STRINGNAME NAME)
ROUTINESPEC SET NAME
!
INTEGERARRAY ADDRESS(1: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 DEFAULT DV TYPE; !set to 0 if array descriptors generally
!address the 1st actual element
! or +ve if array descriptors generally
!address the zero'th element
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
INTEGER MIN PTR ; !ptr to entry in array ADDRESS to smallest name
INTEGER MAX PTR ; !ptr to entry in array ADDRESS to largest name
INTEGER 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
INTEGER DV TYPE ; !>0 if array dope vector addresses zero'th element
INTEGER STACK; !>0 if variable is on the stack
INTEGER REF NAME ; !>0 if variable is a REF(LOCATION) parameter
INTEGER GST ; !>0 if variable is a scalar in the GST area
INTEGER AN ARRAY; !>0 if variable is an array
!
! Characteristics of next name to be printed
!
INTEGER DATA AD ; !store address of the item
INTEGER 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
!
INTEGER DATA BYTES; !the length attribute of the item in bytes
INTEGER DATA SIZE ; !the length attribute of the item
! as follows:
! 3 => 1 byte, 4 => 2 bytes
! 5 => 4 bytes, 6 => 8 bytes
! 7 =>16 bytes
INTEGER NUM DATA ITEMS; !number of values associated with the item
!
! Work Variables
!
LONGINTEGER DESC TO PARM
INTEGER I
STRINGNAME NAME
!
! SET UP THE LIST OF ADDRESSES
!
PTR= SYMTABS; CYCLE NAME CNT=1,1,NO OF NAMES
ADDRESS(NAME CNT)= PTR + 4
PTR= (PTR + 8 + BYTEINTEGER(PTR+4)) & X'FFFFFFFC'
REPEAT
PTR TO NEXT TABLE= PTR
!
!
! INITIALISE VARIABLES FOR THE SORT OPERATION
!
!
MAX PTR= NO OF NAMES
MIN PTR= 1
!
! 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 PTR<MAX PTR CYCLE
!
! SELECT THE NEXT NAME
!
PTR ADDR= ADDRESS(PTR)
PTR NAME==STRING (PTR ADDR)
!
! TEST IF THE NEW NAME SHOULD BE THE MINIMUM
!
IF MIN>PTR 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<PTR NAME THENSTART
MAX ==PTR NAME
ADDRESS(PTR)= MAX ADDR
MAX ADDR = PTR ADDR
FINISH
FINISH
PTR= PTR + 1
REPEAT
!
! TEST FOR END OF SEARCH
!
ADDRESS (MIN PTR)= MIN ADDR AND ADDRESS(MAX PTR)= MAX ADDR
MAX PTR= MAX PTR - 1
MIN PTR= MIN PTR + 1
IF MIN PTR<MAX PTR THEN -> NEW SCAN
! START OUTPUTTING THE VARIABLE NAMES AND VALUES:
!
{!Initialise} DEFAULT DV TYPE = VERSION; !of compiler
NUM DATA ITEMS= 1
NAME CNT = 0
UNTIL NAME CNT=NO OF NAMES CYCLE
NAME CNT= NAME CNT+1
!
! GET THE CHARACTERISTICS OF THE NEXT VARIABLE
!
SET NAME
IF STACK¬=0 THEN DATA AD= OLD LNB + DISP C
ELSESTART
IF GST ¬=FALSE THEN DATA AD= GST ADDR + DISP ELSESTART
IF AN ARRAY¬=FALSE OR C
DATA TYPE= 5 THEN DATA AD= GLA ADDR + DISP C
ELSE DATA AD= BASE + DISP
FINISH
FINISH
IF REF NAME¬= False THENSTART
!
! Check if a REF(NAME) Parameter is defined
!
DESC TO PARM= LONGINTEGER(DATA AD)
IF AN ARRAY¬=False AND C
DV TYPE ¬= 0 THENSTART
!
! Modify Dope Vector to point to 1st Element
!
I = INTEGER(DATA AD) >> 27 {extract TYPE and SIZE of desc}
IF I = 1 {TYPE= 0 + SIZE=1} ORC
I = 2 {TYPE= 0 + SIZE=2} ORC
I>=24 {TYPE= 3 } THEN -> A {invalidity detected}
!
!Note, we must first check that we can modify the descriptor
! without provoking an interrupt from the MODD instruction
!
*LD_ DESC TO PARM; !load dope vector
*LXN_ DATA AD ; ! and modify to
*MODD_ (XNB +2) ; ! point to 1st element
*STD_ DESC TO PARM; ! and save the result
FINISH
*LD_ DESC TO PARM
*VAL_ (LNB +1)
*JCC_ 8,<B>
A: DATA AD=ADDR(BAD DESC OF PARM)
B: FINISH
IF AN ARRAY¬=0 THENSTART
IF ASIZE=0 OR C
DIAG <3 OR C
(DIAG =3 AND STATE>=0) THEN -> NEXT NAME
!
! HANDLE AN ARRAY
!
IF DATA TYPE=5 THEN DATA BYTES= INTEGER(DATA AD - 4)
IF DV TYPE=0 THEN DATA AD = ARRAY ADDRESS1(DATA AD)C
ELSE DATA AD = ARRAY ADDRESS2(DATA AD)
!
IF ASIZE<NUM DATA ITEMS THEN NUM DATA ITEMS=ASIZE
IF NUM DATA ITEMS = 1 THEN AN ARRAY=FALSE
FINISHELSESTART
IF DATA TYPE=5 THEN DATA BYTES=INTEGER(DATA AD)&X'FFFF'C
AND DATA AD =INTEGER(DATA AD+4) C
ELSESTART
IF REF NAME¬=0 THEN DATA AD =INTEGER(DATA AD+4)
FINISH ; FINISH
IF STATE=0 THENSTART
!
! PRINT THE COMMON NAME
!
IF SUBPROG NAME="F#BLCM" THEN SUBPROG NAME= "BLANK COMMON" C
ELSE SUBPROG NAME= "LABELLED COMMON " C
.SUBPROG NAME
PRINT STRING ( SUBPROG NAME. "
"); STATE=1
FINISH ; !=>COMMON name printed
PRINT NAME (NAME)
!
NEXT NAME: REPEAT
ROUTINE SET NAME
!
!
! A UTILITY ROUTINE TO PICK UP THE NEXT SCALAR NAME,
!
! AND TO DETERMINE ITS CHARACTERISTICS.
!
!
INTEGER NAME ADDR
INTEGER I
NAME ADDR = ADDRESS(NAME CNT)
NAME == STRING (NAME ADDR)
I = INTEGER(NAME ADDR - 4)
DATA TYPE = (I>>24) & 7
IF DATA TYPE=NONE THENSTART
!
! Process an Extension to the Identifier Record
!
NAME ADDR= SYMTABS + (I & X'FFFFFF')
I = INTEGER (NAME ADDR)
DATA TYPE=(I >> 24) & 7
DATA SIZE= I >> 28
DV TYPE= I & X'80000'
DISP= INTEGER (NAME ADDR+4)
FINISHELSESTART
!
! Extract Info from an ordinary Identifier Record
!
DATA SIZE= I >> 28
DISP= I & X'FFFFF'
DV TYPE= DEFAULT DV TYPE
FINISH
!
STACK= I & X'800000'
REF NAME = I & X'400000'
AN ARRAY= I & X'200000'
GST = I & X'100000'
!
IF DATA TYPE¬=5 THEN DATA BYTES= 1 << (DATA SIZE - 3)
!
END ; !of SET NAME
INTEGERFN ARRAY ADDRESS1 (INTEGER DV ADDR)
!
!
!
! AN INTEGER FUNCTION WITH ONE PARAMETER WHICH IS THE
!
! ADDRESS OF A DOPE VECTOR WHICH IS USED TO ACCESS
!
! ARRAYS RELATIVE TO THE FIRST ACTUAL ELEMENT.
!
!
! This form of dope vector is the general case for
! FORTRAN77 when array bound checking is to be
! performed. It is not used by FORTRAN(G) or FORTRAN(J).
!
!
! ITS PURPOSE IS TO DETERMINE THE NUMBER OF ELEMENTS IN THE
! ARRAY AND SET 'NUM DATA ITEMS' ACCORDINGLY, AND TO
! RETURN (AS THE RESULT) THE START ADDRESS OF THE ARRAY.
!
!
NUM DATA ITEMS= INTEGER(DV ADDR) & X'FFFFFF'
IF DATA TYPE=3 THENSTART ; NUM DATA ITEMS=NUM DATA ITEMS>>1
! The dope vector assumes
! that complex values are an ordered
! pair of real values
FINISHELSESTART
!
IF (DATA TYPE=1 AND DATA BYTES=2) OR C
DATA TYPE=5 THEN NUM DATA ITEMS= NUM DATA ITEMS//DATA BYTES
!
!IN INTEGER*2 AND CHARACTER ARRAY
!DOPE VECTORS ALL THE LENGTHS ARE
!IN BYTES, AND NOT ELEMENT SIZE.
FINISH
RESULT = INTEGER(DV ADDR+4)
!
!
!
END ; !of ARRAY ADDRESS1
INTEGERFN ARRAY ADDRESS2 (INTEGER DV ADDR)
!
!
!
! AN INTEGER FUNCTION WITH ONE PARAMETER WHICH IS THE
!
! ADDRESS OF A DOPE VECTOR WHICH IS USED TO ACCESS
!
! ARRAYS RELATIVE TO THE ZERO'TH ELEMENT.
!
!
! This form of dope vector is used by FORTRAN(G) and
! FORTRAN(J), and also by FORTRAN77 when no array bound
! checking is required.
!
!
! ITS PURPOSE IS TO DETERMINE THE NUMBER OF ELEMENTS IN THE
! ARRAY AND SET 'NUM DATA ITEMS' ACCORDINGLY, AND TO
! RETURN (AS THE RESULT) THE START ADDRESS OF THE ARRAY.
!
!
INTEGER K; !---the number of elements from zero'th to beginning
*LXN_ DV ADDR; *LB_ (XNB +2); !get no of elements from 0'th to start
*STB_ K ; !and store it in K
!
*LSS_ (XNB ) ; !Load bound from zero'th to last
*USH_ 8 ; ! and shift off descriptor type
*ISH_ -8 ; ! and shift back propagating the sign bit
*ISB_ B ; !Then subtract no of elements from 0'th to start
*ST_ NUM DATA C
ITEMS; ! and store result in NUM DATA ITEMS
!
IF DATA TYPE=3 THEN NUM DATA ITEMS= NUM DATA ITEMS >> 1 ELSESTART
!
IF (DATA TYPE=1 AND DATA BYTES=2) OR C
DATA TYPE=5 THEN NUM DATA ITEMS= NUM DATA ITEMS//DATA BYTES C
AND K = K //DATA BYTES
!In INTEGER*2 and CHARACTER array
!dope vectors all the lengths are
!in bytes, and not element size.
FINISH
!
RESULT = INTEGER(DV ADDR+4) + K*DATA BYTES
!
!
!
END ; !of ARRAY ADDRESS2
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:
!
CONSTINTEGERARRAY INTEGER WIDTHS (4:6)= 6, 11, 20
CONSTINTEGERARRAY COMPLEX WIDTHS (5:7)= 29, 45, 75
CONSTINTEGERARRAY REAL WIDTHS (5:7)= 14, 22, 37
CONSTINTEGERARRAY DECS PER SIZE (5:7)= 7, 15, 30
BYTEINTEGERARRAY MONITOR BUFFER (0:258); !%C
MONITOR BUFFER is used either as a workarea for C
printing a character value or as C
a buffer when outputting floating C
point values. It is large enough C
for the longest F(G) CHARACTER C
value (256) plus two delimiting C
apostrophes plus a byte for a C
string length.
! %C
For CHARACTER values which are greater than this buffer size, output C
is switched to an external area which is acquired via a C
call on F77AUX. This area will be at least 32771 bytes C
long (ie large enough to accomodate the largest possible C
CHARACTER value of FORTRAN77).
! %C
NOTE: Explicit reference to F77AUX must be avoided as C
FDIAG is also common to FORTRAN(G) and FORTRAN(J)C
and hence the Call Descriptor to F77AUX is pickedC
up from the user program GLA at displacement X'40'
!----BUFFER POINTERS-----!
! !
INTEGER BSTART; !address of the buffer
INTEGER BPTR DESC , BPTR ; !pointer to unfilled part of buffer
INTEGER BLEN ; !pointer to end of the buffer
!
INTEGER LINE LEN ; !length of unused part of the output buffer
INTEGER INDENT; !number of spaces reqd at the start of
! a continuation line
INTEGER I ; !utility variable
INTEGER J ; !utility variable
INTEGER REPLY ;!%C
from F77AUX in response to a request for a large area
!
! Format Control Variables
!
INTEGER FMTCODE ; !type of formatting to be performed on a value
INTEGER WIDTH ; !maximum number of digits to output
INTEGER EXP WIDTH ; !number of trailing spaces to follow the value
INTEGER 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'81818181' C
C
OR DATA AD= 0 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):
!
!
BPTR DESC= Byte Desc
BSTART= ADDR(MONITOR BUFFER(1))
!
-> PRINT VALUE OF (DATA TYPE)
!
! PRINT THE VALUE OF A CHARACTER SCALAR OR ARRAY
!
PRINT VALUE OF (A CHARACTER):
!
!
IF DATA BYTES>256 THENSTART
!
IF ADDR OF EXTERNAL AREA=NOT SET THENSTART
!
! Get Access to a Large Area via F77AUX
!
I= ADDR(DESC OF EXTERNAL AREA)
J= ADDR(REPLY)
!
{Do: } *PRCL_ 4
{ F77AUX } *LSS_ 13 ; *ST_ TOS
{ (13, } *LSD_ I ; *ST_ TOS
{ I, } *LXN_ GLA ADDR; *RALN_ 8
{ J)} *CALL_ ((XNB +10))
!
NUM DATA ITEMS=1 ANDRETURN IF REPLY¬=0; !%C
ie forget the variable if area is not available
FINISH
!
BSTART= ADDR OF EXTERNAL AREA+1; !which is at least
FINISH ; ! 32771 bytes long
!
!
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):
!
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= BSTART 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).
!
!
!
CONSTBYTEINTEGERARRAY ETOITAB(0 : 255) = C
0, 1, 2, 3, 156, 9, 134, 127,
151, 141, 142, 11, 12, 13, 14, 15,
16, 17, 18, 19, 157, 10, 8, 135,
24, 25, 146, 143, 28, 29, 30, 31,
128, 129, 130, 131, 132, 133, 23, 27,
136, 137, 138, 139, 140, 5, 6, 7,
144, 145, 22, 147, 148, 149, 150, 4,
152, 153, 154, 155, 20, 21, 158, 26,
32, 160, 161, 162, 163, 164, 165, 166,
167, 168, 91, 46, 60, 40, 43, 33,
38, 169, 170, 171, 172, 173, 174, 175,
176, 177, 93, 36, 42, 41, 59, 94,
45, 47, 178, 179, 180, 181, 182, 183,
184, 185, 124, 44, 37, 95, 62, 63,
186, 187, 188, 189, 190, 191, 192, 193,
194, 96, 58, 35, 64, 39, 61, 34,
195, 97, 98, 99, 100, 101, 102, 103,
104, 105, 196, 197, 198, 199, 200, 201,
202, 106, 107, 108, 109, 110, 111, 112,
113, 114, 203, 204, 205, 206, 207, 208,
209, 126, 115, 116, 117, 118, 119, 120,
121, 122, 210, 211, 212, 213, 214, 215,
216, 217, 218, 219, 220, 221, 222, 223,
224, 225, 226, 227, 228, 229, 230, 231,
123, 65, 66, 67, 68, 69, 70, 71,
72, 73, 232, 233, 234, 235, 236, 237,
125, 74, 75, 76, 77, 78, 79, 80,
81, 82, 238, 239, 240, 241, 242, 243,
92, 159, 83, 84, 85, 86, 87, 88,
89, 90, 244, 245, 246, 247, 248, 249,
48, 49, 50, 51, 52, 53, 54, 55,
56, 57, 250, 251, 252, 253, 254, 255
INTEGER PTR DESC
INTEGER PTR ; !ptr to copy of value to be output
INTEGER BUFF PTR; !ptr to next portion of the value to be output
INTEGER LEN; !length of value still to be output
INTEGER CNT; !length of current record which has been used
INTEGER LENGTH; !length of the whole value to be output
!
! Initialise Variables
!
PTR= BSTART ; !ptr to beginning of actual value to output
LENGTH=DATA BYTES+2; !len of character value + allowance
! for enclosing quotes
IF LENGTH<12 AND AN ARRAY¬=FALSE THENSTART
!
! Insert leading spaces in the buffer
!
*LDTB_ X'1900000C'; !By indenting each Character value
*MODD_ LENGTH ; ! we ensure that any unassigned
*LDA_ PTR ; ! message which is output will
*MVL_ L =DR ,0,32; ! not upset the columns in which
*STD_ PTR DESC ; ! the Character array is output
LENGTH= 12 ; !
FINISH
BYTEINTEGER( PTR)=QUOTE; !Insert the
PTR =PTR+1; ! enclosing quotes
BYTEINTEGER(DATA BYTES+PTR)=QUOTE; ! in the buffer
!
! Acquire the (next) Character value
!
AT START OF LINE: CNT= 0
!set length of the current record
!
NEXT VALUE:
!
! Check for an unassigned variable
!
IF BYTEINTEGER(DATA AD)= 0 THENSTART
PRINT STRING (NOT ASSIGNED TEXT)
IF LENGTH< LINE LEN THEN SPACES(LENGTH-12)
FINISHELSESTART
!
! Copy the next value
!
*LDTB_ BYTE DESC ; *LDA_ DATA AD; !Perform
*LDB_ DATA BYTES; *CYD_ 0 ; ! MOVE(DATA BYTES
*LDA_ PTR ; *MV_ L =DR ; ! , DATA AD , PTR)
!
UNLESS EBCDIC MODE=FALSE THENSTART
!
*LDB_ DATA BYTES ; *LSS_ ETOITAB+4
*LUH_ X'18000100'; *LDA_ PTR
*TTR_ L =DR
FINISH ; !Doing ETOI(PTR,DATA BYTES)
BUFF PTR= BSTART-1; !prepare to
LEN= LENGTH ; ! output the value
!
! Output the Character value
!
WHILE LEN>LINE LEN CYCLE
!
BYTEINTEGER(BUFF PTR)= LINE LEN ; !While the value
PRINTSTRING(STRING(BUFF PTR)); NEWLINE ; ! extends over one
SPACES(INDENT) ; ! line, continue writing
! one line's worth
BUFF PTR= BUFF PTR + LINE LEN ; !Then select
LEN= LEN - LINE LEN ; ! the next chunk
REPEAT
!
{!Output (the last of) the value } BYTEINTEGER(BUFF PTR)= LEN
PRINTSTRING(STRING(BUFF PTR))
FINISH
!
! Test if there are more values
!
IF NUM DATA ITEMS<=1 THENRETURN
NUM DATA ITEMS = NUM DATA ITEMS - 1
DATA AD = DATA BYTES + DATA AD
!
! Prepare for the next Character value
!
CNT= CNT + LENGTH
IF CNT<LINE LEN THEN PRINT SYMBOL (',') AND CNT=CNT+1
IF CNT<LINE LEN 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)
!
!
!
STRING (12) VALUE; INTEGER BOOLEAN VALUE
!
INTEGER PTR; !a note of where we are within the current output line
!
BEGIN: PTR= INDENT
LOOP: !Perform unassigned checking
!
*LDTB_ BYTE DESC; *CYD_ 0 ; !ACC=zero desc
*LDA_ DATA AD ; *LDB_ DATA BYTES ; ! DR=desc to item
*CPS_ L =DR ,0,129 ; !test if assigned
*JCC_ 7,<EXAMINE VALUE>; ! and -> if it is
!
{Otherwise} VALUE = NOT ASSIGNED TEXT AND -> PRINT
EXAMINE VALUE: BOOLEAN VALUE= BYTEINTEGER(DATA AD + DATA BYTES-1) & 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 BYTES + DATA AD
PRINT SYMBOL (','); PTR= PTR + 13
IF PTR<OUTPUT LEN-13 THEN -> 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
!
!
CONSTLONGLONGREALARRAY POWERS OF TEN (5:7)= C
C
R'46989680000000003800000000000000' ,
R'4D38D7EA4C6800003F00000000000000' ,
R'59C9F2C9CD04674E4BDEA40000000000'
!
!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.
!
!
INTEGER BUFF DESC
INTEGER BUFF ADDR ; !actual address of formatted value in the buffer
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; {space-fill } *LD_ BPTR DESC
{ the output} *LDB_ LENGTH
{ field } *MVL_ L =DR ,0,32
!
! Test for an unassigned INTEGER or REAL or COMPLEX (real part only)
!
*LDTB_ BYTE DESC; *LDA_ DATA AD
*LSD_ BYTE DESC; *LDB_ DATA BYTES
*CPS_ L =DR ,0,129
*JCC_ 8,<UNASSIGNED VARIABLE>
IF DATA TYPE=A COMPLEX THENSTART
!
! Test for an unassigned imaginary part
!
*LSD_ BYTE DESC ; *LDB_ DATA BYTES
*LDA_ DATA AD ; *INCA_ DATA BYTES
*CPS_ L =DR ,0,129
{-> if unassigned} *JCC_ 8,<UNASSIGNED COMPLEX>
!
{!--else print the value} OUTPUT COMPLEX
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 BYTES + DATA AD
!
BYTEINTEGER(BPTR)= ',' ; !then insert the
BPTR =BPTR + 1; ! trailing comma
!
! Decide if we need another record
!
IF BPTR+LENGTH<BLEN THEN -> CYCLE
!
MONITOR BUFFER(0)= BPTR - BSTART
PRINT STRING (STRING(BSTART-1))
NEWLINE; SPACES (INDENT)
!
BPTR=BSTART AND -> CYCLE
UNASSIGNED VARIABLE: !Report an Unassigned
UNASSIGNED COMPLEX : ! Real, Integer, or Complex
!
IF AN ARRAY=FALSE THEN PRINT STRING (NOT ASSIGNED TEXT) C
ANDRETURN
!
{For an unassigned } *LD_ NOT ASSIGNED TEXT
{ array element, } *MODD_ 1
{ place the } *CYD_ 0 ; !ACC= desc(NOT ASSIGNED TEXT)
{ NOT ASSIGNED }
{ text directly in} *LDA_ BPTR ; !DR1= BPTR
{ the buffer and } *INCA_ LENGTH ; !DR1= BPTR + LENGTH
{ right-justify it} *INCA_ -12 ; !DR1= BPTR + LENGTH - 12
{ within the } *MV_ L =DR ; !then right justify text
{ reserved field} *STD_ BPTR DESC; ! into the field
!
IF DATA TYPE=A COMPLEX THEN DATA AD= DATA AD + DATA BYTES
!
-> NEXT VALUE
!
! TIDY UP --- PRINT THE (final) LINE
!
RETURN: !If the item is a scalar }
{! then ignore leading spaces} IF AN ARRAY=FALSE THENSTART
!
*LDTB_ BYTE DESC; *LDB_ BPTR; !DR= descriptor
*MODD_ BSTART ; ! to the buffer
*LDA_ BSTART ; ! contents
!
*SWEQ_ L =DR ,0,32 ; !skip over leading spaces
*STD_ BUFF DESC ; ! and save address of 1st character
!
FINISHELSE BUFF ADDR= BSTART
BYTEINTEGER(BUFF ADDR-1)= BPTR - BUFF ADDR
PRINT STRING (STRING(BUFF ADDR-1))
RETURN
ROUTINE OUTPUT COMPLEX
!
!
!
! A LOCAL PROCEDURE WHICH OUTPUTS A COMPLEX VALUE
!
!
!
!
INTEGERFNSPEC WIDTH FOR (INTEGER DATA AD)
!
INTEGER WIDTH1; !field width reserved for the real part
INTEGER WIDTH2; !field width reserved for the imaginary part
INTEGER 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
!
INTEGER 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 BYTES)
WIDTH3= WIDTH1 + WIDTH2 + 3; !=Width(imaginary part) + '('
!+Width(real part) + ',' + ')'
!
! Note any leading spaces required to right-justify the value
!
SPACES REQD= LENGTH-WIDTH3
IF SPACES REQD> 0 THEN BPTR= BPTR + SPACES REQD
!
! Now Output the Real Part
!
BYTEINTEGER(BPTR)= '(' AND BPTR=BPTR+1
WIDTH = WIDTH1
OUTPUT REAL
BYTEINTEGER(BPTR)= ',' AND BPTR=BPTR+1
!
! Then Output the Imaginary Part
!
DATA AD=DATA AD + DATA BYTES
WIDTH=WIDTH2
OUTPUT REAL
!
! Finally Return
!
BYTEINTEGER(BPTR)= ')'
BPTR = BPTR+1
RETURN
INTEGERFN WIDTH FOR (INTEGER DATA AD)
!
!
!
!
! A LOCAL PROCEDURE WHICH RETURNS THE FIELD WIDTH TO BE USED
!
! TO OUTPUT A PART OF A COMPLEX VALUE. THE FACTORS
!
! INVOLVED ARE THE SCALE OF THE VALUE AND THE NUMBER
!
! OF SIGNIFICANT DIGITS REQUIRED.
!
!
!It should be noted that the value returned will be exactly
! sufficient to format the number without any leading spaces.
!
!
!
LONGLONGREAL A ; !a copy of the value to be output
INTEGER SIGN ; !set to one if the value is -ve, else set to zero
INTEGER WIDTH; !----the result returned
!
! Get a copy of the complex part
!
IF DATA SIZE=5 THEN A= REAL(DATA AD) ELSESTART
IF DATA SIZE=7 THEN A=LONGLONGREAL(DATA AD) C
ELSE A= LONGREAL(DATA AD); FINISH
!
IF A<0.0 THEN A=-A AND SIGN=TRUE C
ELSE SIGN=FALSE
!
! Determine whether 'F' or 'E' formatting will be used
!
IF A>=POINT ONE AND A<POWERS OF TEN(DATA SIZE) THENSTART
!
{!'F' formating will be used} WIDTH=DECIMALS+1
WIDTH= WIDTH+1 IF A<1.0
FINISHELSE WIDTH=DECIMALS+5
RESULT =WIDTH+SIGN
!(add on one if value is negative)
END ; !of WIDTH FOR
END ; !of OUTPUT COMPLEX
ROUTINE OUTPUT REAL
!
!
!
!
! A utility procedure to format a real or integer value (as
! described by the variables DATA TYPE, DATA AD, and DATA
! BYTES) at address BPTR according to the values in WIDTH,
! FMTCODE, and DECIMALS.
!
! (In addition, the variable EXP WIDTH indicates the number)
! (of spaces required on the right of a real value. )
!
!
!
LONGLONGREALFNSPEC INTO RANGE (LONGLONGREAL VALUE)
!
BYTEINTEGERARRAY OUTPUT AREA (0:47)
!Work-area for assembling
! the digits to be output
!
! POINTERS
!
INTEGER AREA DESC ; !Descriptor used to
INTEGER AREA PTR ; ! save numerals in the work-area
!
INTEGER PTR DESC ; !Descriptor used to construct a
INTEGER PTR ; ! formatted value in the output area
INTEGER PTR MAX ; !addresses the end of the output field (+1)
!
! LOCAL VARIABLES DESCRIBING THE FORMAT CODE
!
INTEGER FORMAT ; !initially set from FMTCODE
INTEGER DECS ; !initially set from DECIMALS
INTEGER LENGTH ; !initially set from WIDTH
!
! VARIABLES DESCRIBING THE VALUE TO FORMAT
!
LONGLONGREAL A ; !the value in question precision is required
LONGINTEGER LONG I ; ! used to FIX the value of A
!
INTEGER SIGN ; !the sign to be output with the value
! = '+' or '-'
!else = 0 if no sign is required
INTEGER EXP ; !magnitude of value expressed as multiple of 10
INTEGER N , I ; !Work variables
!
! FORMATTING CONTROL VARIABLES
!
INTEGER MAX INT DIGITS; !maximum number of digits that may be
! output left of the decimal point
INTEGER INT DIGITS; !number of digits required left of the '.'
INTEGER LEADING ZEROS ; !number of zeros required right of the '.'
INTEGER TOTAL CHARS ; !number of digits required both left
! and right of the decimal point
!
! VARIABLES ASSOCIATED WITH FORMATTING AN EXPONENT
!
INTEGER EXPONENT ; !Value of exponent to format
INTEGER EXP TYPE ; !Qualifier to be associated with the exponent
! = 'Q' for REAL*16
! = 'D' for REAL* 8
! = 'E' otherwise or FORMAT='E'
!
! INITIALISE VARIABLES
!
LENGTH = WIDTH
PTR = BPTR
PTR MAX = PTR + LENGTH
PTR DESC=STRING DESC ! LENGTH
FORMAT =FMTCODE
!
!
! PICK UP THE VALUE TO BE FORMATTED NUMERICALLY
!
!
IF FORMAT='G' THENSTART ; !LOAD UP A REAL VALUE
!
IF DATA BYTES= 8 THEN A= LONGREAL(DATA AD) ELSESTART
IF DATA BYTES=16 THEN A=LONGLONGREAL(DATA AD) C
ELSE A= REAL(DATA AD); FINISH
A=A + 0.0
!normalise
FINISHELSESTART
!
! LOAD UP AN INTEGER VALUE
!
IF DATA BYTES=8 THENSTART
!
! Handle an INTEGER*8
!
A= LONGINTEGER(DATA AD)
FINISHELSESTART
!
! Handle an INTEGER*4 or INTEGER*2
!
IF DATA BYTES=2 THENSTART
*LDTB_ X'58000002'; *LDA_ DATA AD
*LSS_ (DR )
*USH_ 16
*ISH_ -16 ; *ST_ I
FINISHELSE I=INTEGER (DATA AD)
-> QUICK I FORMAT
FINISH
FINISH
!
! HANDLE A NEGATIVE VALUE
!
IF A<0.0 THEN A=-A AND SIGN=MINUS AND LENGTH=LENGTH-1 C
ELSE SIGN= NONE
{make a descriptor to} *LD_ OUTPUT AREA; *STD_ AREA DESC
{ the work-area} AREA DESC= X'01000000' ! AREA DESC
! (switch off bound checking)
EXP=1;! %FINISH
!preparing for numeric formatting
IF FORMAT='I' THEN -> I FORMAT
!
!***********************************************************************
!
! HANDLE 'G' FORMAT
!
!***********************************************************************
!
G FORMAT: DECS= DECIMALS
!
IF POINT ONE<=A<POWERS OF TEN(DATA SIZE) THENSTART
!
! OUTPUT THE VALUE WITHOUT AN EXPONENT (and left-justify it as well)
!
A =INTO RANGE (A) + 5.0/POWERS OF TEN(DATA SIZE)
IF 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:
!
IF EXPONENT<0 THEN SIGN=MINUS C
ELSE SIGN=PLUS
!
! Determine the characteristic of the exponent
!
IF VERSION¬=F77 AND DATA BYTES>4 THENSTART
IF DATA BYTES>8 THEN EXP TYPE= 'Q' C
ELSE EXP TYPE= 'D'
FINISHELSE EXP TYPE= 'E'
{and write it into the field} *LDB_ 4
*LB_ EXP TYPE; *MVL_ L =1
!
! Produce the exponent part
!
*LB_ SIGN ; *MVL_ L =1 ; !get the sign and move it into buffer
*STD_ PTR DESC; ! and save address of exp digits
!
*LSS_ EXPONENT; *CDEC_ 0 ; !get the exponent (in decimal form)
*MPSR_ X'24' ; *DSH_ 13 ; ! and left-justify it in the ACC
*SUPK_ L =DR ; !----and format into EBCDIC digits
-> FINALISE INTEGER
!Jump to convert EBCDIC digits into ISO digits
!***********************************************************************
!
! 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 and in EBCDIC
!
*LD_ AREA DESC ; *LDB_ LEADING ZEROS
*LB_ EBCDIC ZERO ; *MVL_ L =DR
*LD_ AREA DESC ; *MODD_ LEADING ZEROS
*STD_ AREA DESC ;
!save the address of the next free byte of the work area
FINISHELSESTART ;
!
! Determine total number of numerals required if value>=1.0
!
TOTAL CHARS= INT DIGITS + DECS
FINISH
FORMAT DIGITS:
!
!
! ACQUIRE ALL THE DIGITS (AND POSSIBLY MORE) THAT ARE NEEDED
!
! The code below produces 12 digits at a
! time and saves them (in EBCDIC) in
! the workarea.
!
! DO FORMATTING AT EXTENDED PRECISION
A= A * TEN TO THE 11 ; !
*LD_ AREA DESC
WHILE TOTAL CHARS>0 CYCLE
TOTAL CHARS=TOTAL CHARS-12
!
*LSD_ A ; *FIX_ B
*MYB_ 4 ; *USH_ B
!Perform LONG I= INT PT (A)
!
! (NOTE that INT PT is an INTEGER
! function and not LONGINTEGER
! ---hence the Assembler)
*ST_ LONG I;
*CDEC_ 0 ;
*DSH_ 19 ; *MPSR_ X'24'
*SUPK_ L =12 ;
!
!We have now:
! 1/. got the value in decimal
! 2/. moved it to the top of ACC
! 3/. set condition code to 1
! 4/. acquired 12 alphanumerics
A= (A - LONG I) * TEN TO THE 12
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 ; *LB_ SIGN; *LDB_ 1; *LDA_ PTR
*MVL_ L =1; *STD_ PTR DESC
!
!Move any required sign into the field
FINISH
!
! Write out the digits to the left of the decimal point
!
*LSD_ OUTPUT AREA ; !ACC -> digits generated in the work-area
*LDB_ INT DIGITS; !DR -> sub-field allocated to the left
*LDA_ PTR ; ! hand side of the decimal point
!
*MV_ L =DR ; *ST_ AREA DESC
!perform move; !save ptr to remainder of the digits
!
! Write out the decimal point
!
IF FORMAT='I' THEN -> FINALISE FORMATING
!
*LB_ DOT; *LDB_ 1; *MVL_ L =1
!
! Write out the digits to the right of the decimal point
!
IF DECS>0 THENSTART
!
*LSD_ AREA DESC; *LDB_ DECS
*MV_ L =DR
FINISH
FINALISE FORMATING: !by translating the EBCDIC numerals into ISO
!
*STD_ N; *LDA_ NIL; !construct a descriptor
*LDB_ I; *MODD_ PTR; ! to the numerals
!
*MVL_ L =DR ,31,32; !and perform the %C
translation
IF FORMAT='E' THEN -> OUTPUT THE EXPONENT
!
!Jump if format code is 'E' and continue
! to format the exponent characteristic
-> EXIT
!
!
!***********************************************************************
!
! HANDLE 'I' FORMAT for INTEGER*8
!
!***********************************************************************
!
I FORMAT:
!
IF A=0.0 THEN -> OUTPUT A ZERO INTEGER
A=INTO RANGE( A + 0.5 )
!apply rounding and bring the value into the range 10.0> A >=1.0
!
! Initialise formatting control variables
!
INT DIGITS= EXP ; !number of significant digits
TOTAL CHARS= INT DIGITS; ! that must be output
MAX INT DIGITS= LENGTH; !number of digits that may be output
-> FORMAT DIGITS
OUTPUT A ZERO INTEGER:
! OUTPUT A ZERO INTEGER:
! OUTPUT A ZERO INTEGER:
!
BYTEINTEGER(PTR MAX-1)= NOUGHT AND -> EXIT
!***********************************************************************
!
! HANDLE 'I' FORMAT -----QUICKLY
!
!***********************************************************************
!
QUICK I FORMAT: !Simplified code may be used if the corresponding
! I/O item is an INTEGER*2 or INTEGER*4.
!
IF I=0 THEN -> OUTPUT A ZERO INTEGER
IF I<0 THEN SIGN=MINUS C
ELSE SIGN= NONE
N=15 - LENGTH
{If LENGTH is greater } IF N< 0 THENSTART
{ than 15 then the }
{ code below cannot } PTR= PTR - N
{ generate any leading} N= 0
{ spaces automatically}
{So PTR must be re-set } FINISH
!
! FORMAT THE INTEGER
!
*LSS_ I; *CDEC_ 0; !First load the value and convert into decimal
*DSH_ N
!This moves the number up the ACC so that the subsequent SUPK
!instruction produces the right number of leading spaces as
! well as the required digits.
*LDTB_ STRING DESC; *LDA_ 0
*LDB_ PTR MAX ; *MODD_ PTR ; !Get and save a descriptor
*STD_ PTR DESC; ! to the output field
*MPSR_ X'20' ; !Set condition code to zero
*SUPK_ L =DR ,0,64;
!formats the decimal value in ACC into EBCDIC characters.
! Any leading zeros produce EBCDIC spaces.
!
! Insert any sign
!
*LD_ TOS ; !unstack descriptor generated by SUPK
*LB_ SIGN; *JAT_ 12,<FINALISE INTEGER>; !skip if no sign reqd
*MVL_ L =DR ; !else move the sign in
!
! Translate the result into ISO
!
FINALISE INTEGER: *LD_ PTR DESC ; !convert EBCDIC zones X'F0'
*MVL_ L =DR ,31,32; ! into ISO zones X'30'
!***********************************************************************
!
! END OF HANDLING OUTPUT FORMATS
!
!***********************************************************************
!
EXIT: BPTR= PTR MAX
!
RETURN
!
!
!
!***********************************************************************
!
! ROUTINES FOR HANDLING OUTPUT FORMATS
!
!***********************************************************************
!
LONGLONGREALFN INTO RANGE (LONGLONGREAL 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.
!
!
LONGLONGREAL Y
LONGLONGREAL Z
!
INTEGER I; !a work variable
IF X>=10.0 THENSTART
!
! The value is too large
!
IF X<TEN TO THE 75 THENSTART
!
! Find the scale of the number and bring it into range
!
I= 1; Z= 10.0
Y=100.0
!
Z=Y AND Y=Z*10.0 AND I=I+1 WHILE X>=Y
!
X=X/Z AND EXP=EXP+ I
FINISHELSE EXP=EXP+75 AND X=X/TEN TO THE 75
FINISH
IF X<1.0 THENSTART
!
! The value is too small
!
X=X*10.0 AND EXP=EXP-1 WHILE X<TEN TO THE MINUS 75
!
I= 1
Z=POINT ONE
!
I=I+1 AND Z=Z/10.0 WHILE X<Z
!
EXP=EXP-I
X= X * (10.0**I)
FINISH
!
! Return
!
RESULT = X
!
END ; !of INTO RANGE
END ; !of OUTPUT REAL
END ; !of OUTPUT NUMERIC
END ; !of PRINT NAME
END ; !of SORT AND PRINT NAMES
ROUTINE DUMP(INTEGER START, FINISH)
INTEGER I, J
I=START&(-4)
WHILE I<FINISH CYCLE
PRINTSYMBOL('(')
PHEX(I)
PRINTSTRING(") ")
CYCLE J=I,4,I+28
IF J>=FINISH THEN ->L
SPACES(2)
PHEX(INTEGER(J))
REPEAT
L: NEWLINE
I=I+32
REPEAT
END ; !of DUMP
ROUTINE PHEX (INTEGER VALUE)
!
!
!
!
! A utility routine which prints the parameter as a
!
! hexadecimal value on the currently
!
! selected output stream.
!
!
!
CONSTBYTEINTEGERARRAY HEX(0:15)= '0' , '1' , '2' , '3' ,
'4' , '5' , '6' , '7' ,
'8' , '9' , 'A' , 'B' ,
'C' , 'D' , 'E' , 'F'
INTEGER I
CYCLE I=28,-4,0
PRINT SYMBOL (HEX(VALUE>>I&15))
REPEAT
END ; !of PHEX
END ; !of FDIAG
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
!
ENDOFFILE