FUNCTION IFIGPS() ! Parse the line. D CALL PSNTRY('IFIGPS') ! Trace entry. CALL PSHNML ! Save the usual stuff. IF (IKEYWD()) GO TO 8000 ! If a keyword statement. IF (IASSLH()) GO TO 8000 ! If an arithmetic assignment. GO TO 8200 ! Error. 8000 IF (IPEOS()) GO TO 8100 ! If EOS, OK. IF (IPCHAR(';')) GO TO 8100 ! If stmt sep, OK. GO TO 8200 ! Reject. 8100 CALL POPACC ! Accept. IFIGPS = .TRUE. ! Mark accepted. RETURN ! Return to caller. 8200 CALL POPREJ ! Reject. IFIGPS = .FALSE. ! Mark rejected. RETURN ! Return to caller. END FUNCTION IKEYWD() ! Parse a keyword statement. INTEGER*2 INEST ! Desired nest depth. INTEGER*2 IQREQ ! Quotes req'd for file name. D CALL PSNTRY('IKEYWD') ! Trace entry. CALL PSHNML ! Save the usual junk. IQREQ = .FALSE. ! Originally, no. INEST = 1 ! Originally, nest. IF (IPCHAR('@')) GO TO 1100 ! If "@", handle. IQREQ = .TRUE. ! Finally, yes. IF (IPSTR(7,'INCLUDE',7)) GO TO 1100 ! If INCLUDE, handle. INEST = 0 ! No nest. IF (IPSTR(5,'CHAIN',5)) GO TO 1100 ! If CHAIN, handle. IF (IPSTR(4,'HELP',0)) GO TO 1300 ! IF HELP, handle. GO TO 8200 1100 IF (IFILER(INEST,IQREQ)) GO TO 8000 ! Process INCLUDE. GO TO 8200 ! If error, handle. 1300 CALL SYSHLP ! Issue the help. GO TO 8000 ! We're done. 8000 CALL POPACC ! Accept the command. CALL PSTRCR('K') ! Trace it. IKEYWD = .TRUE. ! Recognition. RETURN ! Return to caller. 8200 CALL POPREJ ! Reject the command. IKEYWD = .FALSE. ! No recognition. RETURN ! Return to caller. END SUBROUTINE PSTRCR(C) ! Trace the parse. LOGICAL*1 C ! Char. to trace with. INCLUDE 'FIGI01.FTN' INCLUDE 'IPCOMM.FTN' IF (PTRACE .LE. 0) RETURN ! If not wanted, ret. IF (IPLOC .LE. 0) GO TO 2000 ! If not in string. IF (IPLEN .LE. 0) GO TO 3000 ! If no length. WRITE (PTRACE,1000) (C,I=1,IPLEN) ! Write it. 1000 FORMAT (X,A1) RETURN 2000 WRITE (PTRACE,2010) IPLOC, IPLEN 2010 FORMAT (' Warning - Bad syntax element. Loc =',I4, 1 ' len =',I4,'.') RETURN 3000 WRITE (PTRACE,3010) C ! Write. 3010 FORMAT (X,A1,' (Length zero).') ! Format. RETURN ! Return to caller. END SUBROUTINE PSNTRY(C) ! Trace the parse. LOGICAL*1 C(6) ! Name of subroutine. INCLUDE 'FIGI01.FTN' IF (PTRACE .LE. 0) RETURN ! If not wanted, return. WRITE (PTRACE,1000) C ! Write it. 1000 FORMAT (' Entering ',6A1) RETURN END SUBROUTINE PSPUSH(IVAR) INTEGER*2 IVAR INCLUDE 'FIGI01.FTN' ! Calculator common. PSPNTR = PSPNTR + 1 ! Reserve loc. PSSTAK(PSPNTR) = IVAR ! Save var. RETURN ! Return to caller. ENTRY PSPOP IVAR = PSSTAK(PSPNTR) PSPNTR = PSPNTR - 1 RETURN END SUBROUTINE PSHNML ! Put normal stuff on stack. INCLUDE 'IPCOMM.FTN' INCLUDE 'FIGI01.FTN' CALL PSPUSH(IPSLOC) ! Save current loc CALL PSPUSH(IPSLEN) ! and length. CALL PSPUSH(OPPNTR) ! Save operand stack. CALL PSPUSH(NVARS) ! Save number of vars. CALL IPSKIP() ! Skip blanks. IPLOC = IPSLOC ! Init location. CALL PSPUSH(IPLOC) ! Save location. RETURN ENTRY POPACC ! Pop off stack for acceptance. CALL PSPOP(IPLOC) ! Restore location. CALL PSPOP(IPLEN) ! Trash no of vars. CALL PSPOP(IPLEN) ! Trash oper. pointer. CALL PSPOP(IPLEN) ! Trash saved CALL PSPOP(IPLEN) ! context. IPLEN = IPSLOC - IPLOC ! Calc. length. D IF (PTRACE .GT. 0) WRITE (PTRACE,1200) ! Write it. D1200 FORMAT (' Accepted') RETURN ENTRY POPREJ ! Pop off stack for rejection. CALL PSPOP(IPLEN) ! Trash the location. CALL PSPOP(NVARS) ! Restore no of vars. CALL PSPOP(OPPNTR) ! Restore oper. pntr. CALL PSPOP(IPSLEN) ! Restore saved CALL PSPOP(IPSLOC) ! context. IPLOC = IPSLOC ! Return standard info IPLEN = 0 ! for failure. D IF (PTRACE .GT. 0) WRITE (PTRACE,1300) ! Write it. D1300 FORMAT (' Rejected') RETURN END FUNCTION IRESWD() ! Recognize reserved words. C+ C Function IRESWD recognizes reserved words, and returns C .TRUE. if one is found. The parser is not advanced C beyond the reserved word. C- INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. D CALL PSNTRY('IRESWD') ! Trace entry. CALL PSHNML ! Push the usual stuff. IRESWD = .TRUE. ! Assume we hit one. IF (IPSTR(7,'INCLUDE',0)) GO TO 1000 ! "Include". IF (IPSTR(5,'CHAIN',0)) GO TO 1000 ! "Chain". IF (IPSTR(5,'FALSE',0)) GO TO 1000 ! "False". IF (IPSTR(4,'HELP',0)) GO TO 1000 ! "Help". IF (IPSTR(4,'SIGN',0)) GO TO 1000 ! 'Signum'. IF (IPSTR(4,'TRUE',0)) GO TO 1000 ! "True". IF (IPSTR(3,'ABS',0)) GO TO 1000 ! Absolute value. IF (IPSTR(3,'DIV',0)) GO TO 1000 ! Integer division. IF (IPSTR(3,'MOD',0)) GO TO 1000 ! Remainder. IF (IPSTR(3,'TEN',0)) GO TO 1000 ! Value ten. IRESWD = .FALSE. ! Not a reserved word. 1000 CALL POPREJ ! Reject. RETURN ! Return to caller. END FUNCTION IRXOP(IRX) ! Recognize radix oper, and return rdx C C Function IRXOP recognises a radix operator of the form C %B - Binary C %D - Decimal C %H - Hexadecimal C %L - Logical ("TRUE" or "FALSE" only) C %O - Octal C %X - Hexadecimal C %n - Explicit radix spec, where "n" is a DECIMAL C integer in the range 1 to 36. C If a radix operator is found at the current input string C location, IRXOP returns .TRUE., and IRX is its value; otherwise, C IRXOP returns .FALSE., and the value of IRX is not modified. C INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. D CALL PSNTRY('IRXOP ') ! Trace entry. CALL PSHNML ! Save the usual. IF (.NOT. IPCHAR('%')) GO TO 8200 ! If no radix ctrl. IF (IPCHAR('O')) GO TO 610 ! If octal. IF (IPCHAR('D')) GO TO 620 ! If decimal. IF (IPCHAR('X')) GO TO 630 ! If hexadecimal. IF (IPCHAR('H')) GO TO 630 ! If hexadecimal (alt). IF (IPCHAR('B')) GO TO 640 ! If binary. IF (IPCHAR('L')) GO TO 650 ! If logical. IF (IPNUM(10)) GO TO 660 ! If a number. GO TO 8200 ! Reject. 610 IRX = 8 ! Radix = 8 GO TO 8000 ! Continue 620 IRX = 10 ! Radix = 10 GO TO 8000 ! Continue 630 IRX = 16 ! Radix = 16 GO TO 8000 ! Continue 640 IRX = 2 ! Radix = 2 GO TO 8000 ! Continue 650 IRX = 1 ! Radix = 1 GO TO 8000 ! Continue. 660 CONTINUE IF (IPVALU .LE. 0) GO TO 8200 ! If out of range, err. IF (IPVALU .GT. 36) GO TO 8200 ! If out of range, err. IRX = IPVALU ! Get the radix. GO TO 8000 ! Accept. 8000 CALL POPACC ! Accept. IRXOP = .TRUE. ! Got a radix op. RETURN ! Return to caller. 8200 CALL POPREJ ! Reject. IRXOP = .FALSE. ! No radix op. RETURN ! Return to caller. END FUNCTION IREAL(IRDX,IMK) ! Match a real number of radix IRDX INTEGER*2 IREAL INTEGER*2 IRDX ! Radix to match. LOGICAL*1 IMK ! Exponent marker. INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. INTEGER*2 IV(2) ! Integer for value. REAL*4 RIPART ! Value. EQUIVALENCE (RIPART,IV) D CALL PSNTRY('IREAL ') ! Trace entry. IIRDX = ABS(IRDX) CALL PSHNML ! Save the normal stuff. CALL IPSKIP() ! Skip blanks. INULOC = IPSLOC ! Get loc. of number. IINMRC = .FALSE. ! Assume not explicit no CALL IRXOP(IIRDX) ! Get temp. radix if any IOP = OPTRUE ! Assume 'TRUE'. IF (IPSTR(4,'TRUE',0)) GO TO 2100 ! If so. OK. IOP = OPFALS ! Assume 'FALSE'. IF (IPSTR(5,'FALSE',0)) GO TO 2100 ! If so, OK. IF (IIRDX .LE. 1) GO TO 2200 ! If dflt logical, err. 1000 IIPOS = .TRUE. ! Assume positive. IF (IPCHAR('+')) GO TO 1200 ! If plus, OK. IIPOS = .NOT. IPCHAR('-') ! Get real sign. 1200 RIPART = 10. ! Assume literal ten. IF (IPSTR(3,'TEN',0)) GO TO 2000 ! If so, OK. RIPART = 0. ! Assume zero. IF (IINMRC) GO TO 1300 ! If explicit numeric. CALL IPSKIP ! Skip blanks. IF (IPBUF(IPSLOC) .EQ. 46) GO TO 1300 ! If a dot, OK. IF ((IRXMRK .LT. 65 .OR. IRXMRK .GT. 90) !If radix mark not alph 1 .AND. IPBUF(IPSLOC) .EQ. IRXMRK) ! and at the radix mk 2 GO TO 1300 ! OK. IF (IPBUF(IPSLOC) .LT. 48) GO TO 2200 ! If a non-numeric, err. IF (IPBUF(IPSLOC) .GT. 57) GO TO 2200 ! If a non-numeric, err. 1300 IF (IPNUM(IIRDX)) RIPART = IPVALU ! Get integer part. IF (.NOT. IPCHAR('.')) GO TO 1400 ! If no radix point. IF (.NOT. IPNUM(IIRDX)) GO TO 1400 ! If no fractional part. RIPART = FLOAT(IPVALU)/ ! Include the frac- 1 (FLOAT(IIRDX)**IPLEN) + RIPART ! tional part. 1400 IF (.NOT. IIPOS) RIPART = -RIPART ! If neg, make it so. IF (.NOT. IPCHAR(IMK)) GO TO 2000 ! If no exponent, done. IF (RIPART .EQ. 0.) RIPART = 1. ! Assume one wanted. IEPOS = .TRUE. ! Assume positive. IF (IPCHAR('+')) GO TO 1600 ! If plus, OK. IEPOS = .NOT. IPCHAR('-') ! Determine exp. sign. 1600 CONTINUE ! Get exponent magnitude IF (.NOT. IPNUM(IIRDX)) GO TO 2000 ! If no exponent, skip IEXP = IPVALU ! Set the exponent. IF (.NOT. IEPOS) IEXP = -IEXP ! Proper sign RIPART = RIPART*(FLOAT(IIRDX)**IEXP) ! Exponentiate. 2000 CONTINUE ! We have number. IF (INULOC .GE. IPSLOC) GO TO 2200 ! If no number. OPPNTR = OPPNTR + 1 ! Update the op. pointer OPSTAK(OPPNTR) = OPPSHI ! Insert the operation. OPPNTR = OPPNTR + 1 ! Update the op. pointer OPSTAK(OPPNTR) = IV(1) ! Insert first part. OPPNTR = OPPNTR + 1 ! Update the op. pointer OPSTAK(OPPNTR) = IV(2) ! Insert second part. IREAL = .TRUE. ! Success. CALL POPACC ! Clean up stack. CALL PSTRCR('R') ! Trace the parse. RETURN ! Return to caller. 2100 OPPNTR = OPPNTR + 1 ! Update the op. pointer OPSTAK(OPPNTR) = IOP ! Insert the operation. IREAL = .TRUE. ! Success. CALL POPACC ! Clean up stack. CALL PSTRCR('R') ! Trace the parse. RETURN ! Return to caller. 2200 CONTINUE CALL POPREJ ! Restore position. IREAL = .FALSE. ! Failed. RETURN ! Return to caller. END FUNCTION IVAR(ICRE,IFUNC,RVAL) ! Match a variable name. C+ C Function IVAR recognizes an arithmetic variable name C of the form C C ::= {1 to 6 RAD-50 characters, which must include C at least one letter or dollar sign} C- INTEGER*2 IVAR INTEGER*2 ICRE ! .TRUE. to create if not present. INTEGER*2 IFUNC ! Function to execute. REAL*4 RVAL ! Initial value. INCLUDE 'IPCOMM.FTN' ! Parser common. INCLUDE 'FIGI01.FTN' ! Calculator common. INTEGER*2 I ! Index. INTEGER*4 JVAR(MXVNAM) ! Variable name. D CALL PSNTRY('IVAR ') ! Trace entry. IILOC = IPSLOC IILEN = IPSLEN CALL IPSKIP ! Advance to text. IF (IRESWD()) GO TO 2200 ! If a reserved word. IF (.NOT. IPR50(MXVNAM*6)) GO TO 2200 ! If illegal var name. IF (IPBUF(IPLOC) .LT. 65 .OR. ! If not 1 IPBUF(IPLOC) .GT. 90) ! alphabetic, 2 GO TO 2200 ! an error. DO 1040 I = 1,MXVNAM ! Loop thru intrnal name JVAR(I) = 0 ! setting it to zero. 1040 CONTINUE ! repeat as needed. IRLIDX = IRAD50(IPLEN,IPBUF(IPLOC),JVAR) !Convert to rad-50 IF (NVARS .LE. 0) GO TO 1200 ! If must create. DO 1190 IRLIDX=1,NVARS ! Loop thru table. DO 1180 I=1,MXVNAM ! Loop thru var name. IF (VARNAM(I,IRLIDX) .NE. ! If a mismatch, 1 JVAR(I)) GO TO 1190 ! go for the next. 1180 CONTINUE ! Keep looking. GO TO 2000 ! Jackpot. 1190 CONTINUE ! Continue looping. 1200 CONTINUE IF (.NOT. ICRE) GO TO 2200 ! If required, exit. IRLIDX = NVARS + 1 ! Location for new. IF (IRLIDX .GE. MXVARS+1) GO TO 2200 ! If no room, die. NVARS = IRLIDX ! Note new variable. DO 1890 I=1,IRLIDX ! Loop thru variable name VARNAM(I,IRLIDX) = JVAR(I) ! Save its name. 1890 CONTINUE ! Repeat as needed. VARVAL(IRLIDX) = RVAL ! Initialize. 2000 CONTINUE OPPNTR = OPPNTR + 1 ! Update the op. pointer OPSTAK(OPPNTR) = IFUNC ! Insert the operation. OPPNTR = OPPNTR + 1 ! Update the op. pointer OPSTAK(OPPNTR) = IRLIDX ! Insert the location. IVAR = .TRUE. ! We have a var. CALL PSTRCR('V') ! Trace the parse. RETURN ! Return to caller. 2200 CONTINUE IVAR = .FALSE. IPLOC = IILOC IPLEN = 0 IPSLOC = IILOC IPSLEN = IILEN RETURN END FUNCTION IQOSTR(LEN,BUF,ISLEN) ! Get quoted string. INCLUDE 'IPCOMM.FTN' ! Parser common. LOGICAL*1 BUF(LEN) ! Size the buffer. CALL PSHNML ! Save the usual stuff. IF (.NOT. IPCHAR('"')) GO TO 8200 ! If no open quote, bad. ISLEN = 0 ! Init buffer pointer. 1100 IBEGIN = IPLOC + 1 ! Mark start of string. 1200 IF (IPCHAR('"')) GO TO 1400 ! At end of string? IF (IPANY()) GO TO 1200 ! If not, eat char. GO TO 8200 ! If no more line left. 1400 IEND = IPLOC - 1 ! Find end. IF (IEND .LT. IBEGIN) GO TO 1440 ! If no data, skip copy. DO 1420 I=IBEGIN,IEND ! Loop thru the string, ISLEN = ISLEN + 1 ! increm. length and BUF(ISLEN) = IPBUF(I) ! move character. 1420 CONTINUE ! repeat until done. 1440 CONTINUE ! String copied. IF (IPEOS()) GO TO 8000 ! If end of string, done IF (.NOT. IPCHAR('"')) GO TO 8200 ! If not another quote. ISLEN = ISLEN + 1 ! Got another character. BUF(ISLEN) = IPMCH ! Copy the character. GO TO 1100 ! Loop for more. 8000 BUF(ISLEN+1) = 0 ! Terminate with null. CALL POPACC ! Accept the command. CALL PSTRCR('Q') ! Trace if needed. IQOSTR = .TRUE. ! Recognition. RETURN ! Return to caller. 8200 CALL POPREJ ! Reject the command. IQOSTR = .FALSE. ! No recognition. RETURN ! Return to caller. END SUBROUTINE UPCASE(LEN,BUF) ! Uppercase a buffer. INTEGER*2 LEN LOGICAL*1 BUF(LEN) IQOT = .FALSE. ! Quote not encountered. DO 1090 I=1,LEN ! Loop thru buffer. IF (BUF(I) .EQ. '"') ! If we're a quote, 1 IQOT = .NOT. IQOT ! toggle the flag. IF (BUF(I) .GE. 'a' .AND. ! If we're a character 1 BUF(I) .LE. 'z' .AND. ! in lowercase range 2 .NOT. IQOT) ! and not quoted, 3 BUF(I) = BUF(I) - 'a' + 'A' ! uppercase us. 1090 CONTINUE ! Done. RETURN ! Return to caller. END ! End of module.