Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
decus/20-0001/errcx.for
There is 1 other file named errcx.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 ERRCX *
C * *
C **************************************************
C
C
C THIS SUBROUTINE DOES INITIAL SYNTAX CHECKING ON THE INPUT
C LINE. THE CHECKS MAKE SURE THAT PARENTHESES ARE BALANCED
C AND THAT THE EQUAL SIGN IS NOT MISUSED.
C
C
C
C
C RETCD MEANING
C
C 1 NO ERRORS DETECTED
C 2 ERROR FOUND
C
C
C
C
C MODIFICATION CLASSES: M1
C
C
C
C
C ERRCX CALLS ERRMSG WHICH PRINTS ERROR MESSAGES.
C
C
C
C ERRCX IS CALLED BY CALC
C
C
C
C VARIABLE USE
C
C ALPHA(27) HOLDS LEGAL VARIABLE NAMES: ALPHABETIC
C OR THE CHARACTER %.
C BLANK ' '
C I,J HOLDS TEMPORARY VALUES.
C LAST HOLDS A CODE WHEN LOOKING FOR ERRORS INVOLVING
C THE EQUAL SIGN.
C LEND LAST NON-BLANK CHARACTER IN LINE(80).
C LPAR '('
C PARCNT 0 IF PARENTHESIS ENCOUNTERED BALANCE. INCREASED
C BY 1 FOR EVERY LEFT PARENTHESIS, DECREASED BY
C BY 1 FOR EVERY RIGHT PERENTHESIS FOUND.
C RETCD HOLDS RETURN CODE. 1=O.K. 2=ERROR
C RPAR ')'
C
C
C
C
C
C
SUBROUTINE ERRCX (RETCD)
INTEGER*2 LEVEL,NONBLK,LEND
INTEGER*2 RETCD,PARCNT,VIEWSW,BASED
INTEGER*2 I,J,LAST
C
LOGICAL*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ
LOGICAL*1 LINE(80)
C
COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED
COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ
C
C
RETCD=1
C
C **************************************************
C ****** MAKE SURE PARENTHESIS ARE BALANCED ******
C **************************************************
C
PARCNT=0
DO 100 I=NONBLK,LEND
IF (LINE(I).EQ.LPAR) PARCNT=PARCNT+1
IF (LINE(I).EQ.RPAR) PARCNT=PARCNT-1
IF(PARCNT.LT.0)GOTO 160
100 CONTINUE
C
IF (PARCNT.EQ.0) GOTO 200
C
C
C UNBALANCED PARENTHESIS
I=6
140 CALL ERRMSG(I)
150 RETCD=2
RETURN
C
C
C ILLEGAL EXPRESSION LIKE ')))X((('
160 I=8
GOTO 140
C
C
C
C
C
C
C
C **************************************************
C ********* = SIGN SYNTAX CHECK ****************
C **************************************************
C
200 CONTINUE
C
C
C ALLOW A=B=C+2
C MAY ONLY ASSIGN VALUES TO SINGLE UNSIGNED VARIABLES.
C ALSO CATCH =A
C AND A==B
C
C LAST = 0 FIRST CHAR OR FOUND =
C 1 1 ALPHA CHARACTER
C 2 MORE THAN 1 ALPHA OR
C ENCOUNTERED NON-ALPHA
C (BUT NOT = OR BLANK)
C
C
C
LAST=0
DO 270 I=NONBLK,LEND
IF (LINE(I).EQ.BLANK) GOTO 270
IF (LINE(I).EQ.EQ) GOTO 230
C
C
C LOOK FOR ALPHA
DO 220 J=1,27
IF (LINE(I).EQ.ALPHA(J)) GOTO 240
220 CONTINUE
C
C
C MORE THAN 1 ALPHA OR ENCOUNTERED NON-ALPHA
C (BUT NOT = SIGN OR BLANK)
225 LAST=2
GOTO 270
C
C
C = SIGN ENCOUNTERED
230 IF (LAST.EQ.1) GOTO 235
C
C ILLEGAL USE OF = SIGN
GOTO 290
C
C HAD 1 ALPHA CHARACTER FOLLOWED BY = SIGN
235 LAST=0
GOTO 270
C
C ENCOUNTERED A VARIABLE NAME (1 CHARACTER)
240 IF (LAST.EQ.2) GOTO 270
IF (LAST.EQ.1) GOTO 225
C
C
C EXACTLY 1 ALPHA CHARACTER EITHER AS FIRST CHARACTER
C ENCOUNTERED OR AS THE 1ST CHARACTER AFTER AN = SIGN.
LAST=1
270 CONTINUE
C
C
C
C
C
C
C <<<<<<<<<<<< ADD ADDITIONAL CHECKS HERE >>>>>>>>>>
C
RETURN
C
C
C ILLEGAL USE OF = SIGN
290 I=17
GO TO 140
END