Trailing-Edge
-
PDP-10 Archives
-
decus_20tap1_198111
-
decus/20-0001/calc.for
There is 1 other file named calc.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 *** CALC MAINLINE ***
C *** ***
C *******************************************************
C *******************************************************
C
C
C THIS PROGRAM EVALUATES ARITHMETIC EXPRESSIONS INPUT TO IT
C AND ALLOWS VARIABLES TO BE ASSIGNED VALUES. IT FEATURES
C MULTIPLE PRECISION ARITHMETIC IN BASE 10, OCTAL, AND
C HEXADECIMAL. SEE CALC.MEM FOR A COMPLETE DESCRIPTION IN
C THE FORM OF A USERS GUIDE. TYPE ? TO OBTAIN A LIST OF
C POSSIBLE COMMANDS.
C
C
C
C CALC CALLS
C
C ASSIGN OPENS A FILE AND ASSIGNS IT TO A LOGICAL I/O UNIT.
C CLOSE CLOSES A FILE ASSOCIATED WITH A LOGICAL I/O UNIT.
C CMND DETERMINES WHAT CALC COMMAND IS REQUIRED.
C ERRCX CHECKS THE EXPRESSION IN AN INPUT LINE FOR SYNTAX ERRORS.
C ERRMSG PRINTS OUT ERROR MESSAGES.
C HALT RETURNS TO OPERATING SYSTEM.
C EXIT RETURNS TO OPERATING SYSTEM WITH TIME MESSAGE.
C GETMCR GETS THE COMMAND LINE USED TO INVOKE CALC. IF AN ARGUMENT
C IS PRESENT, CALC HALTS AFTER THAT ONE COMMAND IS EXECUTED.
C INPOST CONVERTS AN INFIX EXPRESSION TO POSTFIX FORM.
C LIST LISTS THE LEGAL CALC COMMANDS.
C POSTVL CONVERTS AN EXPRESSION IN POSTFIX NOTATION ON STACK 1 TO
C A VALUE.
C SLEND FINDS THE LAST NON-BLANK IN LINE(80).
C VAROUT PRINTS OUT THE VALUE OF A VARIABLE.
C ZNEG DETERMINES IF A VARIABLE IS POSITIVE IN VALUE
C
C
C
C
C
C
C
C VARIABLE USE
C
C BASED DEFAULT BASE WHEN CONSTANTS ARE ENTERED.
C BLANK ' '
C DIGITS(16,3) HOLDS DECIMAL, OCTAL, AND HEXADECIMAL DIGITS. THE
C SECOND SUBSCRIPT IS
C 1 FOR DECIMAL
C 2 FOR OCTAL
C 3 FOR HEXADECIMAL
C I,J HOLD TEMPORARY VALUES.
C ITCNTV(6) INDEXED BY LEVEL. 0 INDICATES THAT NO ITERATION ON THE
C INDIRECT COMMAND FILE IS TO TAKE PLACE. IF POSITIVE, IT
C HOLDS THE INDEX INTO VBLS AND REPRESENTS THE VARIABLE
C USED TO CONTROL ITERATION.
C LEND POINTS TO LAST NON-BLANK CHARACTER IN LINE(80)
C LEVEL HOLDS THE LOGICAL I/O UNIT WHERE THE NEXT CALC COMMAND
C LINES COME FROM.
C LINE(80) COMMAND INPUT LINE.
C NONBLK POINTS TO LAST NON-BLANK FOUND IN LINE(80).
C ONCE HOLDS 1 IF ONLY ONE COMMAND LINE IS TO BE EXECUTED,
C 0 OTHERWISE.
C STAR '*'
C VIEWSW VIEW SWITCH
C 0 = OUTPUT ERROR MESSAGES
C 1 = OUTPUT ERROR MESSAGES AND FILE COMMAND LINES
C 2 = OUTPUT ERROR MESSAGES AND VALUE OF EXPRESSIONS
C EVALUATED.
C 3 = OUTPUT EVERYTHING
C WHAT '?' SIGNIFIES THAT A LIST OF POSSIBLE COMMANDS
C SHOULD BE OUTPUT.
C
C
C
INTEGER*2 LEVEL,NONBLK,LEND
INTEGER*2 RETCD,VIEWSW,BASED
INTEGER*2 ONCE
INTEGER*2 ZNEG,ITCNTV(6)
C
LOGICAL*1 LINE(80),WHAT,STAR,QUOTE
LOGICAL*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
LOGICAL*1 DIGITS(16,3)
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
COMMON /DIGV/ DIGITS
COMMON/ITERA/ITCNTV
C
DATA WHAT/'?'/, STAR/'*'/, QUOTE/''''/
DATA ONCE/0/
C
C GET COMMAND LINE (MCR20 ROUTINE WRITTEN BY PAUL LEMAIRE TO
C SIMULATE PDP-11'S GETMCR ROUTINE ON THE DEC-20)
C
CALL MCR20 (LINE,LEND)
C
C THE FOLLOWING CALL TO ERRSET ASSURES THAT ARITHMETIC AND LIBRARY
C ERROR MESSAGES WILL ALWAYS BE PRINTED
C
CALL ERRSET (1000000)
C
C
C
C LOGICAL I/O UNIT 1 IS ASSIGNED TO THE INVOKING TERMINAL
C IF YOU DON'T WANT TO RISK THE BUILDER TASK BUILDING (LINKING)
C THE MODULES PROPERLY, PUT IN A
C CALL ASSIGN (1,'TI:')
C THE ADVANTAGE OF NOT DOING THIS IS THAT YOU CAN CREATE AN OUTPUT
C TEST FILE TO DISK TO HELP VERIFY CORRECTNESS AFTER A CHANGE TO THE
C SOURCE HAS BEEN MADE.
C
C
CALL ASSIGN (1, 'TTY', 3)
C
IF(LEND)20,20,5
5 CONTINUE
C
C MCR20 STRIPS THE CALC COMMAND AND RETURNS THE EXPRESSION
C LEFT-JUSTIFIED (NO LEADING SPACES)
C
NONBLK = 1
ONCE=1
GO TO 106
C
C ERROR RESET
10 IF(LEVEL.EQ.1) GO TO 12
CALL CLOSE(LEVEL)
LEVEL=LEVEL-1
GO TO 10
12 CONTINUE
VIEWSW=3
BASED=10
C
C
C GET NEXT INPUT LINE
20 IF(ONCE.EQ.1.AND.LEVEL.EQ.1) CALL HALT
IF(LEVEL.EQ.1)WRITE(1,22)
22 FORMAT(' CALC>',$)
C
C
READ (LEVEL,24,END=900,ERR=1000) LINE
24 FORMAT (80A1)
C
C
C
C FIND LAST NONBLANK, SAVE POSITION WITH VARIABLE 'LEND'
CALL SLEND(RETCD)
GO TO(30,20),RETCD
STOP 30
30 CONTINUE
C
C
C
C SHOW WHAT WAS READ FROM FILE
IF(LEVEL.NE.1.AND.(VIEWSW.EQ.1.OR.VIEWSW.EQ.3))
1 WRITE(1,40)LEVEL,(LINE(I),I=1,LEND)
40 FORMAT (' CALC<',I1,'>',80A1)
103 CONTINUE
C
C IDENTIFY FIRST NON-BLANK
DO 104 NONBLK=1,LEND
IF (LINE(NONBLK).NE.BLANK) GOTO 106
104 CONTINUE
STOP 104
C
C SEE IF A LIST OF POSSIBLE COMMANDS SHOULD BE PRINTED
106 IF (LINE(NONBLK).NE.WHAT) GOTO 110
CALL LIST
GOTO 20
C
C SEE IF IT IS A COMMAND
110 IF (LINE(NONBLK).NE.STAR) GOTO 120
CALL CMND (RETCD)
GOTO (20,115,10), RETCD
STOP 110
C
C
C A READ COMMAND WAS EXECUTED SO LINE HOLDS THE NEW COMMAND LINE.
115 CALL SLEND(RETCD)
GO TO (103,20),RETCD
STOP 115
C
C SEE IF ONLY ONE ALPHA CHARACTER
120 J=NONBLK+1
IF (LEND.NE.NONBLK) GOTO 130
DO 124 I=1,27
IF (LINE (NONBLK).EQ.ALPHA(I)) GOTO 126
124 CONTINUE
C
C ALLOW FOR A SINGLE DIGIT TO BE ASSIGNED TO %
DO 125 I=1,10
IF(LINE(NONBLK).EQ.DIGITS(I,1))GO TO 130
125 CONTINUE
C
C
C ALLOW FOR ENTERING THE ASCII BLANK
IF(LINE(NONBLK).EQ.QUOTE)GO TO 130
I=1
GOTO 1001
C
C OUTPUT VALUE OF SINGLE VARIABLE
126 CALL VAROUT(I)
GOTO 20
C
C
C CHECK INPUT FOR SYNTAX ERRORS
130 CALL ERRCX (RETCD)
GOTO (140,10),RETCD
STOP 130
C
C CHANGE FROM INFIX TO POSTFIX NOTATION
140 CALL INPOST (RETCD)
GOTO (150,10), RETCD
C
C
C EVALUATE EXPRESSION
150 CONTINUE
CALL POSTVL(RETCD)
GOTO(20,10),RETCD
STOP 150
C
C
C EXIT
900 IF (LEVEL.EQ.1) CALL EXIT
IF(ITCNTV(LEVEL).EQ.0)GOTO 910
IF(ZNEG(ITCNTV(LEVEL)).EQ.1)GO TO 910
C
C VALUE OF ITERATION VARIABLE IS POSITIVE SO REWIND FILE
C AND EXECUTE AGAIN.
REWIND LEVEL
GO TO 20
C
C
C EXIT FROM THIS LEVEL BY CLOSING THE FILE AND DECREASING VALUE
C OF LEVEL BY ONE.
910 CALL CLOSE(LEVEL)
LEVEL=LEVEL-1
GOTO 20
C
C
C
C *** ERROR PROCESSING ***
1000 I=27
1001 CALL ERRMSG(I)
GO TO 10
END