home *** CD-ROM | disk | FTP | other *** search
/ The Fred Fish Collection 1.5 / ffcollection-1-5-1992-11.iso / ff_progs / libs / matlab.lzh / MATLAB / MATLAB.LZH / Source / MatLab / parse.for < prev    next >
Encoding:
Text File  |  1991-04-13  |  7.9 KB  |  324 lines
  1.       SUBROUTINE PARSE
  2.       IMPLICIT NONE
  3. C
  4.       INCLUDE MATLAB$KOM:SIZEPARMS.INC
  5.       INCLUDE MATLAB$KOM:VSTK.KOM
  6.       INCLUDE MATLAB$KOM:RECU.KOM
  7.       INCLUDE MATLAB$KOM:IOP.KOM
  8.       INCLUDE MATLAB$KOM:COM.KOM
  9. C
  10.       INTEGER SEMI, EQUAL, EOL, ID(4), EXCNT, LPAREN, RPAREN, COLON
  11.       INTEGER PTS, ALFL, BLANK, COMMA, LESS, GREAT, NAME, ANS(4)
  12.       INTEGER ENND(4), ELSE(4), P, R, J, K, L, LS, N, I5, LUNIT
  13. C
  14.       LOGICAL EQID
  15.       DOUBLE PRECISION DFLOAT
  16. C
  17.       DATA BLANK / 36 /, SEMI / 39 /, EQUAL / 46 /, EOL / 99 /
  18.       DATA COMMA / 48 /, COLON / 40 /, LPAREN / 37 /, RPAREN / 38 /
  19.       DATA LESS / 50 /, GREAT / 51 /, NAME / 1 /, ALFL / 52 /
  20.       DATA ANS / 10, 23, 28, 36 /, ENND / 14, 23, 13, 36 /
  21.       DATA ELSE / 14, 21, 28, 14 /
  22. C
  23. C
  24. 01    CONTINUE
  25.       R = 0
  26.       IF (ERR.GT.0) PTZ = 0
  27.       IF (ERR.LE.0 .AND. PT.GT.PTZ) R = RSTK(PT)
  28.       IF (DDT.EQ.1) WRITE (WTE, 100) PT, R, PTZ, ERR
  29. 100   FORMAT (' PARSE ', 4I4)
  30.       IF (R.EQ.15) GO TO 93
  31.       IF (R.EQ.16 .OR. R.EQ.17) GO TO 94
  32.       SYM = EOL
  33.       TOP = 0
  34.       IF (RIO.NE.RTE) CALL FILES (-1*RIO, BUF)
  35.       RIO = RTE
  36.       LCT(3) = 0
  37.       LCT(4) = 2
  38.       LPT(1) = 1
  39. 10    CONTINUE
  40.       IF (SYM.EQ.EOL .AND. MOD (LCT(4)/2, 2).EQ.1)
  41.      .      CALL PROMPT (LCT(4)/4)
  42.       IF (SYM.EQ.EOL) CALL GETLIN
  43.       ERR = 0
  44.       PT = PTZ
  45. 15    CONTINUE
  46.       EXCNT = 0
  47.       IF (DDT.EQ.1) WRITE (WTE, 115) PT, TOP
  48. 115   FORMAT (' STATE ', 2I4)
  49.       LHS = 1
  50.       CALL PUTID (ID, ANS)
  51.       CALL GETSYM
  52.       IF (SYM.EQ.COLON .AND. CHAR.EQ.EOL) DDT = 1-DDT
  53.       IF (SYM.EQ.COLON) CALL GETSYM
  54.       IF (SYM.EQ.SEMI .OR. SYM.EQ.COMMA .OR. SYM.EQ.EOL) GO TO 80
  55.       IF (SYM.EQ.NAME) GO TO 20
  56.       IF (SYM.EQ.LESS) GO TO 40
  57.       IF (SYM.EQ.GREAT) GO TO 45
  58.       GO TO 50
  59. C
  60. C ***      LHS BEGINS WITH NAME
  61. 20    CONTINUE
  62.       CALL COMAND (SYN)
  63.       IF (ERR.GT.0) GO TO 01
  64.       IF (FUN.EQ.99) GO TO 95
  65.       IF (FIN.EQ.-15) GO TO 80
  66.       IF (FIN.LT.0) GO TO 91
  67.       IF (FIN.GT.0) GO TO 70
  68. C
  69. C ***      IF NAME IS A FUNCTION, MUST BE RHS
  70.       RHS = 0
  71.       CALL FUNS (SYN)
  72.       IF (FIN.NE.0) GO TO 50
  73. C
  74. C ***      PEEK ONE CHARACTER AHEAD
  75.       IF (CHAR.EQ.SEMI .OR. CHAR.EQ.COMMA .OR. CHAR.EQ.EOL)
  76.      .      CALL PUTID (ID, SYN)
  77.       IF (CHAR.EQ.EQUAL) GO TO 25
  78.       IF (CHAR.EQ.LPAREN) GO TO 30
  79.       GO TO 50
  80. C
  81. C ***      LHS IS SIMPLE VARIABLE
  82. 25    CONTINUE
  83.       CALL PUTID (ID, SYN)
  84.       CALL GETSYM
  85.       CALL GETSYM
  86.       GO TO 50
  87. C
  88. C ***      LHS IS NAME(...)
  89. 30    CONTINUE
  90.       LPT(5) = LPT(4)
  91.       CALL PUTID (ID, SYN)
  92.       CALL GETSYM
  93. 32    CONTINUE
  94.       CALL GETSYM
  95.       EXCNT = EXCNT+1
  96.       PT = PT+1
  97.       CALL PUTID (IDS(1,PT), ID)
  98.       PSTK(PT) = EXCNT
  99.       RSTK(PT) = 1
  100. C *CALL* EXPR
  101.       GO TO 92
  102. C
  103. 35    CONTINUE
  104.       CALL PUTID (ID, IDS(1,PT))
  105.       EXCNT = PSTK(PT)
  106.       PT = PT-1
  107.       IF (SYM.EQ.COMMA) GO TO 32
  108.       IF (SYM.NE.RPAREN) CALL ERROR (3)
  109.       IF (ERR.GT.0) GO TO 01
  110.       IF (ERR.GT.0) RETURN
  111.       IF (SYM.EQ.RPAREN) CALL GETSYM
  112.       IF (SYM.EQ.EQUAL) GO TO 50
  113. C
  114. C ***      LHS IS REALLY RHS, FORGET SCAN JUST DONE
  115.       TOP = TOP-EXCNT
  116.       LPT(4) = LPT(5)
  117.       CHAR = LPAREN
  118.       SYM = NAME
  119.       CALL PUTID (SYN, ID)
  120.       CALL PUTID (ID, ANS)
  121.       EXCNT = 0
  122.       GO TO 50
  123. C
  124. C ***      MULTIPLE LHS
  125. 40    CONTINUE
  126.       LPT(5) = LPT(4)
  127.       PTS = PT
  128.       CALL GETSYM
  129. 41    CONTINUE
  130.       IF (SYM.NE.NAME) GO TO 43
  131.       CALL PUTID (ID, SYN)
  132.       CALL GETSYM
  133.       IF (SYM.EQ.GREAT) GO TO 42
  134.       IF (SYM.EQ.COMMA) CALL GETSYM
  135.       PT = PT+1
  136.       LHS = LHS+1
  137.       PSTK(PT) = 0
  138.       CALL PUTID (IDS(1,PT), ID)
  139.       GO TO 41
  140. C
  141. 42    CONTINUE
  142.       CALL GETSYM
  143.       IF (SYM.EQ.EQUAL) GO TO 50
  144. 43    CONTINUE
  145.       LPT(4) = LPT(5)
  146.       PT = PTS
  147.       LHS = 1
  148.       SYM = LESS
  149.       CHAR = LPT(4)-1
  150.       CHAR = LIN(CHAR)
  151.       CALL PUTID (ID, ANS)
  152.       GO TO 50
  153. C
  154. C ***      MACRO STRING
  155. 45    CONTINUE
  156.       CALL GETSYM
  157.       IF (DDT.EQ.1) WRITE (WTE, 145) PT, TOP
  158. 145   FORMAT (' MACRO ', 2I4)
  159.       IF (SYM.EQ.LESS .AND. CHAR.EQ.EOL) CALL ERROR (28)
  160.       IF (ERR.GT.0) GO TO 01
  161.       PT = PT+1
  162.       RSTK(PT) = 20
  163. C *CALL* EXPR
  164.       GO TO 92
  165. C
  166. 46    CONTINUE
  167.       PT = PT-1
  168.       IF (SYM.NE.LESS .AND. SYM.NE.EOL) CALL ERROR (37)
  169.       IF (ERR.GT.0) GO TO 01
  170.       IF (SYM.EQ.LESS) CALL GETSYM
  171.       K = LPT(6)
  172.       LIN(K+1) = LPT(1)
  173.       LIN(K+2) = LPT(2)
  174.       LIN(K+3) = LPT(6)
  175.       LPT(1) = K+4
  176. C
  177. C ***      TRANSFER STACK TO INPUT LINE
  178.       K = LPT(1)
  179.       L = LSTK(TOP)
  180.       N = MSTK(TOP)*NSTK(TOP)
  181.       DO 48 J = 1, N
  182.         LS = L+J-1
  183.         LIN(K) = IDINT (STKR(LS))
  184.         IF (LIN(K).LT.0 .OR. LIN(K).GE.ALFL) CALL ERROR (37)
  185.         IF (ERR.GT.0) RETURN
  186.         IF (K.LT.1024) K = K+1
  187.         IF (K.EQ.1024) WRITE (WTE, 47) K
  188. 47      FORMAT (' INPUT BUFFER LIMIT IS ', I4, ' CHARACTERS.')
  189. 48    CONTINUE
  190.       TOP = TOP-1
  191.       LIN(K) = EOL
  192.       LPT(6) = K
  193.       LPT(4) = LPT(1)
  194.       LPT(3) = 0
  195.       LPT(2) = 0
  196.       LCT(1) = 0
  197.       CHAR = BLANK
  198.       PT = PT+1
  199.       PSTK(PT) = LPT(1)
  200.       RSTK(PT) = 21
  201. C *CALL* PARSE
  202.       GO TO 15
  203. C
  204. 49    CONTINUE
  205.       PT = PT-1
  206.       IF (DDT.EQ.1) WRITE (WTE, 149) PT, TOP
  207. 149   FORMAT (' MACEND', 2I4)
  208.       K = LPT(1)-4
  209.       LPT(1) = LIN(K+1)
  210.       LPT(4) = LIN(K+2)
  211.       LPT(6) = LIN(K+3)
  212.       CHAR = BLANK
  213.       CALL GETSYM
  214.       GO TO 80
  215. C
  216. C ***      LHS FINISHED, START RHS
  217. 50    CONTINUE
  218.       IF (SYM.EQ.EQUAL) CALL GETSYM
  219.       PT = PT+1
  220.       CALL PUTID (IDS(1,PT), ID)
  221.       PSTK(PT) = EXCNT
  222.       RSTK(PT) = 2
  223. C *CALL* EXPR
  224.       GO TO 92
  225. C
  226. 55    CONTINUE
  227.       IF (SYM.EQ.SEMI .OR. SYM.EQ.COMMA .OR. SYM.EQ.EOL) GO TO 60
  228.       IF (SYM.EQ.NAME .AND. EQID (SYN, ELSE)) GO TO 60
  229.       IF (SYM.EQ.NAME .AND. EQID (SYN, ENND)) GO TO 60
  230.       CALL ERROR (40)
  231.       IF (ERR.GT.0) GO TO 01
  232. C
  233. C ***      STORE RESULTS
  234. 60    CONTINUE
  235.       RHS = PSTK(PT)
  236.       CALL STACKP (IDS(1,PT))
  237.       IF (ERR.GT.0) GO TO 01
  238.       PT = PT-1
  239.       LHS = LHS-1
  240.       IF (LHS.GT.0) GO TO 60
  241.       GO TO 70
  242. C
  243. C ***      UPDATE AND POSSIBLY PRINT OPERATION COUNTS
  244. 70    CONTINUE
  245.       K = FLP(1)
  246.       IF (K.NE.0) STKR(VSIZE-3) = DFLOAT (K)
  247.       STKR(VSIZE-2) = STKR(VSIZE-2)+DFLOAT (K)
  248.       FLP(1) = 0
  249.       IF (.NOT.(CHAR.EQ.COMMA .OR. (SYM.EQ.COMMA .AND. CHAR.EQ.EOL)))
  250.      .      GO TO 80
  251.       CALL GETSYM
  252.       I5 = 10**5
  253.       LUNIT = WTE
  254. C
  255. 71    CONTINUE
  256.       IF (K.EQ.0) WRITE (LUNIT, 171)
  257. 171   FORMAT (/, '    no flops')
  258.       IF (K.EQ.1) WRITE (LUNIT, 172)
  259. 172   FORMAT (/, '     1 flop')
  260.       IF (1.LT.K .AND. K.LT.100000) WRITE (LUNIT, 173) K
  261. 173   FORMAT (/, 1X, I5, ' flops')
  262.       IF (100000.LE.K) WRITE (LUNIT, 174) K
  263. 174   FORMAT (/, 1X, I9, ' flops')
  264.       IF (LUNIT.EQ.WIO .OR. WIO.EQ.0) GO TO 80
  265.       LUNIT = WIO
  266.       GO TO 71
  267. C
  268. C ***      FINISH STATEMENT
  269. 80    CONTINUE
  270.       FIN = 0
  271.       P = 0
  272.       R = 0
  273.       IF (PT.GT.0) P = PSTK(PT)
  274.       IF (PT.GT.0) R = RSTK(PT)
  275.       IF (DDT.EQ.1) WRITE (WTE, 180) PT, PTZ, P, R, LPT(1)
  276. 180   FORMAT (' FINISH', 5I4)
  277.       IF (SYM.EQ.COMMA .OR. SYM.EQ.SEMI) GO TO 15
  278.       IF (R.EQ.21 .AND. P.EQ.LPT(1)) GO TO 49
  279.       IF (PT.GT.PTZ) GO TO 91
  280.       GO TO 10
  281. C
  282. C ***      SIMULATE RECURSION
  283. 91    CONTINUE
  284.       CALL CLAUSE
  285.       IF (ERR.GT.0) GO TO 01
  286.       IF (PT.LE.PTZ) GO TO 15
  287.       R = RSTK(PT)
  288.       IF (R.EQ.21) GO TO 49
  289.       GO TO (99, 99, 92, 92, 92, 99, 99, 99, 99, 99,
  290.      .       99, 99, 15, 15, 99, 99, 99, 99, 99), R
  291. C
  292. 92    CONTINUE
  293.       CALL EXPR
  294.       IF (ERR.GT.0) GO TO 01
  295.       R = RSTK(PT)
  296.       GO TO (35, 55, 91, 91, 91, 93, 93, 99, 99, 94,
  297.      .       94, 99, 99, 99, 99, 99, 99, 94, 94, 46), R
  298. C
  299. 93    CONTINUE
  300.       CALL TERM
  301.       IF (ERR.GT.0) GO TO 01
  302.       R = RSTK(PT)
  303.       GO TO (99, 99, 99, 99, 99, 92, 92, 94, 94, 99,
  304.      .       99, 99, 99, 99, 95, 99, 99, 99, 99), R
  305. C
  306. 94    CONTINUE
  307.       CALL FACTOR
  308.       IF (ERR.GT.0) GO TO 01
  309.       R = RSTK(PT)
  310.       GO TO (99, 99, 99, 99, 99, 99, 99, 93, 93, 92,
  311.      .       92, 94, 99, 99, 99, 95, 95, 92, 92), R
  312. C
  313. C ***      CALL MATFNS BY RETURNING TO MATLAB
  314. 95    CONTINUE
  315.       IF (FIN.GT.0 .AND. MSTK(TOP).LT.0) CALL ERROR (14)
  316.       IF (ERR.GT.0) GO TO 01
  317.       RETURN
  318. C
  319. 99    CONTINUE
  320.       CALL ERROR (22)
  321.       GO TO 01
  322. C
  323.       END
  324.