! fcinnum1a
! 15/01/87 - insert %alias for amdahl system routines
!
! Modified 5/June/86 8.00
!***********************************************************************
!*********************************************************************%C
%C
%C
A SET OF NUMBER CONVERSION ROUTINES (version 6.0) %C
%C
FOR THE FORTRAN77 %C
%C
(used either by the compiler or F77IOA and F77IOC) %C
%C
%C
!*********************************************************************%C
!***********************************************************************
!---Modes of Operation:
!
!
%constinteger Compile Time = 0
%constinteger Run Time1= 1 { report CONSTANT OUT OF RANGE}
%constinteger Run Time2= 2 {dont report CONSTANT OUT OF RANGE}
%constinteger MODE = Compile Time
!change MODE if running with the compiler!
!---Conditional Compilation Variables:
!
!
%constinteger EMAS = 0
%constinteger PERQ = 1
%constinteger PNX = 2
%constinteger IBM = 3
%constinteger PERQ3= 4
%constinteger Whitechapel= 5
%constinteger Gould= 6
%constinteger False= 0
%constinteger True = 1
!---------------------------------------!
! !
! !
! CONDITIONAL COMPILATION CONSTANTS !
! !
! !
!---------------------------------------!
%CONSTINTEGER TARGET= GOULD
%CONSTINTEGER HOST= IBM
%CONSTINTEGER Relax Ansi= False
%IF TARGET=EMAS %THENSTART
!
!
! Define Conditional Compilation Constants for EMAS
!
!
%CONSTINTEGER k= 0 ;!%C
k is set to the shift count required to convert %C
a byte displacement into an address displacement
%CONSTINTEGER HALFs= True ;!%C
HALFS= True implies that 16-bit entities are accessed%C
via the HALFINTEGER map and are unsigned
%CONSTINTEGER IEEE= False ;!%C
IEEE= False implies that floating point constants %C
conform to the 'excess-64' notation as %C
used by IBM and ICL 2900s
%CONSTINTEGER Byte Addressing= True ;!%C
Byte Addressing= True implies that {address}+1 %C
accesses the next byte and not the next word
%CONSTINTEGER CR Delimiter= False ;!%C
CR Delimiter= False implies that the Carriage Return %C
character is not an alternative record delimiter %C
to the Newline (NL) character in a formatted input%C
field
%CONSTINTEGER Output Len= 120 ;!%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
%CONSTINTEGER UNIX IO= False ;!%C
UNIX IO= False implies that the underlying target %C
file system is not UNIX or UNIX based
%CONSTINTEGER Unassigned Word= X'80808080'
%CONSTINTEGER Unassigned Half= X'FFFF8080'
%CONSTINTEGER Unassigned Char= 0
! {!!!} %CONSTLONGINTEGER Unassigned Long= R'8080808080808080'
%FINISH
%IF TARGET= IBM %THENSTART
!
!
! Define Conditional Compilation Constants for Amdahl
!
!
%CONSTINTEGER k= 0
%CONSTINTEGER HALFs= False ;!%C
HALFS= False if 16-bit entities are accessed via %C
the SHORTINTEGER map and they are signed
%CONSTINTEGER IEEE= False
%CONSTINTEGER Byte Addressing= True
%CONSTINTEGER CR Delimiter= False
%CONSTINTEGER Output Len= 120
%CONSTINTEGER UNIX IO= False
%CONSTINTEGER Unassigned Word= X'81818181'
%CONSTINTEGER Unassigned Half= X'FFFF8181'
%CONSTINTEGER Unassigned Char= 0
! {!!!} %CONSTLONGINTEGER Unassigned Long= R'8181818181818181'
%FINISH
%IF TARGET=PERQ %THENSTART
!
!
! Define Conditional Compilation Constants for ACCENT or WHITECHAPEL
!
!
%CONSTINTEGER k= 1
%CONSTINTEGER HALFs= False
%CONSTINTEGER IEEE= True ;!%C
IEEE= True implies that floating point constants %C
conform to the IEEE Standard
%CONSTINTEGER Byte Addressing= False ;!%C
Byte Addressing= False implies that {address}+1 %C
accesses the next word and not the next byte
%CONSTINTEGER CR Delimiter= True ;!%C
CR Delimiter= True implies that the Carriage Return %C
character within a formatted input field is to be %C
regarded as an alternative record delimiter to the%C
Newline (NL) character
%CONSTINTEGER Output Len= 84
%CONSTINTEGER UNIX IO= False
%CONSTINTEGER Unassigned Word= X'80808080'
%CONSTINTEGER Unassigned Half= X'FFFF8080'
%CONSTINTEGER Unassigned Char= X'81'
%FINISH
%IF TARGET= PNX %THENSTART
!
!
! Define Conditional Compilation Constants for PNX
!
!
%CONSTINTEGER k= 1
%CONSTINTEGER HALFs= True
%CONSTINTEGER IEEE= True
%CONSTINTEGER Byte Addressing= False
%CONSTINTEGER CR Delimiter= True
%CONSTINTEGER Output Len= 84
%CONSTINTEGER UNIX IO= True ;!%C
UNIX IO= True implies that the underlying target %C
file system is UNIX or UNIX-like
%CONSTINTEGER Unassigned Word= X'80808080'
%CONSTINTEGER Unassigned Half= X'FFFF8080'
%CONSTINTEGER Unassigned Char= X'80'
%FINISH
%IF TARGET= PERQ3 %THENSTART
!
!
! Define Conditional Compilation Constants for PERQ3
!
!
%CONSTINTEGER k= 0
%CONSTINTEGER HALFs= False ;!%C
HALFS= False if 16-bit entities are accessed via %C
the SHORTINTEGER map and they are signed
%CONSTINTEGER IEEE= True
%CONSTINTEGER Byte Addressing= True
%CONSTINTEGER CR Delimiter = True
%CONSTINTEGER Output Len = 84
%CONSTINTEGER UNIX IO= True
%CONSTINTEGER Unassigned Word= X'81818181'
%CONSTINTEGER Unassigned Half= X'FFFF8181'
%CONSTINTEGER Unassigned Char= X'81'
%FINISH
%IF TARGET= Whitechapel %THENSTART
!
!
! Define Conditional Compilation Constants for WHITECHAPEL
!
!
%CONSTINTEGER k= 0
%CONSTINTEGER HALFs= False ;!%C
HALFS= False if 16-bit entities are accessed via %C
the SHORTINTEGER map and they are signed
%CONSTINTEGER IEEE= True
%CONSTINTEGER Byte Addressing= False
%CONSTINTEGER CR Delimiter = True
%CONSTINTEGER Output Len = 84
%CONSTINTEGER UNIX IO= True
%CONSTINTEGER Unassigned Word= X'81818181'
%CONSTINTEGER Unassigned Half= X'FFFF8181'
%CONSTINTEGER Unassigned Char= X'81'
%FINISH
%IF TARGET= GOULD %THENSTART
!
!
! Define Conditional Compilation Constants for GOULD
!
!
%CONSTINTEGER k= 0
%CONSTINTEGER HALFs= False ;!%C
HALFS= False if 16-bit entities are accessed via %C
the SHORTINTEGER map and they are signed
%CONSTINTEGER IEEE= False
%CONSTINTEGER Byte Addressing= True
%CONSTINTEGER CR Delimiter = True
%CONSTINTEGER Output Len = 80
%CONSTINTEGER UNIX IO= True
%CONSTINTEGER Unassigned Word= X'81818181'
%CONSTINTEGER Unassigned Half= X'FFFF8181'
%CONSTINTEGER Unassigned Char= X'81'
%FINISH
!NOTE: Other lines that might require changing are marked with the pattern {!!!}
%EXTERNALINTEGERFN IN NUMBER %ALIAS "S#INNUMBER" %C
(%INTEGER DATA AD, DATA LEN , FORMAT,BLANKS,
%INTEGER DECS, SCALE FACTOR,
%INTEGERNAME TEXT PTR , TEXT END ,
%BYTEINTEGERARRAYNAME IO BUFFER, TEXT )
!
!
!
!
! This Procedure Analyses the Number in the Input Buffer
!
! to determine (A) if the Syntax is correct,
!
! (B) the scale of the number
!
! and to remove all occurrences of signs, exponents, and decimal points.
!
!
! This Procedure then Converts the Number into Binary.
!
!
!The following table represents values assigned to each
! character in the ISO Character Set. The assignments
! are made on the following basis:
!
%CONSTINTEGER Syntax Fault = 0 {for an invalid char},
A Blank = 1 {for ' ' },
A Digit = 2 {for '0' - '9' incl },
A Sign = 3 {for '+' , '-' },
A Decimal Point = 4 {for '.' },
A Lower Case Exp{onent}= 5 {for 'd' , 'e' , 'q'},
An Exponent = 6 {for 'D' , 'E' , 'Q'},
A Comma = 7 {for premature end }; !%C
A Carriage Return = 7 { of field}
%CONSTBYTEINTEGERARRAY TYPE (0:127)= Syntax Fault (13),
A Comma {for Carriage Return},
Syntax Fault (18), A Blank { },
Syntax Fault (10),
A Sign { + } , A Comma , A Sign { - },
A Decimal Point { . } , Syntax Fault ,
A Digit {0-9} (10) , Syntax Fault (10),
An Exponent {D,E} ( 2) , Syntax Fault (11),
An Exponent { Q } , Syntax Fault (18),
A Lower Case Exp {d,e} ( 2) , Syntax Fault (11),
A Lower Case Exp { q} , Syntax Fault (14)
!
!
%SWITCH HANDLE (Syntax Fault:A Comma)
!NOTE that the parameter list makes no allowances for byte offsets
! from word addresses which is required for type BYTE
! when running on ACCENT, and hence it has been assumed
! that for type BYTE the calling routine will nominate an
! address of a four-byte work area which it will copy to
! the final destination after IN NUMBER returns.
!NOTE if running in compiler mode then IN NUMBER returns -1
! as a result if more digits are specified than can
! be represented in the requested precision
!
%IF MODE= Compile Time %THENSTART
!
!INTEGER RESULT
%CONSTINTEGER No Comment= 0 ,
Lost Significance= -1
%FINISH
!
!***********************************************************************
!
! CONSTANTS
!
!***********************************************************************
!
%CONSTINTEGER CR =13 {for Carriage Return}
%CONSTINTEGER Zero = 0
%CONSTINTEGER Null = 0
%CONSTINTEGER Not Set = 0
%CONSTINTEGER Off = 0, On = 1
!Values taken by 'boolean' variables
! (ie. Integers used as flags)
%CONSTINTEGER A Minus= 0 ; !values used internally
%CONSTINTEGER A Plus = 1 ; ! to indicate a positive or negative value is reqd
!Error Messages:
!
!
%CONSTINTEGER Invalid Integer = 140
%CONSTINTEGER Invalid Real = 141
%CONSTINTEGER Invalid Character = 148
{CONSTINTEGER Null Field = 133}
%IF MODE= Compile Time %THENSTART
%CONSTINTEGER Constant Out Of Range= 20
%FINISHELSESTART; %CONSTINTEGER Constant Out Of Range= 188
%FINISH
%IF HOST=EMAS %OR HOST= IBM %OR HOST= GOULD %THENSTART
%UNLESS TARGET= IBM %THENSTART
!
! Double Precision Floating-Point Constants
!
%CONSTLONGREAL Largest Real= R'7FFFFFFFFFFFFFFF'
%FINISHELSESTART
!
! 'EXCESS 64' Notation Real Constants (for Amdahl)
!
!%CONSTLONGLONGREAL Largest Real= R'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' {!!!}
%FINISH
%FINISHELSESTART
%IF HOST=PNX %OR HOST=PERQ3 %OR HOST=Whitechapel %THENSTART
!
! PNX/PERQ3/WHITECHAPEL Floating Point Constants
!
%CONSTLONGREAL Largest Real= R'7FEFFFFFFFFFFFFF'
%FINISHELSESTART
!
! PERQ (POS) Floating-Point Constants
!
%CONSTINTEGERARRAY PERQ LARGEST REAL (0:1)= X'FFFFFFFF',
X'7FEFFFFF'
%OWNLONGREALNAME LARGEST REAL ;!%C
LARGEST REAL is mapped onto PERQ LARGEST REAL
!
!
%FINISH; !if PERQ
%FINISH; !defining LARGEST REAL
%CONSTINTEGERARRAY Integer Power Of Ten (0:9)= %C
%C
1,
10, {by using this table }
100, {we overcome any problem}
1000, {we may have if integer }
10000, {exponentiation has not }
100000, {yet been implemented }
1000000,
10000000,
100000000,
1000000000
!
!*************************************************************************
!
! SPECIFICATIONS FOR EXTERNAL PROCEDURES
!
!*************************************************************************
!
%EXTERNALLONGLONGREALFNSPEC POWER OF TEN %ALIAS "S#POWEROFTEN" (%INTEGER POWER)
!
!************************************************************************
!
! SPECIFICATIONS FOR LOCAL PROCEDURES
!
!************************************************************************
!
%INTEGERFNSPEC TO INTEGER (%INTEGER DATA AD, DATA LEN , INT LEN , INT PTR)
%INTEGERFNSPEC TO REAL (%INTEGER DATA AD, DATA LEN , INT LEN , INT PTR)
%INTEGERFNSPEC COMPARE (%INTEGER LENGTH, THIS BASE, THIS DISP,
%INTEGER THAT BASE, THAT DISP)
!
! Local Variables
!
%INTEGER D PTR ; !ptr to decimal digits in local buffer
%INTEGER E PTR ; !ptr to exponent digits in local buffer
%INTEGER E LEN ; !number of digits in the exponent
%INTEGER E SIGN; !set zero of no exponent sign
!set -ve if exponent sign='-'
!set +ve if exponent sign='+'
%INTEGER SIGN; !set zero if no numeric sign
!set -ve if numeric sign='-'
!set +ve if numeric sign='+'
%INTEGER B FLAG; ! if zero then leading spaces are to be ignored
%INTEGER C ; !the current character being analysed
%INTEGER I ; !the scanning ptr through the local buffer
%INTEGER LENGTH; !the number of digits specified
%INTEGER FAULT
!
%INTEGER S1 PTR, S2 PTR, S PTR ;!%C
S1 PTR, S2 PTR are ptrs into the I/O buffer to positions %C
where significant digits for the numeric %C
and exponent parts respectively are expected
{and S PTR points to the exponent character in the I/O buffer}
%INTEGER PTR, PTR MAX ;!%C
PTR, PTR MAX point to the start and end of the text %C
in the I/O buffer respectively
%INTEGER INT PTR, INT LEN ;!%C
INT PTR, INT LEN describe the location and length of the %C
analysed text which has been placed in TEXT
!
! Exponent Related Variables
!
%INTEGER EXP ; !the exponent converted into binary
%INTEGER MULT ; ! a multiplier used while converting the exponent
%INTEGER J ; !--a utility variable
!
! Initialise Variables
!
D PTR = Not Set ; !=> no decimal point found
E PTR = Not Set ; !=> no exponent found
E SIGN= Not Set ; !=> no exponent sign found
SIGN= Not Set ; !=> no numeric sign found
B FLAG= Not Set ; !=> leading spaces are not significant
I = Not Set ; !=> no significant digits found
!
PTR = TEXT PTR
PTR MAX = TEXT END
!
!S1 PTR = PTR; !used to determine a null numeric
!S2 PTR = PTR; ! or null exponent part
!
!
! ANALYSE THE NUMBER
!
!
%WHILE PTR<PTR MAX %CYCLE
!
{pick up} C= IO BUFFER(PTR)
{the next} PTR= PTR+1
{character} -> HANDLE(TYPE(C)) {and go and process it}
HANDLE (Syntax Fault): ! Handle an ILLEGAL Character !
! !
! !
INVALID CHAR : FAULT= Invalid Character; -> REPORT
INVALID REAL : FAULT= Invalid Real ; -> REPORT
INVALID INTEGER: FAULT= Invalid Integer
REPORT : TEXT PTR= PTR
%RESULT = FAULT
! NULL FIELD1 : TEXT PTR= S1 PTR
! %RESULT = Null Field
! NULL FIELD2 : TEXT PTR= S2 PTR
! %RESULT = Null Field
HANDLE (A Blank): ! Handle a SPACE Character !
! !
! !
%CONTINUE %IF B FLAG= 0 %OR BLANKS\=Zero {ignore insignificant blanks}
!
{otherwise} C ='0' {and fall through}
HANDLE (A Digit): ! Handle a DIGIT !
! !
! !
I=I+1; TEXT(I)= C {save the digit}
B FLAG = ON
%CONTINUE
HANDLE (A Sign): ! Handle a SIGN (it may signify an exponent) !
! !
! !
%IF E PTR=Not Set %THENSTART
%IF SIGN\=Not Set {ie we have already had a sign} %OR %C
I\=Not Set {ie we have at least one digit} %THEN %C
E SIGN= C %AND -> AN EXPONENT
{otherwise} SIGN= C {%AND S1 PTR= PTR}
%FINISHELSESTART
{IF E PTR \=Not Set %THENSTART}
%IF E PTR \= I+1 {ie sign is embedded in an exponent} %ORC
E SIGN\=Not Set {ie we have an exponent sign already} %C
%THEN -> INVALID REAL
E SIGN = C
{S2 PTR = PTR}
%FINISH
%CONTINUE
HANDLE (A Decimal Point): ! Handle a DECIMAL part !
! !
! !
-> INVALID INTEGER %IF FORMAT='I'
-> INVALID REAL %IF D PTR\= 0 %C
%OR E PTR\= 0
B FLAG= ON {save any embedded blank}
D PTR = I+1 {note the decimal point}
%CONTINUE
HANDLE (A Lower Case Exp{onent}): ! Handle a Lower Case Exponent !
! !
! !
C=C-' '
{convert to upper case}
HANDLE (An Exponent): ! Handle an EXPONENT !
AN EXPONENT : ! !
! !
-> INVALID CHAR %IF C='Q' %AND RELAX ANSI= False
-> INVALID INTEGER %IF FORMAT='I'
-> INVALID REAL %IF E PTR\= Not Set
E PTR = I+1
B FLAG= Off
{S2 PTR= PTR %AND} S PTR= PTR
%CONTINUE
HANDLE (A Comma): ! Handle Premature End ! HANDLE (A Carriage Return):
! of Input Field !
! !
%IF CR Delimiter=False %AND C=CR %THEN -> INVALID CHAR
%EXIT
%REPEAT; !for the next character
LENGTH= I; TEXT PTR= PTR MAX - PTR
!
! ANALYSE THE ANALYSIS
!
%IF E PTR\=Not Set %THENSTART
!
! Analyse the given Exponent
!
%IF E PTR>LENGTH %THENSTART
! -> NULL FIELD2 %IF BLANKS\=Zero %C
%OR S2 PTR = PTR
%FINISH
E LEN=LENGTH - (E PTR-1)
LENGTH= E PTR - 1
PTR= S PTR - 1
!
! Convert the given Exponent into Binary
!
%IF E LEN> 9 %THENSTART
!
!Use the Integer Conversion Routine for Large Exponents
!
J=TO INTEGER(ADDR(EXP),4,E LEN,E PTR)
%FINISHELSESTART
!
EXP = 0
%IF E LEN > 0 %THENSTART
!
MULT= Integer Power Of Ten (E LEN - 1)
%WHILE MULT> 0 %CYCLE
EXP = EXP + (MULT * ( TEXT(E PTR) - '0'))
E PTR = E PTR+ 1
MULT= MULT//10
%REPEAT
%FINISH; %FINISH
!
%IF EXP>32767 %THEN EXP= 32767
%IF E SIGN='-' %THEN EXP= -EXP
!
SCALE FACTOR= -EXP
%FINISH
!Handling an Exponent
!
! Analyse the (rest of the) Number
!
! %IF LENGTH=Null %THENSTART
! !
! -> NULL FIELD1 %IF S1 PTR = PTR - D PTR %OR %C
! (S1 PTR\=S2 PTR - D PTR %AND BLANKS\=Zero)
! %FINISH
%IF D PTR\=Null %THEN DECS=LENGTH - (D PTR-1)
!
! Prepare to Call a Numeric Conversion Routine
!
%IF SIGN\= Not Set %THENSTART
!
{set parameters} TEXT(0)= SIGN ; INT PTR= 0
{for a call on } INT LEN= LENGTH+1
{ TO REAL } %FINISHELSESTART; INT LEN= LENGTH
{ or on } INT PTR= 1
{ TO INTEGER} %FINISH
!
!
! NOW CONVERT TEXT INTO BINARY
!
!
%IF FORMAT= 'I' %THEN FAULT= TO INTEGER (DATA AD, DATA LEN, INT LEN, INT PTR) %C
%ELSE FAULT= TO REAL (DATA AD, DATA LEN, INT LEN, INT PTR)
%IF FAULT\= 0 %THEN TEXT PTR= PTR MAX
!
%RESULT= FAULT
%INTEGERFN TO INTEGER (%INTEGER DATA AD , DATA LEN , TEXT LEN , TEXT INC)
!
!
!
!
! THIS IS A PROCEDURE TO CONVERT A STRING OF CHARACTERS (which
!
! have been analysed syntactically) INTO AN INTEGER VALUE.
!
!
!The character string is assumed to be in the area TEXT, and is
!defined by the parameters TEXT LEN and TEXT INC which identify the
!length and start (relative to TEXT) of the string respectively. At
!exit the result is stored in the location defined by the parameters
!DATA AD and DATA LEN which identify the address and the length (in
!bytes) of the result location.
!
!
!NOTE1: It is assumed that there are no leading, embedded or trailing blanks
!NOTE2: The string of digits is assumed to represent a valid integer
!
!
! At Exit: RESULT= 0 if the constant was within range
! RESULT= 20 if the constant was out of range and MODE= Compile Time
! RESULT=188 if the constant was out of range and MODE= Run Time1
!
!
!
%IF TARGET= Gould %THENSTART
!
!
%CONSTINTEGERARRAY Maximum Of (0:2)= 0, -32768, X'80000000'
!
!the values above represent the largest
! values that may be assigned to a
! INTEGER*1 or INTEGER*2 or INTEGER*4 respectively
%FINISHELSESTART
!
!
%CONSTINTEGERARRAY Maximum Of (0:2)= -128, -32768, X'80000000'
!
!the values above represent the largest
! values that may be assigned to a
! BYTE or INTEGER*2 or INTEGER*4 respectively
%FINISH
!Text of the Largest Negative Integer:
!
%CONSTBYTEINTEGERARRAY Largest Integer(0:9)= {-}'2','1','4','7','4',
'8','3','6','4','8'
!
! Variables used to Address the Digits
!
%INTEGER PTR {scanning ptr through TEXT }
%INTEGER MAX PTR { maximum value PTR may have}
%INTEGER LEN ;!%C
LEN is the actual number %C
of significant digits in the TEXT
!
! Variables used to Convert the Digits to Binary
!
%INTEGER SIGN ; !set +ve if value is positive, else set to zero
%INTEGER MULT ; !scaling to be applied to the next digit
%INTEGER SUM ; !the binary result
%INTEGER I
{a utility variable}
!
! Initialise Variables
!
PTR= TEXT INC ; !initialise the scanning ptr
MAX PTR= TEXT LEN + PTR; !initialise its maximum value
!
! Check for a Sign
!
SIGN= TEXT (PTR)
%IF SIGN< '0' %THENSTART
%IF SIGN='+' %THEN SIGN=A Plus %C
%ELSE SIGN=A Minus
PTR=PTR+1
%FINISH %ELSE SIGN=A Plus
!
! Check Magnitude of the Value
!
LEN= MAX PTR - PTR
%IF LEN> 9 %THENSTART {chance of Integer Overflow later}
!
! Skip any Leading Spaces or Zeros
!
A: I=TEXT(PTR)
%IF I='0' %THEN PTR= PTR + 1 %AND -> A
LEN= MAX PTR - PTR
-> INTEGER OVERFLOW %IF LEN> 10
-> SIMPLE APPROACH %IF LEN< 10
!
! Now Test for Integer Overflow (when there are 10 digits)
!
I=COMPARE(10,ADDR(TEXT(0)),PTR,ADDR(Largest Integer(0)),0)
-> INTEGER OVERFLOW %C
%IF I+SIGN> 0
%FINISH
SIMPLE APPROACH: SUM=0; %IF LEN>0 %THENSTART
!
! Now Convert the Text into Binary
!
MULT=-Integer Power Of Ten (LEN-1)
%WHILE MULT< 0 %CYCLE
!
SUM = SUM + (MULT * (TEXT(PTR) - '0'))
PTR = PTR + 1
MULT= MULT//10
%REPEAT
SUM = -SUM %UNLESS SIGN=A Minus
%FINISH
%IF DATA LEN= 4 {bytes} %THENSTART
!
!
! Assign the Value to an INTEGER*4
!
!
INTEGER(DATA AD)= SUM
%FINISHELSESTART
%IF DATA LEN= 2 {bytes} %THENSTART
!
!
! Assign the Value to an INTEGER*2
!
!
%IF SIGN=A Minus %THENSTART
%IF SUM<-32768 %THEN -> INTEGER OVERFLOW
%FINISH %ELSE %IF SUM> 32767 %THEN -> INTEGER OVERFLOW
!
!
{Perform the Assignment} HALFINTEGER(DATA AD)= SUM %IF HALFs= True
SHORTINTEGER(DATA AD)= SUM %IF HALFs= False
%FINISHELSESTART
!
!
! Assign the Value to a BYTE or (INTEGER*1 if Gould)
!
!
%IF SIGN=A Minus %THENSTART
%IF TARGET = Gould %AND SUM< 0 %THEN -> INTEGER OVERFLOW
%IF TARGET\= Gould %AND SUM<-128 %THEN -> INTEGER OVERFLOW
%FINISHELSESTART
%IF TARGET = Gould %AND SUM> 255 %THEN -> INTEGER OVERFLOW
%IF TARGET\= Gould %AND SUM> 127 %THEN -> INTEGER OVERFLOW
%FINISH
!
!
{Perform the Assignment} INTEGER(DATA AD)= SUM
! Note that the calling routine is
%FINISH; ! expected to perform the actual
%FINISH; ! assignment
%RESULT= 0 {return with no errors}
INTEGER OVERFLOW: !check if this is a fault
!
%IF MODE\= Run Time2 %THENRESULT= Constant Out Of Range
!
! Set Data Item to Maximum Permitted Value
!
SUM= Maximum Of (DATA LEN >> 1)
SUM=-(SUM+1) %IF SIGN=A Plus
SUM= SUM & X'FF' %IF TARGET= Gould
!
%IF DATA LEN= 2 %THENSTART
%IF Halfs= False %THEN SHORTINTEGER(DATA AD)= SUM %C
%ELSE HALFINTEGER(DATA AD)= SUM
%FINISHELSE INTEGER(DATA AD)= SUM
%RESULT= 0
%END; !of TO INTEGER
%INTEGERFN TO REAL (%INTEGER DATA AD, DATA LEN, INT LEN, INT PTR)
!
!
!
!
! THIS PROCEDURE CONVERTS A STRING OF CHARACTERS (which have been
!
! analysed syntactically) INTO A FLOATING POINT NUMBER.
!
!
!The character string is assumed to be in an area TEXT and is defined
!by the parameters INT LEN, INT PTR, which identify the length and
!start (relative to TEXT) of the characters. The global integer DECS
!defines the implied positioning of the decimal point: while the global
!variable SCALE FACTOR defines the exponentiation to be applied to the
!result. The result is saved in the location defined by DATA AD and
!DATA LEN which specify its address and length (in bytes) respectively.
!
!
!NOTE1: There are no embedded or trailing blanks
!NOTE2: It is assumed that there are no leading spaces
!NOTE3: The character string is assumed to represent a
! valid floating point number
!
!
! At Exit: RESULT= 0 if the constant was within range
! RESULT= 20 if the constant was out of range and MODE= Compile Time
! RESULT=188 if the constant was out of range and MODE= Run Time1
!
!
!
!NOTE if running in compiler mode then TO REAL returns -1
! as a result if more digits are specified than can
! be represented in the requested precision
!
%IF MODE= Compile Time %THENSTART
!
%INTEGER RESULT
!CONSTINTEGER No Comment= 0 ,
Lost Significance= -1
%FINISH
%IF IEEE= False %THENSTART; !-------------Define Excess-64 type Real Constants
%IF TARGET=EMAS %OR TARGET= IBM %THENSTART
!
!
! Declare IBM type specific Floating Point Constants
!
!
!%CONSTLONGLONGREAL Maximum Single = R'7FFFFFFF000000000000000000000000' {!!!}
!%CONSTLONGLONGREAL Maximum Double = R'7FFFFFFFFFFFFFFF0000000000000000' {!!!}
%IF TARGET= EMAS %THENSTART
!
!%OWNLONGLONGREAL Real4 Rounding= R'00000000800000000000000000000000' {!!!}
!%OWNLONGLONGREAL Real8 Rounding= R'00000000000000000080000000000000' {!!!}
!
!Note that on IBM style architectures, assignments to
! a shorter precision is rounded up, but not on 2900
! style architectures.
%FINISH
%FINISHELSESTART
!
! Declare Gould specific Floating Point Constants
!
%CONSTLONGREAL Maximum Single= R'7FFFFFFF00000000'
%CONSTLONGREAL Maximum Double= R'7FFFFFFFFFFFFFFF'
%FINISH
%CONSTINTEGER Max Power= 75
%CONSTINTEGER Min Power= -78
%OWNSTRING(40) LARGEST POSSIBLE= "7237005577332262213973186563043052414499"
!LARGEST POSSIBLE is a representation, in characters, of
! the 40 most significant digits of the largest possible
! real in 'Excess 64' notation.
%FINISHELSESTART; !-------------Define IEEE type Real Constants
!
!
! Declare IEEE specific Floating Point Constants
!
!
%CONSTLONGREAL Maximum Single= 3.40282356@+38
%CONSTLONGREAL Minimum Single= 1.17549440@-38
%CONSTINTEGER Min Power = -306
%CONSTINTEGER Max Power = 308
%OWNSTRING(16) LARGEST POSSIBLE= "1797693134862315"
!LARGEST POSSIBLE is a representation, in characters, of
! the 16 most significant digits of the largest possible
! real defined in the IEEE Standard
%FINISH
!
! Variables used to Address the Digits
!
%INTEGER PTR {scanning ptr through TEXT }
%INTEGER MAX PTR { maximum value PTR may have}
%INTEGER LEN ;!%C
LEN is the actual number %C
of significant digits in the TEXT
!
! Variables associated with the Scale of the Number
!
%INTEGER MAX DIGITS; !maximum significant digits associated with the required precision
%INTEGER VAL SIZE ; !scale of the leftmost significant digit
%INTEGER EXP ; !scale of the rightmost significant digit
%INTEGER SIGN ; ! sign of the value, either=A MINUS,
or=A PLUS
!
! Variables used in Numeric Conversion
!
%INTEGER MULT ; !scaling to be applied to the next digit
%INTEGER SUM ; ! binary integer value of the digits bar scaling
%LONGLONGREAL X ; ! actual Real result
%REAL Y
EXP=-(SCALE FACTOR+DECS)
!
!Initialise the exponentiation to be applied
!
!
! Examine the Number
!
!
SIGN=A Plus {guess}
!
%IF INT LEN>0 %THENSTART
!
! Look for a Numeric Sign
!
SIGN= TEXT(INT PTR)
%IF SIGN<'0' %THENSTART
%IF SIGN='-' %THEN SIGN=A Minus
INT LEN=INT LEN-1
INT PTR=INT PTR+1
!
%FINISH
%FINISH
PTR= 1; MAX PTR= INT LEN
!
! Ignore Leading and Trailing Zeros
!
PTR= PTR+1 %WHILE MAX PTR>=PTR %AND TEXT(PTR)='0'
!ignore any leading zeros
MAX PTR=MAX PTR-1 %AND %C
EXP= EXP+1 %WHILE MAX PTR>=PTR %AND TEXT(MAX PTR)='0'
!ignore any trailing zeros
!
! Determine the Magnitude of the Value
!
LEN=MAX PTR - (PTR-1) %AND MAX DIGITS= DATA LEN << 1
%IF LEN>MAX DIGITS %THENSTART {= 8 or 16 or 32}
!
! Ignore any digits which have no bearing on the result
!
EXP= EXP + (LEN-MAX DIGITS)
LEN= MAX DIGITS
RESULT= Lost Significance %IF MODE= Compile Time
!
%FINISHELSE %IF MODE= Compile Time %THEN RESULT= No Comment
VAL SIZE=EXP + (LEN-1); !NOTE: LEN=number of significant digits
! ! EXP= scale of rightmost digit
! ! VAL SIZE= scale of leftmost digit
%IF VAL SIZE> Max Power %OR %C
EXP < Min Power %THEN -> FURTHER EXAMINATION
!Jump if
! the value is around or beyond
! the capabilities of the code below
FORM RESULT: X=0.0
!
! Test for a Zero
!
%IF LEN<= 0 %THENSTART
!
-> ASSIGN A REAL4 %IF DATA LEN= 4
-> ASSIGN A REAL8 %IF DATA LEN= 8 %OR TARGET\= IBM
-> ASSIGN A REAL16 %IF TARGET= IBM
%FINISH
!
!
! Perform the Conversion
!
!
%IF LEN> 9 %THENSTART
%CYCLE; MULT= 100000000 {10 ** ** 8}
SUM= 0
%CYCLE; SUM = SUM + (MULT * (TEXT(PTR) - '0'))
PTR = PTR + 1
MULT= MULT// 10
%REPEAT %UNTIL MULT<= 0
LEN= LEN - 9
X= X + (SUM * POWER OF TEN(EXP+LEN))
%REPEAT %UNTIL LEN< 10
%FINISH
!
!The loop above is used when more than 9 digits are to be converted
! into a floating point number. Each set of nine digits (from
! left to right) are converted into an integer, then scaled as
! appropriate, and then added to the result of the previous
! loop (if any). Note if 10 or more digits were processed as a
! time then overflow would/could occur.
!The code below operates similarly as above but uses the final
!N digits (N<=9), and incorporates the result into the running
!total if any:
MULT= Integer Power Of Ten (LEN-1)
SUM= 0
%CYCLE; SUM= SUM + (MULT * (TEXT(PTR) - '0'))
PTR= PTR + 1
MULT=MULT//10
%REPEAT %UNTIL MULT<= 0
X= X + (SUM * POWER OF TEN(EXP))
RETURN RESULT:
!
!
! Assign the Value to the I/O Item
!
!
%IF DATA LEN= 4 %THENSTART
!
! Return a Single Precision Real
!
%IF X>= Maximum Single %THENSTART
%IF TARGET\=IBM %AND X> Maximum Single %AND MODE\=Run Time2 %THEN -> CHECK MODE
X= Maximum Single;%FINISHELSESTART
%IF TARGET\=IBM %ANDC
TARGET\=GOULD %AND X<=Minimum Single %THENSTART
%IF X< Minimum Single %AND MODE\=Run Time2 %THEN -> CHECK MODE
X= Minimum Single;%FINISH
%IF TARGET=EMAS %THEN BYTEINTEGER(ADDR(Real4 Rounding))=BYTEINTEGER(ADDR(X)) %C
%AND X= X + Real4 Rounding
%FINISH
ASSIGN A REAL4: Y= X
!
Y =-Y %IF SIGN=A Minus
REAL(DATA AD)= Y
-> RETURN
%FINISH
%IF TARGET= IBM %AND DATA LEN= 16 %THENSTART
!
! Return an Extended Precision Real
!
ASSIGN A REAL16: X =-X %IF SIGN=A Minus
LONGLONGREAL(DATA AD)= X
-> RETURN
%FINISH
!
! Return a Double Precision Real
!
%IF TARGET = IBM %OR TARGET= EMAS %THENSTART
!
%IF X>= Maximum Double %THEN X= Maximum Double %ELSESTART
%IF TARGET=EMAS %THEN BYTEINTEGER(ADDR(Real8 Rounding))= BYTEINTEGER(ADDR(X)) %C
%AND X=X + Real8 Rounding
%FINISH
%FINISH
ASSIGN A REAL8: X =-X %IF SIGN=A Minus
LONGREAL(DATA AD)= X
RETURN: %RESULT= RESULT %IF MODE= Compile Time
%RESULT= 0
!= 0 if run time
FURTHER EXAMINATION: !required for very large or for very small
! values before conversion can be
! attempted
!
%IF VAL SIZE< Min Power %THEN -> VALUE TOO SMALL
%IF VAL SIZE>= Max Power %THENSTART
%IF VAL SIZE = Max Power %THENSTART
!
! Compare Digits with the Largest Possible Real
!
-> VALUE TOO LARGE %C
%IF COMPARE (LEN,ADDR(TEXT(0)), PTR,
ADDR(LARGEST POSSIBLE),1)>0
%FINISHELSE %C
{!} %C
%IF LEN=0 %THEN -> VALUE TOO SMALL %C
%ELSE -> VALUE TOO LARGE
%FINISH
%IF EXP< Min Power %THENSTART
!
! Ignore digit which will have no effect on the Result
!
LEN = LEN + (EXP-Min Power)
EXP = Min Power
%FINISH
-> FORM RESULT
!
! HANDLE NUMBERS OUT OF THE PERMITTED RANGE
!
VALUE TOO SMALL: X= 0.0 ; -> CHECK MODE
VALUE TOO LARGE: X=LARGEST REAL;
!
CHECK MODE : %IF MODE\= Run Time2 %THENRESULT= Constant Out Of Range
!\=> it is a fault
-> RETURN RESULT
!
!
!
%END; !of TO REAL
!
!***********************************************************************
!
! UTILITY PROCEDURES
!
!***********************************************************************
!
%INTEGERFN COMPARE (%INTEGER LENGTH, THIS BASE, THIS DISP,
THAT BASE, 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)
! RESULT= 1 if Text(THIS BASE)>Text(THAT BASE)
!
!
!
%IF TARGET= PERQ %OR TARGET= Whitechapel %THENSTART
%BYTEINTEGERARRAYFORMAT Byte Format (0:30000)
%BYTEINTEGERARRAYNAME THIS
%BYTEINTEGERARRAYNAME THAT
THAT== ARRAY (THAT BASE, Byte Format)
THIS== ARRAY (THIS BASE, Byte Format)
%WHILE LENGTH>0 %CYCLE
!
%RESULT= 1 {greater than} %IF THIS(THIS DISP)> THAT(THAT DISP)
%RESULT=-1 { less than} %IF THIS(THIS DISP)< THAT(THAT DISP)
THIS DISP= THIS DISP + 1
THAT DISP= THAT DISP + 1
LENGTH= LENGTH - 1
%REPEAT
%RESULT= 0 {equal if we fall through the cycle}
%FINISHELSESTART
!
%IF TARGET= PNX %THENSTART
!
THIS BASE= THIS BASE + THIS BASE + THIS DISP
THAT BASE= THAT BASE + THAT BASE + THAT DISP
%FINISHELSESTART
!
THAT BASE= THAT BASE +THAT DISP
THIS BASE= THIS BASE +THIS DISP
%FINISH
%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)<BYTEINTEGER(THAT BASE)
!
THIS BASE = THIS BASE + 1
THAT BASE = THAT BASE + 1
LENGTH = LENGTH - 1
%REPEAT
! !
%RESULT= 0 { equal to }
%FINISH
!
%END; !of COMPARE
%END; !of IN NUMBER
%ENDOFFILE
! fcinnum1
! 10/10/86 - copy of ftncinnum7