FUNCTION IPRIM() ! Recognize a primary. C+ C Function IPRIM recognizes an arithmetic primary of the C form C C ::= ||| C ~|-| C SIGN |ABS C C That is, a variable, constant, or a temporary radix C operator followed by an assignment or an arithmetic test C enclosed in parentheses, or the logical negation, C arithmetic negation, arithmetic sign, or absolute value C of any of the above. C- INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. INTEGER*2 UNOPS ! Number of unary operations. D CALL PSNTRY('IPRIM ') ! Trace entry. CALL PSHNML ! Push the usual stuff. CALL PSPUSH(UNOPS) ! Number of Unarys. UNOPS = -1 ! New number is 0. 1000 UNOPS = UNOPS + 1 ! Count another. IF (IPCHAR('~')) GO TO 1100 ! Is it a logical 'NOT'? IF (IPCHAR('-')) GO TO 1200 ! Is it a unary minus? IF (IPSTR(4,'SIGN',0)) GO TO 1300 ! Is it a "signum"? IF (IPSTR(3,'ABS',0)) GO TO 1400 ! Is it absolute val? GO TO 2000 ! If neither, handle. 1100 CALL PSPUSH(OPNOT) ! Save the 'not' oper. GO TO 1000 ! Look for more. 1200 CALL PSPUSH(OPNEG) ! Save the neg. operator GO TO 1000 ! Look for more. 1300 CALL PSPUSH(OPSGN) ! Save signum operator GO TO 1000 ! Look for more. 1400 CALL PSPUSH(OPABS) ! Save abs val operator GO TO 1000 ! Look for more. 2000 IF (IREAL(CURRDX,IRXMRK)) GO TO 8000 ! If a constant, fine. IF (IVAR(.FALSE.,OPPUSH,0.)) GO TO 8000 ! If a variable, fine. IF (IGREXP()) GO TO 8000 ! If radix+parens, fine. GO TO 8200 ! No known syntax type. 8000 IF (UNOPS .EQ. 0) GO TO 8100 ! If no unaries, fine. DO 8040 I=1,UNOPS ! For each unary, OPPNTR = OPPNTR + 1 ! Bump operation pointr. CALL PSPOP(OPSTAK(OPPNTR)) ! Store operator. 8040 CONTINUE ! Loop until done. 8100 CALL PSPOP(UNOPS) ! Restore unary op. cnt. CALL POPACC ! Accepted. IPRIM = .TRUE. ! We have a primary. CALL PSTRCR('P') ! Trace the parse. RETURN ! Return to caller. 8200 PSPNTR = PSPNTR - UNOPS ! Clean up the stack. CALL PSPOP(UNOPS) ! Restore unary op. cnt. CALL POPREJ ! Rejected. IPRIM = .FALSE. ! No primary. RETURN ! Return to caller. END FUNCTION ITEST() ! Recognize a test. C+ C Function ITEST recognizes an arithmetic test of the C form C C ::= =? | C | C >? | C >=? | C <=? | C <>? | C C C That is, an arithmetic expression compared equal to, C less than, greater than, greater than or equal to, C less than or equal to, or not equal to another C arithmetic expression. The version without relational C operators is a "test" that returns the value of the C assignment, rather than the "normal" true or false, and C exists mostly to make things simpler internally. C- INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. D CALL PSNTRY('ITEST ') ! Trace entry. CALL PSHNML ! Save usual stuff. CALL PSPUSH(0) ! Init the mask. IF (.NOT. IEXPR()) GO TO 8200 ! If no expr, error. 1000 IF (IPCHAR('<')) GO TO 1010 ! Process 'less than'. IF (IPCHAR('=')) GO TO 1020 ! Process 'equal to'. IF (IPCHAR('>')) GO TO 1030 ! Process 'greater than' IF (IPCHAR('?')) GO TO 1040 ! If test, break out. IF (PSSTAK(PSPNTR) .EQ. 0) GO TO 8000 ! If no cond opers, OK. GO TO 8200 ! Error out. 1010 IF ((PSSTAK(PSPNTR) .AND. 1) .NE. 0) ! If already have "<", 1 GO TO 8200 ! an error. PSSTAK(PSPNTR) = PSSTAK(PSPNTR) .OR. 1 ! Insert mask. GO TO 1000 ! Loop back. 1020 IF ((PSSTAK(PSPNTR) .AND. 2) .NE. 0) ! If already have "=", 1 GO TO 8200 ! an error. PSSTAK(PSPNTR) = PSSTAK(PSPNTR) .OR. 2 ! Insert mask. GO TO 1000 ! Loop back. 1030 IF ((PSSTAK(PSPNTR) .AND. 4) .NE. 0) ! If already have ">", 1 GO TO 8200 ! an error. PSSTAK(PSPNTR) = PSSTAK(PSPNTR) .OR. 4 ! Insert mask. GO TO 1000 ! Loop back. 1040 IF (.NOT. IEXPR()) GO TO 8200 ! If not expr, bad. OPPNTR = OPPNTR + 1 ! Update oper. pointer. OPSTAK(OPPNTR) = OPCMP ! Stack the operation. OPPNTR = OPPNTR + 1 ! Update oper. pointer. CALL PSPOP(OPSTAK(OPPNTR)) ! Insert the mask. GO TO 8100 ! A match. 8000 CALL PSPOP(IPLEN) ! Mask not needed. 8100 CALL POPACC ! Accepted. ITEST = .TRUE. ! We have a test. CALL PSTRCR('C') ! Trace the parse. RETURN ! Return to caller. 8200 CALL PSPOP(IPLEN) ! Align the stack. CALL POPREJ ! Rejected. ITEST = .FALSE. ! No test. RETURN ! Return to caller. END FUNCTION IFAC() ! Recognize a factor. C+ C Function IFAC recognizes an arithmetic factor of the C form C C ::= |^ C C That is, an arithmetic primary, or the exponential of C a factor. C- INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. D CALL PSNTRY('IFAC ') ! Trace entry. CALL PSHNML ! Save the usual stuff. IF (.NOT. IPRIM()) GO TO 8300 ! If not prim, no match. 1000 IF (IPCHAR('^')) GO TO 1100 ! If exponential, handle GO TO 8000 ! End of term. 1100 CALL PSPUSH(OPEXP) ! Stack the operation. GO TO 1900 ! Go get next. 1900 IF (.NOT. IPRIM()) GO TO 8200 ! If not a primary, err. OPPNTR = OPPNTR + 1 ! Update oper. pointer. CALL PSPOP(OPSTAK(OPPNTR)) ! Put in the operator. GO TO 1000 8000 CALL POPACC ! Accepted. IFAC = .TRUE. ! We have a factor. CALL PSTRCR('F') ! Trace the parse. RETURN ! Return to caller. 8200 CALL PSPOP(IPLEN) ! Trash the operator. 8300 CALL POPREJ ! Rejected. IFAC = .FALSE. ! No factor. RETURN ! Return to caller. END FUNCTION ITERM() ! Recognize a term. C+ C Function ITERM recognizes an arithmetic term of the C form C C ::= |*|/| C DIV | C MOD | C & C C That is, the product, quotient, integer quotient, C remainder, or logical 'and' of C one or more factors. C- INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. D CALL PSNTRY('ITERM ') ! Trace entry. CALL PSHNML ! Save the usual stuff. IF (.NOT. IFAC()) GO TO 8300 ! If not factr, no match. 1000 IF (IPCHAR('*')) GO TO 1100 ! If multiplication. IF (IPCHAR('/')) GO TO 1200 ! If division. IF (IPCHAR('&')) GO TO 1300 ! If logical 'and'. IF (IPSTR(3,'DIV',0)) GO TO 1400 ! If integer divide. IF (IPSTR(3,'MOD',0)) GO TO 1500 ! If remainder. GO TO 8000 ! End of term. 1100 CALL PSPUSH(OPMUL) ! Save mult. operator. GO TO 1900 ! Go get next. 1200 CALL PSPUSH(OPDIV) ! Save div. operator. GO TO 1900 ! Go get next. 1300 CALL PSPUSH(OPAND) ! Save 'and' operator. GO TO 1900 ! Go get next. 1400 CALL PSPUSH(OPIDIV) ! Save integer div. oper GO TO 1900 ! Go get next. 1500 CALL PSPUSH(OPMOD) ! Save remainder oper. GO TO 1900 1900 IF (.NOT. IFAC()) GO TO 8200 ! If not a factr, err. OPPNTR = OPPNTR + 1 ! Space in operatn list. CALL PSPOP(OPSTAK(OPPNTR)) ! Stack the operation. GO TO 1000 8000 CALL POPACC ! Accepted. ITERM = .TRUE. ! We have a term. CALL PSTRCR('T') ! Trace the parse. RETURN ! Return to caller. 8200 CALL PSPOP(IPLEN) ! Trash the operation. 8300 CALL POPREJ ! Rejected. ITERM = .FALSE. ! No term. RETURN ! Return to caller. END FUNCTION IEXPR() ! Recognize an expressn. C+ C Function IEXPR recognizes arithmetic expressions of C the form C C ::= |+|-| C ! C C That is, the sum, difference, or logical 'or' of one C or more terms. C- INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. D CALL PSNTRY('IEXPR ') ! Trace entry. CALL PSHNML ! Save the normal stuff. IF (.NOT. ITERM()) GO TO 8300 ! If not factor, no match. 1000 IF (IPCHAR('+')) GO TO 1100 ! If addition, handle. IF (IPCHAR('-')) GO TO 1200 ! If subtraction, handle IF (IPCHAR('!')) GO TO 1300 ! If logical 'or'. GO TO 8000 ! End of term. 1100 CALL PSPUSH(OPADD) ! Save add'n operator. GO TO 1900 ! Go get next. 1200 CALL PSPUSH(OPSUB) ! Save subtr. operator. GO TO 1900 ! Go get next. 1300 CALL PSPUSH(OPOR) ! Save 'or' operator. GO TO 1900 ! Go get next. 1900 IF (.NOT. ITERM()) GO TO 8200 ! If not a factor, err. OPPNTR = OPPNTR + 1 ! Update oper. pointer. CALL PSPOP(OPSTAK(OPPNTR)) ! Insert the operation. GO TO 1000 8000 CALL POPACC ! Accepted. IEXPR = .TRUE. ! We have an expression. CALL PSTRCR('E') ! Trace the parse. RETURN ! Return to caller. 8200 CALL PSPOP(IPLEN) ! Trash the operation. 8300 CALL POPREJ ! Rejected. IEXPR = .FALSE. ! No expression. RETURN ! Return to caller. END FUNCTION IGREXP() ! Recognize global radix expr. C+ C Function IGREXP recognizes a "global temporary radix C expression" of the form C C ::= () C C That is, a legal expression or assignment statement C in parens, preceded by a temporary radix operator C (which may be null). C- INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. D CALL PSNTRY('IGREXP') ! Trace entry. CALL PSHNML ! Save the normal stuff. CALL PSPUSH(CURRDX) ! Stack current radix. CALL IRXOP(CURRDX) ! Modify it if need be. IF (.NOT. IPCHAR('(')) GO TO 8200 ! If no "(", illegal. IF (.NOT. IASSLH()) GO TO 8200 ! If no assign, illegal. IF (.NOT. IPCHAR(')')) GO TO 8200 ! If no ")", illegal. 8000 CALL PSPOP(CURRDX) ! Restore current radix. CALL POPACC ! Accepted. IGREXP = .TRUE. ! We have an assignment. CALL PSTRCR('%') ! Trace the parse. RETURN ! Return to caller. 8200 CALL PSPOP(CURRDX) ! Restore current radix. CALL POPREJ ! Rejected. IGREXP = .FALSE. ! No assignment. RETURN ! Return to caller. END FUNCTION IASSLH() ! Recognize left side of assgn. C+ C Function IASSLH recognizes an assignment operation C of the form C C ::= |= C C That is, an arithmetic test preceded by zero or more C assignment operations. C- INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. D CALL PSNTRY('IASSLH') ! Trace entry. CALL PSHNML ! Save the normal stuff. CALL PSPUSH(0) ! Stack marker. 1000 CALL PSHNML ! Save it again. IF (.NOT. IVAR(.TRUE.,OPSTO,0.)) ! If not variable, 1 GO TO 2000 ! no match. IF (.NOT. IPCHAR('=')) GO TO 2000 ! If no assgn, seek test IF (IPCHAR('?')) GO TO 2000 ! If it is really IF (IPCHAR('<')) GO TO 2000 ! a test, IF (IPCHAR('>')) GO TO 2000 ! reject. CALL POPACC ! Accept. CALL PSPUSH(OPSTAK(OPPNTR)) ! Save the variable OPPNTR = OPPNTR - 1 ! address and the CALL PSPUSH(OPSTAK(OPPNTR)) ! operand in parsr OPPNTR = OPPNTR - 1 ! stack, for later. GO TO 1000 ! Loop. 2000 CALL POPREJ ! Reject. IF (.NOT. ITEST()) GO TO 8200 ! If no expression, rej. 2100 IF (PSSTAK(PSPNTR) .EQ. 0) GO TO 2200 ! If stripped, done. OPPNTR = OPPNTR + 1 ! Bump operation pointr. CALL PSPOP(OPSTAK(OPPNTR)) ! Store operator. OPPNTR = OPPNTR + 1 ! Bump operation pointr. CALL PSPOP(OPSTAK(OPPNTR)) ! Store operand. GO TO 2100 ! Try for more. 2200 CALL PSPOP(IPLEN) ! Pop the marker. 8000 CALL POPACC ! Accepted. IASSLH = .TRUE. ! We have an assignment. CALL PSTRCR('A') ! Trace the parse. RETURN ! Return to caller. 8200 IF (PSSTAK(PSPNTR) .EQ. 0) GO TO 8300 ! If at flag, quit. PSPNTR = PSPNTR - 2 ! Decrement the stack. GO TO 8200 ! Loop. 8300 CALL PSPOP(IPLEN) ! Pop flag off. CALL POPREJ ! Rejected. IASSLH = .FALSE. ! No assignment. RETURN ! Return to caller. END