Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0001/calbin.for
There is 1 other file named calbin.for in the archive. Click here to see a list.
C
C
C
C COPYRIGHT (c) 1977 BY
C DIGITAL EQUIPMENT CORPORTATION, MAYNARD, MASS.
C
C THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
C ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
C INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
C COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
C OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
C TRANSFERRED.
C
C THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
C AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
C CORPORATION.
C
C DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
C SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
C
C
C
C
C
C
C
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++
C + +
C + CALC VERSION X01-01 +
C + +
C + PETER BAUM 1-SEP-77 +
C + DIGITAL EQUIPMENT CORPORATION +
C + 146 MAIN STREET +
C + MAYNARD, MASSACHUSETTS 01754 +
C + +
C ++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C
C
C
C *******************************************************
C * *
C * SUBROUTINE CALBIN *
C * *
C *******************************************************
C
C SUBROUTINE CALBIN PERFORMS A BINARY OPERATION ON TWO CONSTANTS.
C
C
C
C UPON ENTRANCE TO ROUTINE:
C OPERAND1 IS IN STACK1 (ST1PT-1)
C OPERAND2 IS ON TOP OF STACK2 (ST2PT-1)
C OPERATOR IS BELOW OPERAND2 (ST2PT-2)
C UPON EXIT:
C RESULT IS IN STACK1
C STACK2 HAS BEEN CLEANED UP
C
C RETURN CODE MEANING
C 1 NORMAL RETURN
C 2 OPERATION COMPLETE (RESULT HAS BEEN OUTPUT)
C 3 ERROR RETURN
C
C
C
C MODIFICATION CLASSES: M3, M4, AND M8
C
C
C
C CALBIN CALLS
C
C CONTYP CONVERTS CONSTANTS TO DIFFERENT DATA TYPES
C ERRMSG PRINTS OUT ERROR MESSAGES
C MULADD PERFORMS MULTIPLE PRECISION ADDITION
C MULDIV PERFORMS MULTIPLE PRECISION DIVISION
C MULMUL PERFORMS MULTIPLE PRECISION MULTIPLICATION
C
C
C
C CALBIN IS CALLED BY POSTVL WHICH EVALUATES A POSTFIX EXPRESSION
C
C
C
C
C VARIABLE USE
C
C EIGHT(8) PICKS OUT A REAL CONSTANT FROM STACK.
C FOUR(4) PICKS OUT AN INTEGER CONSTANT FROM STACK.
C I,J HOLD TEMPORARY VALUES.
C IA FIRST BYTE OF OPERAND 1. THIS HOLDS THE INDEX INTO
C VBLS OF A VARIABLE IF THE OPERATOR IS AN = SIGN.
C ID USED TO CONVERT DECISION TABLE LOGICAL*1 VALUE TO
C AN INTEGER*2 VALUE THAT CAN BE USED AS AN ARGUMENT
C IN A CALL TO CONTYP.
C INT,IHOLD HOLD INTEGER*4 VALUES.
C IOP HOLDS THE BINARY OPERATOR.
C IOP2 USED TO INDEX A COMPUTED GO.
C ISW HOLDS BASE FOR MULTIPLE PRECISION EXPONENTIATION
C MINUS VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
C NUMBER THAT IS USED TO INDICATE A NEGATIVE.
C OP1TYP TYPE OF OPERAND 1.
C OP2TYP TYPE OF OPERAND 2.
C PLUS VALUE IN THE 100TH BYTE OF A MULTIPLE PRECISION
C NUMBER THAT IS USED TO INDICATE POSITIVE.
C PT1,PT2 POINT TO ELEMENTS ON TOP OF STACKS 1 AND 2.
C REAL,RHOLD HOLD TEMPORARY REAL*8 VALUES.
C RETCD ERROR RETURN: 1 = O.K. 2 = RESULT WAS OUTPUT
C 3 = ERROR
C
C
C
C
C
C
C
C
C
SUBROUTINE CALBIN(RETCD)
REAL*8 REAL,RHOLD,DFLOAT
C
INTEGER*4 INT,IHOLD
C
INTEGER*2 LEVEL,NONBLK,LEND
INTEGER*2 VLEN(9)
INTEGER*2 IOP,IA,ID,IOP2,ISW
INTEGER*2 PLUS,MINUS
INTEGER*2 OLDTYP,VIEWSW,TYPE(27),BASED
INTEGER*2 RETCD,RETCD2
INTEGER*2 OP1TYP,OP2TYP
INTEGER*2 ST1PT,ST2PT,ST1TYP(40),ST2TYP(40),ST1LIM,ST2LIM
INTEGER*2 PT1,PT2
C
LOGICAL*1 STACK1(100,40),STACK2(100,40)
LOGICAL*1 VBLS(100,27), DTBL1(9,9,8)
LOGICAL*1 EIGHT(8),FOUR(4)
LOGICAL*1 LINE(80)
C
EQUIVALENCE (EIGHT,REAL), (FOUR,INT)
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON/V/ TYPE,VBLS,VLEN
COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
; ST1LIM,ST2LIM
COMMON /DECIDE/DTBL1
C
C
DATA PLUS/0/,MINUS/1/
C
C
C
C
C
RETCD=1
PT1=ST1PT-1
PT2=ST2PT-1
C
C
IOP=ST2TYP(ST2PT-2)
OP1TYP=ST1TYP(PT1)
OP2TYP=ST2TYP(PT2)
IA=STACK1(1,PT1)
IF (IOP.NE.200) GOTO 100
C
C
C
C AN = SIGN IS THE OPERATOR. THIS IS A SPECIAL CASE.
IF(OP1TYP.GE.0) GO TO 5
C
C
C
C VARIABLE TO THE LEFT OF = SIGN HAS A DATA TYPE BUT NO VALUE
OP1TYP=-OP1TYP
ST1TYP(PT1)=OP1TYP
C
C
C
C OPERAND 2 COPIED INTO OLD OPERAND'S POSITION IN CASE MORE
C THAN 1 = SIGN IS PRESENT FOR EXPRESSIONS LIKE I=J=2
5 J=VLEN(OP2TYP)
TYPE(IA)=OP1TYP
DO 10 I=1,J
10 STACK1(I,PT1)=STACK2(I,PT2)
CALL CONTYP (STACK1,PT1,OP2TYP,OP1TYP,RETCD2)
GOTO (20,9999), RETCD2
STOP 20
C
C
C THE SPECIFIED VARIABLE GETS NEW VALUE.
20 J=VLEN(OP1TYP)
DO 30 I=1,J
VBLS(I,IA)=STACK1(I,PT1)
30 CONTINUE
GOTO 10000
C
C
C IOP2 VALUES 1="**" 2="*" 3="/" 4="+" 5="-"
100 IOP2=IOP-111
GOTO (1000,2000,2000,2000,2000),IOP2
C
C
C ********************************************
C *********** EXPONENTIATION ***************
C ********************************************
C
C
C FIRST CONVERT TO PROPER TYPE
1000 ID=DTBL1(OP2TYP,OP1TYP,5)
CALL CONTYP(STACK1,PT1,OP1TYP,ID,RETCD2)
IF (RETCD2.EQ.2) GOTO 9999
ID=DTBL1(OP2TYP,OP1TYP,6)
CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
IF (RETCD2.EQ.2) GOTO 9999
C
C
C GOTO APPROPRIATE PLACE TO PERFORM OPERATION
ID=DTBL1(OP2TYP,OP1TYP,8)
GOTO (1100,1200,1300,1400,1500,1600,1700),ID
STOP 1000
C
C
C REAL**REAL
1100 DO 1104 I=1,8
1104 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 1108 I=1,8
1108 EIGHT(I)=STACK2(I,PT2)
REAL=RHOLD**REAL
C
C
C USED BY REAL**I
1109 DO 1110 I=1,8
1110 STACK1(I,PT1)=EIGHT(I)
C
C
C USED BY I**REAL,I**I
1114 ST1TYP(PT1)=DTBL1(OP2TYP,OP1TYP,7)
GOTO 10000
C
C
C
C REAL**I
1200 DO 1204 I=1,8
1204 EIGHT(I)=STACK1(I,PT1)
DO 1208 I=1,4
1208 FOUR(I)=STACK2(I,PT2)
REAL=REAL**INT
GOTO 1109
C
C
C
C I**REAL (PARTS USED BY I**I)
1300 DO 1304 I=1,4
1304 FOUR(I)=STACK1(I,PT1)
DO 1308 I=1,8
1308 EIGHT(I)=STACK2(I,PT2)
C
C DIFFERENT VERSIONS OF FORTRAN TREAT THE RESULT IN DIFFERENT WAYS.
C IF YOU WANT THE RESULT TO BE REAL, YOU MUST ALSO CHANGE DTBL1.
C
INT=DFLOAT(INT)**REAL
1310 DO 1314 I=1,4
1314 STACK1(I,PT1)=FOUR(I)
GOTO 1114
C
C
C
C I**I
1400 DO 1404 I=1,4
1404 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 1408 I=1,4
1408 FOUR(I)=STACK2(I,PT2)
INT=IHOLD**INT
GOTO 1310
C
C
C
C M8**I (PARTS USED BY M10**I, M16**I)
1500 ISW=8
1501 IF(ST2PT.LE.ST2LIM)GO TO 1502
C
C
C STACK OVERFLOW
CALL ERRMSG(9)
GO TO 9999
C
C
C GET EXPONENT AS AN INTEGER
1502 DO 1504 I=1,4
1504 FOUR(I)=STACK2(I,PT2)
IF (INT.GE.0) GOTO 1520
C
C
C EXPONENT NOT POSITIVE OR 0
CALL ERRMSG (15)
GOTO 9999
1520 IF (INT.GT.0) GOTO 1530
C
C
C I**0 = 1
STACK1(100,PT1)=PLUS
DO 1522 I=2,99
1522 STACK1(I,PT1)=0
STACK1(1,PT1)=1
GOTO 10000
C
C
C EXPONENT IS > 0
1530 INT=INT-1
C
C
C IF EXPONENT = 1 WE ARE DONE
IF(INT.EQ.0)GO TO 10000
C
C
C EXPONENT IS > 1. COPY TO STACK 2 WHERE MULMUL EXPECTS THE OTHER
C FACTOR.
DO 1534 I=1,100
1534 STACK2(I,ST2PT)=STACK1(I,PT1)
ST2TYP(ST2PT)=ST1TYP(PT1)
C
C
C
C
1549 DO 1550 I=1,INT
CALL MULMUL(PT1,ST2PT,RETCD2,ISW)
IF(RETCD2.GE.2)GO TO 9999
1550 CONTINUE
GOTO 10000
C
C M10**I
1600 ISW=10
GOTO 1501
C
C
C
C M16**I
1700 ISW=16
GOTO 1501
C
C
C
C
C
C
C
C *****************************************
C * MAKE CONVERSIONS APPROPRIATE FOR */+- *
C *****************************************
2000 CONTINUE
ID=DTBL1(OP2TYP,OP1TYP,1)
CALL CONTYP (STACK1,PT1,OP1TYP,ID,RETCD2)
IF (RETCD2.EQ.2) GOTO 9999
IF(ID.EQ.0)GO TO 2010
ST1TYP(PT1)=ID
OP1TYP=ID
2010 ID=DTBL1(OP2TYP,OP1TYP,2)
CALL CONTYP (STACK2,PT2,OP2TYP,ID,RETCD2)
IF (RETCD2.EQ.2) GOTO 9999
IF(ID.EQ.0)GOTO 2020
ST2TYP(PT2)=ID
OP2TYP=ID
C
2020 CONTINUE
C
C
C GOTO SECTION ACCORDING TO OPERATION *=3000, /=4000,+=5000,-=6000
GOTO (2100,3000,4000,5000,6000),IOP2
2100 STOP 2100
C
C
C
C
C
C
C **********************************************
C *********** MULTIPLICATION *****************
C **********************************************
3000 ID=DTBL1(OP2TYP,OP1TYP,4)
GOTO (3100,3200,3300,3300,3500,3600,3700,3300,3200),ID
STOP 3000
C
C
C ASCII (ALSO SUBTRACTION, MULTIPLICATION AND DIVISION)
3100 CALL ERRMSG (12)
GOTO 9999
C
C
C DECIMAL, REAL
3200 DO 3204 I=1,8
3204 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 3208 I=1,8
3208 EIGHT(I)=STACK2(I,PT2)
REAL=RHOLD*REAL
3209 DO 3210 I=1,8
3210 STACK1(I,PT1)=EIGHT(I)
C
C
C FOLLOWING USED BY OTHER SECTIONS
3220 ST1TYP(PT1)=DTBL1(OP2TYP,OP1TYP,3)
GOTO 10000
C
C
C
C HEX,INTEGER,OCTAL
3300 DO 3304 I=1,4
3304 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 3308 I=1,4
3308 FOUR(I)=STACK2(I,PT2)
INT=IHOLD*INT
3309 DO 3310 I=1,4
3310 STACK1(I,PT1)=FOUR(I)
GOTO 3220
C
C
C
C M10
3500 CALL MULMUL (PT1,PT2,RETCD2,10)
C
C
C FOLLOWING USED BY OTHER SECTIONS
3510 IF (RETCD2.EQ.2) GOTO 9999
GOTO 3220
C
C
C
C M8
3600 CALL MULMUL (PT1,PT2,RETCD2,8)
GOTO 3510
C
C
C
C M16
3700 CALL MULMUL (PT1,PT2,RETCD2,16)
GOTO 3510
C
C
C
C
C
C
C **************************************************
C ****************** DIVISION ********************
C **************************************************
4000 ID=DTBL1(OP2TYP,OP1TYP,4)
GOTO (3100,4200,4300,4300,4500,4600,4700,4300,4200),ID
STOP 4000
C
C
C DECIMAL,REAL
4200 DO 4204 I=1,8
4204 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 4208 I=1,8
4208 EIGHT(I)=STACK2(I,PT2)
IF(REAL.NE.0.D0)GO TO 4210
CALL ERRMSG(23)
GO TO 9999
4210 REAL=RHOLD/REAL
GOTO 3209
C
C
C HEX,INTEGER,OCTAL
4300 DO 4304 I=1,4
4304 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 4308 I=1,4
4308 FOUR(I)=STACK2(I,PT2)
IF(INT.NE.0)GO TO 4310
CALL ERRMSG(23)
GO TO 9999
4310 INT=IHOLD/INT
GOTO 3309
C
C
C M10
4500 CALL MULDIV (PT1,PT2,RETCD2,10)
GOTO 3510
C
C
C M8
4600 CALL MULDIV (PT1,PT2,RETCD2,8)
GOTO 3510
C
C
C M16
4700 CALL MULDIV (PT1,PT2,RETCD2,16)
GOTO 3510
C
C
C
C
C
C **************************************************
C ***************** ADDITION *********************
C **************************************************
C
5000 ID=DTBL1(OP2TYP,OP1TYP,4)
GOTO (3100,5200,5300,5300,5500,5600,5700,5300,5200),ID
STOP 5000
C
C
C DECIMAL, REAL
5200 DO 5204 I=1,8
5204 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 5208 I=1,8
5208 EIGHT(I)=STACK2(I,PT2)
REAL=RHOLD+REAL
GOTO 3209
C
C
C HEX,INTEGER,OCTAL
5300 DO 5304 I=1,4
5304 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 5308 I=1,4
5308 FOUR(I)=STACK2(I,PT2)
INT=IHOLD+INT
GOTO 3309
C
C
C M10
5500 CALL MULADD (PT1,PT2,RETCD2,1)
GOTO 3510
C
C
C M8
5600 CALL MULADD (PT1,PT2,RETCD2,2)
GOTO 3510
C
C
C M16
5700 CALL MULADD(PT1,PT2,RETCD2,3)
GOTO 3510
C
C
C
C
C
C
C ***************************************************
C ****************** SUBTRACTION ******************
C ***************************************************
C
6000 ID=DTBL1(OP2TYP,OP1TYP,4)
GOTO (3100,6200,6300,6300,6500,6600,6700,6300,6200),ID
STOP 6000
C
C
C DECIMAL,REAL
6200 DO 6204 I=1,8
6204 EIGHT(I)=STACK1(I,PT1)
RHOLD=REAL
DO 6208 I=1,8
6208 EIGHT(I)=STACK2(I,PT2)
REAL=RHOLD-REAL
GOTO 3209
C
C
C HEX,INTEGER,OCTAL
6300 DO 6304 I=1,4
6304 FOUR(I)=STACK1(I,PT1)
IHOLD=INT
DO 6308 I=1,4
6308 FOUR(I)=STACK2(I,PT2)
INT=IHOLD-INT
GOTO 3309
C
C
C M10
6500 CALL MULADD (PT1,PT2,RETCD2,4)
GOTO 3510
C
C
C M8
6600 CALL MULADD (PT1,PT2,RETCD2,5)
GOTO 3510
C
C
C M16
6700 CALL MULADD (PT1,PT2,RETCD2,6)
GOTO 3510
C
C
C
C
C
C EXIT
9999 RETCD=3
C
C
C
10000 ST2PT=ST2PT-2
RETURN
END