C RPN EXPRESSION EVALUATOR FOR RPTTAB C RETURNS FLOATING POINT RESULT C C Submitted by: C C R. N. Stillwell C Institute for Lipid Research C Baylor College of Medicine C Houston, Texas 77030 C C (who would be glad to receive comments, suggestions, bug fixes, etc., but C who promises no support whatever). C C Literature reference: C C R. N. Stillwell. A low-overhead laboratory data management system C for the PDP11. Comput. Biomed. Res., 15, 29-38(1982). C C Acknowledgement: C C This software was developed under National Institutes of Health grants C GM-13901 and GM-26611. C C General permission is hereby granted to copy, modify, or distribute this C program, but not for profit. Copyright to this software is and shall C remain in the public domain. C C REVISED JAN 1982: +001 IMPROVE ATOM CHECKING C (2) REARRANGE ATSYMB C (3) INCLUDE COMMON.FLX C (4) REMOVE "TERM" ARGUMENT C C 25-FEB-82 REDUCE ATSYMB TO R*4 C FUNCTION EVAL(FILERR,EVALER) LOGICAL*1 FILERR,EOF,EVALER LOGICAL*1 STKERR,OPERR C C DECLARE COMMON BLOCKS C COMMON /TABDAT/ NREC,NCOLS,LENREC,IOFSET,IPTRD,TABREC, 1 DATA INTEGER NREC,NCOLS,LENREC,IOFSET,IPTRD(41),TABREC BYTE DATA(1000) COMMON /LUN/ INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN INTEGER INLUN,OUTLUN,TILUN,TABLUN,TAILUN,RDFLUN COMMON /INPUT/ IREC,INPTR,LLINE,INLINE BYTE INLINE(132) DATA MAXIN/132/ COMMON /OUTPUT/ OUTLIN,OUTPTR,OUTEND BYTE OUTLIN (132) INTEGER OUTPTR,OUTEND DATA MAXOUT /132/ COMMON /FILES/ FILNAM,MAXFNM,MODNAM,LFNAM,FLREC, 1 MAXLVL,INLVL,OLDLVL,ULBUF,CARCTL,TERM 1 ,OUTOPN,TBOPEN C C FILE STACK C BYTE FILNAM(26,5) DATA MAXFNM/26/ REAL*4 MODNAM(5) !9-OCT-81 RAD50 MODULE NAMES INTEGER LFNAM(5) !LENGTHS OF NAMES C !POINTERS TO START OF CURRENT C !OR NEXT RECORD REAL*4 FLREC(5) !9-OCT-81 CHANGED FROM C !RECORD PTR TO BYTE PTR C D INTEGER IFLREC(2,5) D EQUIVALENCE (IFLREC,FLREC) DATA MAXLVL/5/ INTEGER INLVL !CURRENT LEVEL POINTER INTEGER OLDLVL !PREVIOUS LEVEL POINTER INTEGER ULBUF (7) BYTE CARCTL LOGICAL*1 TERM,OUTOPN,TBOPEN C C SCRATCH MEMORY. DEFINITIONS MAY DIFFER FROM SUBROUTINE TO SUBROUTINE, C OR MAY USE EQUIVALENCE STATEMENTS. C COMMON /SCRATCH/ SCRATCH BYTE SCRATCH (576) C C LOCAL DECLARATIONS C INTEGER ATOM,DONE DATA DONE /-1/ LOGICAL*1 OPRATR !ATOM IS AN OPERATOR C C OPERATORS ARE ORDERED SO THAT <= IS SCANNED BEFORE <, ETC. C !!!NOTE!!! ANY ADDITION OR CHANGE IN THE ORDER OF ATSYMB C REQUIRES A CORRESPONDING CHANGE IN SUBROUTINE DOIT. C REAL*4 ATSYMB(17) DATA ATSYMB/'+','-','&','!','*','/','%','MOD','<=','>=','<>', 1 '<','>','=','MINU','NOT','ABS'/ DATA NATSYM/17/ DATA IUNOP /15/ !+001 INDEX OF FIRST UNARY OPERATOR C REAL*4 STACK(50) INTEGER ISTACK,MAXSTK DATA MAXSTK/50/ C EQUIVALENCE (STACK,SCRATCH) C LOGICAL*1 LOGIC1,LOGIC2 BYTE CHAR,BLANK,CARRET DATA BLANK,CARRET/' ',"15/ C BYTE ATBUF(20) REAL*4 ATWORD EQUIVALENCE (ATBUF,ATWORD) DATA MAXATB/20/ INTEGER IATBUF C EVALER = .FALSE. ISTACK = 0 C FIRST CHARACTER SHOULD BE THE BLANK PRECEDING . GET-CHARACTER GET-ATOM WHILE (ATOM.NE.DONE) C+001 CONDITIONAL (ISTACK.EQ.0) EVALUATE-AND-STACK (ISTACK.EQ.1) CHECK-FOR-UNARY-OPERATOR WHEN (OPRATR) DO-IT-TO-IT ELSE EVALUATE-AND-STACK FIN (OTHERWISE) IDENTIFY-ATOM WHEN (OPRATR) DO-IT-TO-IT ELSE EVALUATE-AND-STACK FIN FIN C+001 GET-ATOM FIN IF (ISTACK.NE.1) REPORT-STACK-ERROR EVAL = STACK(1) RETURN C TO DO-IT-TO-IT D WRITE (5,9904) ATOM,(STACK(I),I=1,ISTACK) D9904 FORMAT (' DO',I4,' TO'/(1PG20.5)) CALL DOIT(ATOM,ISTACK,STACK,MAXSTK,STKERR,OPERR) D WRITE (5,9905) (STACK(I),I=1,ISTACK) D9905 FORMAT (' RESULT IS'/(1PG20.5)) IF (STKERR) REPORT-STACK-ERROR IF (OPERR) REPORT-ILLEGAL-OPERATOR FIN TO EVALUATE-AND-STACK D WRITE (5,9906) (ATBUF(I),I=1,IATBUF) D9906 FORMAT (' EVALUATE :',40A1) TEMP = EVATOM(IATBUF,ATBUF,EVALER) D WRITE (5,9907) TEMP D9907 FORMAT (' RESULT IS ',1PG20.5) IF (EVALER) REPORT-EVALUATION-ERROR ISTACK = ISTACK+1 IF (ISTACK.GT.MAXSTK) REPORT-STACK-OVERFLOW STACK(ISTACK) = TEMP FIN TO GET-ATOM WHILE (CHAR.EQ.BLANK) GET-CHARACTER WHEN (CHAR.EQ.CARRET) ATOM = DONE ELSE GET-ATOM-SYMBOL D WRITE (5,9902) IATBUF,(ATBUF(I),I=1,IATBUF) D9902 FORMAT (' IATBUF,ATBUF:',I6,2X,20A1) C (PENDING IDENTIFICATION) ATOM = 0 FIN FIN TO GET-ATOM-SYMBOL DO (I=1,MAXATB) ATBUF(I) = BLANK C PRELIMINARY: ALL ATOMS MUST BE SEPARATED BY BLANKS IATBUF = 0 WHILE (CHAR.NE.BLANK.AND.CHAR.NE.CARRET.AND.IATBUF.LT.MAXATB) IATBUF = IATBUF+1 ATBUF(IATBUF) = CHAR GET-CHARACTER FIN FIN TO GET-CHARACTER CALL GETCHR(CHAR,EOF,FILERR) FILERR = FILERR.OR.EOF IF (FILERR) RETURN D WRITE (5,9901) CHAR D9901 FORMAT (' IN EVAL: CHAR: ',O8) FIN TO IDENTIFY-ATOM ATOM = 1 WHILE (ATOM.LE.NATSYM.AND.ATWORD.NE.ATSYMB(ATOM)) ATOM = ATOM+1 OPRATR = ATOM.LE.NATSYM D WRITE (5,9903) ATOM,OPRATR D9903 FORMAT (' ATOM, OPRATR:',I6,L3) FIN TO CHECK-FOR-UNARY-OPERATOR ATOM = IUNOP WHILE (ATOM.LE.NATSYM.AND.ATWORD.NE.ATSYMB(ATOM)) ATOM = ATOM+1 OPRATR = ATOM.LE.NATSYM D WRITE (5,9903) ATOM,OPRATR FIN TO REPORT-EVALUATION-ERROR WRITE (TILUN,91) 91 FORMAT (' EVALUATION ERROR.') EVALER = .TRUE. EVAL = 0.0 RETURN FIN TO REPORT-ILLEGAL-OPERATOR WRITE (TILUN,93) 93 FORMAT (' ILLEGAL OPERATOR.') EVALER = .TRUE. EVAL = 0.0 RETURN FIN TO REPORT-STACK-ERROR WRITE (TILUN,90) 90 FORMAT (' STACK ERROR.') EVALER = .TRUE. EVAL = 0.0 RETURN FIN TO REPORT-STACK-OVERFLOW WRITE (TILUN,92) 92 FORMAT (' STACK OVERFLOW.') EVALER = .TRUE. EVAL = 0.0 RETURN FIN END