Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0001/inpost.for
There is 1 other file named inpost.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 INPOST *
C * *
C **************************************************
C
C
C CONVERTS THE INPUT STRING (INFIX NOTATION) TO POSTFIX
C FOR LATER EVALUATION BY POSTVL
C
C
C
C MODIFICATION CODES: M3,M10
C
C
C LAST MODIFIED 23-NOV-77 P.B.
C
C
C
C
C INPOST CALLS
C
C ERRMSG PRINTS ERROR MESSAGES
C NEXTEL GETS THE NEXT ELEMENT FROM LINE(80)
C
C
C
C INPOST IS CALLED BY CALC
C
C
C
C
C
C
C THE VARIABLE AND FUNCTION CODES.
C TABLE ALSO GIVES COMPARE VALUES AND STACK VALUES OF
C FUNCTIONS THAT OCCUR WHEN EXPRESSIONS ARE EVALUATED.
C
C
C
C
C STACK
C ELEMENT COMPARE STACK
C CODE TYPE BYTES VALUE VALUE
C
C 0 UNDEFINED - - -
C 1 ASCII 1 - -
C 2 DECIMAL 8 - -
C 3 HEXADECIMAL 4 - -
C 4 INTEGER 4 - -
C 5 MULT.PREC.(10) 100 - -
C 6 MULT.PREC.(8) 100 - -
C 7 MULT.PREC.(16) 100 - -
C 8 OCTAL 4 -
C 9 REAL 8 - -
C 10-30 UNDEFINED - - -
C
C ----------FUNCTIONS------------
C
C 31 ABS (=DABS) - 70 45
C 32 IABS - 70 45
C 33 FLOAT - 70 45
C 34 IFIX - 70 45
C 35 AINT - 70 45
C 36 INT (=IDINT) - 70 45
C 37 EXP (=DEXP) - 70 45
C 38 ALOG (=DLOG) - 70 45
C 39 ALOG10(=DLOG10) - 70 45
C 40 SQRT (=DSQRT) - 70 45
C 41 SIN (=DSIN) - 70 45
C 42 COS (=DCOS) - 70 45
C 43 TANH (=DTANH) - 70 45
C 44 ATAN (=DATAN) - 70 45
C 45 RESERVED - - -
C 46-100 RESERVED - - -
C
C 110 ( - 70 15
C 111 UNARY - - 50 49
C 112 ** - 40 39
C 113 * - 30 31
C 114 / - 30 31
C 115 + - 20 21
C 116 - - 20 21
C 117 ) - 10 -
C
C 200 = - 10 10
C
C
C
C
C
C
C
C VARIABLE USE
C
C I,K HOLDS TEMPORARY INTEGER*2 VALUES.
C LASTOP HOLDS THE TYPE OF LAST ELEMENT OBTAINED
C ON LINE(80). SET AT 0 AT BEGINNING OF EXPRESSION.
C USED BY NEXTEL TO IDENTIFY UNARY OPERATORS.
C NONBLK POINTER IN LINE(80). NEXTEL STARTS SCAN AT NONBLK+1.
C OPVAL(200,2) HOLDS THE COMPARE AND STACK VALUE OF EACH OPERATOR.
C PARVAL HOLDS 110 WHICH IS THE CODE FOR '(' IN STACK 2.
C RETCD RETURN CODE. 1=O.K. 2=ERROR.
C RETCD2 RETURN CODE FOR CALL TO NEXTEL.
C RETTYP HOLDS TYPE OF NEXT ELEMENT IN LINE, EITHER A FUNCTION
C CODE OR A DATA TYPE CODE.
C RETVAL(100) HOLDS VALUE OF NEXT ELEMENT IN LINE(80).
C ST1LIM HOLDS LIMIT OF STACK 1.
C ST2LIM HOLDS LIMIT OF STACK 2.
C ST1PT STACK 1 POINTER.
C ST2PT STACK 2 POINTER.
C ST1TYP TYPE OF EACH ELEMENT IN STACK 1
C ST2TYP TYPE OF EACH ELEMENT IN STACK 2
C VLEN HOLDS THE NUMBER OF BYTES USED BY EACH DATA TYPE.
C
C
C
C
SUBROUTINE INPOST (RETCD)
C
C
C
INTEGER*2 LEVEL,NONBLK,LEND
INTEGER*2 LASTOP
INTEGER*2 VIEWSW,BASED
INTEGER*2 OPVAL(200,2),PARVAL
INTEGER*2 RETCD,TYPE(27),RETCD2,RETTYP
INTEGER*2 ST1TYP(40),ST2TYP(40),ST1PT,ST2PT
INTEGER*2 ST1LIM,ST2LIM
INTEGER*2 VLEN(9)
INTEGER*2 I,K
C
LOGICAL*1 LINE(80)
LOGICAL*1 VBLS(100,27),RETVAL(100)
LOGICAL*1 STACK1(100,40),STACK2(100,40)
C
C
COMMON /STACK/STACK1,STACK2,ST1PT,ST2PT,ST1TYP,ST2TYP,
; ST1LIM,ST2LIM
COMMON /V/TYPE,VBLS,VLEN
COMMON /ERROR/ LASTOP
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
C
C
DATA OPVAL/30*-1,14*70,65*-1,70,50,40,30,30,20,20,10,82*-1,10,
; 30*-1,14*45,65*-1,15,49,39,31,31,21,21,-1,82*-1,10/
DATA PARVAL/110/
C
C
C
C
C
C INITIALIZE STACKS, RETURN CODE DEFAULT, AND LASTOP
RETCD=1
ST1PT=1
ST2PT=1
LASTOP=0
C
C SET UP FOR NEXTEL CALL
NONBLK=NONBLK-1
C
C
C
C
C **************************************************
C ***** GET NEXT ELEMENT OF EXPRESSION *************
C **************************************************
C
C
C
C NEXTEL RETURNS
C 1 IF OPERAND
C 2 IF OPERATOR (VALUE IN RETTYP)
C 3 IF NO MORE ELEMENTS
C 4 IF ERROR
C
C
50 CALL NEXTEL (RETVAL,RETTYP,RETCD2)
GOTO (100,200,300,999),RETCD2
STOP 50
C
C
C
C
C
C **************************************************
C ******** OPERAND FOUND, PUT ON STACK 1 *********
C **************************************************
C
C STACK 1 OVERFLOW CHECK
100 IF (ST1PT.GT.ST1LIM) GOTO 990
C
C
C
C
C
109 CONTINUE
C
C SUBROUTINE ERRCX HAS ALREADY ASSURED THAT
C IF AN OPERAND IS FOLLOWED BY AN = SIGN, THAT VARIABLE
C IS NOT PART OF AN EXPRESSION.
C
C VARIABLE INDEX IS TO BE PLACED IN STACK1 (1,ST1PT)
C SO IF YOU WANTED TO SPEED THE OPERATION AT THE EXPENSE
C OF SPACE, YOU WOULD ONLY COPY RETVAL(1) IF RETTYP < 0
K=VLEN(IABS(RETTYP))
DO 110 I=1,K
110 STACK1(I,ST1PT)=RETVAL(I)
ST1TYP(ST1PT)=RETTYP
ST1PT=ST1PT+1
GOTO 50
C
C
C
C
C
C
C
C
C **************************************************
C ***************** OPERATOR *********************
C **************************************************
C
200 CONTINUE
C
C IF NO OTHER OPERATOR ON STACK 2, PLACE ON STACK 2
IF (ST2PT.EQ.1) GOTO 222
C
C
C COMPARE VALUE WITH OPERATOR IN STACK2, IF GREATER OR EQUAL THEN
C PLACE IN STACK 2 BECAUSE IT HAS HIGHER PRECEDENCE AND IS ASSOCIATED
C WITH PREVIOUSLY ENCOUNTERED OPERAND, IS A UNARY OPERATOR ASSOCIATED
C WITH THE FOLLOWING ELEMENT, OR IS A '(' WHICH IS SAVED UNTIL A ')'
C IS FOUND.
C
K=ST2TYP(ST2PT-1)
IF (OPVAL(RETTYP,1).GE.OPVAL(K,2)) GOTO 220
C
C
C IF POPPING OFF ELEMENTS FROM STACK2 BECAUSE ')' WAS FOUND THEN WHEN
C ')' IS FOUND WE GO TO 230 TO REMOVE THE OPERATOR '(' FROM STACK 2.
C
IF (PARVAL.EQ.K) GOTO 230
IF (ST1PT.GT.ST1LIM) GOTO 990
C
C
C
C OPERATOR ON STACK 2 GOES ONTO STACK 1.
C
ST1TYP(ST1PT)=K
ST1PT=ST1PT+1
ST2PT=ST2PT-1
GOTO 200
C
C
C PUT OPERATOR ON STACK 2
220 IF (ST2PT.GT.ST2LIM) GOTO 992
222 ST2TYP(ST2PT)=RETTYP
ST2PT=ST2PT+1
GOTO 50
C
C
C REMOVE '(' FROM STACK 2
230 ST2PT=ST2PT-1
GOTO 50
C
C
C
C
C
C **************************************************
C ******* NO MORE ELEMENTS IN LINE *****************
C **************************************************
C
C CLEAN OFF STACK 2
300 IF (ST2PT.EQ.1) GOTO 1000
C
C IF A '(' GO TO 350 TO THROW IT AWAY.
IF (ST2TYP(ST2PT-1).EQ.PARVAL) GOTO 350
IF (ST1PT.GT.ST1LIM) GOTO 990
C
C
C
C PLACE ELEMENT ON STACK 2 ONTO STACK 1.
C
ST1TYP(ST1PT)=ST2TYP(ST2PT-1)
ST1PT=ST1PT+1
C
C THROW AWAY '(' FROM STACK 2.
350 ST2PT=ST2PT-1
GOTO 300
C
C
C
C
C *** ERROR HANDLING ***
C
C STACK 1 OVERFLOW
990 I=7
GO TO 998
C
C STACK 2 OVERFLOW
992 I=9
C
C
998 CALL ERRMSG(I)
999 RETCD=2
1000 RETURN
C
END