INCLUDE 'IPCOMM.FTN' INCLUDE 'FIGI01.FTN' INTEGER*2 IVALU(2) ! For picking up immediate value REAL*4 VALU ! Immediate value. INTEGER*2 INTER ! .TRUE. if interactive. EQUIVALENCE (VALU,IVALU) 91000 FORMAT (X,/,'$Shall I trace the parse? [T/F]: ') 91010 FORMAT (L10) 91030 FORMAT ('RADIX RESULT TRIM') 92000 FORMAT (X,/,'$Give calculation: ') 92010 FORMAT (Q,132A1) 92020 FORMAT (X,132A1) 92050 FORMAT (' Syntax error.') 92200 FORMAT (' Operator -',I6) 92210 FORMAT (' Operand -',I6,', Value -',F13.6) 92230 FORMAT (' Operator -',I6,', Value -',F13.6) D WRITE (5,91000) ! Ask user if he wants trace. D READ (6,91010) I ! Get user's response. PTRACE = 0 ! Assume no trace. D IF (I) PTRACE = LUNOUT ! If trace wanted, set it up. IPSKFG = .TRUE. ! Set parser to ignore blanks. IRXMRK = '@' ! Set the radix marker. DEFFMT = FMREAL ! Init the default format. OPPNTR = 0 ! Init operand stack pointer. NVARS = 0 ! No variables defined yet. ENCODE(IPBLEN,91030,IPBUF) ! Stick in the predefined names. IPSLOC = 1 ! They start at front of buffer. IPSLEN = IPBLEN ! They occupy the whole thing. IPSKFG = .TRUE. ! Blanks are delimiters. I = IVAR(.TRUE.,0,10.) ! Set up PRADIX = OPSTAK(OPPNTR) ! RADIX. I = IVAR(.TRUE.,0,0.) ! Set up PRESUL = OPSTAK(OPPNTR) ! RESULT. I = IVAR(.TRUE.,0,-1.) ! Set up PTRIM = OPSTAK(OPPNTR) ! TRIM. CURRDX = VARVAL(PRADIX) ! Set the current radix. SRCLUN = LUNIN ! Init the source LUN. INTER = .FALSE. ! Assume not interactive. CALL SYSGCM ! Try to get a command. IF (IPSLEN .GT. 0) GO TO 2010 ! If gotten, process. INTER = .TRUE. ! We're interactive. 2000 IF (SRCLUN .GE. LUNIN) ! If interactive, 1 WRITE (LUNOUT,92000) ! Ask for calculation. READ (SRCLUN,92010,END=9900) ! Read 1 IPSLEN,(IPBUF(I),I=1,IPSLEN) ! it. IF (IPSLEN .LE. 0) GO TO 9950 ! Ignore null lines. IPSLOC = 1 ! Init location in string. 2010 CALL UPCASE(IPSLEN,IPBUF) ! Uppercase the line. 2020 OPPNTR = 0 ! Init op. stack pointer. IF (PTRACE .GT. 0) ! If trace selected, 1 WRITE (PTRACE,92020) ! write out the 2 (IPBUF(I),I=IPSLOC, ! input 3 IPSLOC+IPSLEN-1) ! string. IF (IFIGPS()) GO TO 2090 ! If success, process. WRITE (LUNOUT,92050) ! Record syntax error. GO TO 9950 ! Loop back. 2090 CONTINUE ! Process further. IF (OPPNTR .LE. 0) GO TO 9950 ! If no operations, skip. IF (PTRACE .LE. 0) GO TO 2290 ! If no trace, skip. I = 0 GO TO 2240 2200 J = OPSTAK(I) ! Get the value. IF (J .GE. 0) GO TO 2210 IF (J .EQ. OPPSHI) GO TO 2220 WRITE (PTRACE,92200) J ! Write op. GO TO 2240 2210 VALU = VARVAL(J) ! Get value. WRITE (PTRACE,92210) J, ! Write 1 VALU ! value. GO TO 2240 2220 I = I + 1 IVALU(1) = OPSTAK(I) I = I + 1 IVALU(2) = OPSTAK(I) 2230 WRITE (PTRACE,92230) J, ! Write 1 VALU ! value. 2240 I = I + 1 ! Bump pointer. IF (I .LE. OPPNTR) GO TO 2200 !Loop. 2290 CONTINUE CALL FIGEVL ! Evaluate. IF (PRADIX .LE. 0) GO TO 2295 ! Skip if no radix. CURRDX = VARVAL(PRADIX) ! Get the current radix. CURRDX = MAX(MIN(CURRDX,36),1) ! Range it. 2295 IF (IPSLEN .GT. 0) GO TO 2020 ! If multiple statements. GO TO 9950 ! Go for more. 9900 IF (SRCLUN .GE. 5) CALL EXIT ! If at end of top level file, CLOSE (UNIT=SRCLUN) ! Close the source file. SRCLUN = SRCLUN + 1 ! Go back up a level. 9950 IF (.NOT. INTER .AND. ! If not interactive and 1 SRCLUN .GE. 5) ! trying to get from term., 2 CALL EXIT ! leave. GO TO 2000 ! Go back for mare data. END