mat_parse Subroutine

public subroutine mat_parse()

THE PARSER-INTERPRETER (10)

The structure of the parser-interpreter is similar to that of Wirth's
compiler [6] for his simple language, PL/0 , except that LALA is
programmed in Fortran, which does not have explicit recursion. The
interrelation of the primary subroutines is shown in the following
diagram.

      MAIN
        |
      LALA     |--CLAUSE
        |       |    |
      PARSE-----|--EXPR----TERM----FACTOR
                |    |       |       |
                |    |-------|-------|
                |    |       |       |
                |  STACK1  STACK2  STACKG
                |
                |--STACKP--PRINT
                |
                |--COMAND
                |
                |
                |          |--CGECO
                |          |
                |          |--CGEFA
                |          |
                |--MATFN1--|--CGESL
                |          |
                |          |--CGEDI
                |          |
                |          |--CPOFA
                |
                |
                |          |--IMTQL2
                |          |
                |          |--HTRIDI
                |          |
                |--MATFN2--|--HTRIBK
                |          |
                |          |--CORTH
                |          |
                |          |--COMQR3
                |
                |
                |--MATFN3-----CSVDC
                |
                |
                |          |--CQRDC
                |--MATFN4--|
                |          |--CQRSL
                |
                |
                |          |--FILES
                |--MATFN5--|
                           |--SAVLOD

Subroutine MAT_PARSE controls the interpretation of each statement. It
calls subroutines that process the various syntactic quantities such
as command, expression, term and factor. A fairly simple program
stack mechanism allows these subroutines to recursively "call"
each other along the lines allowed by the syntax diagrams. The four
STACK subroutines manage the variable memory and perform elementary
operations, such as matrix addition and transposition.

The four subroutines MATFN1 though MATFN4 are called whenever "serious"
matrix computations are required. They are interface routines which
call the various LINPACK and EISPACK subroutines. MATFN5 primarily
handles the file access tasks.

Arguments

None

Contents

Variables

Source Code

mat_parse

Variables

Type Visibility Attributes Name Initial
integer, public, parameter :: ans(GG_MAX_NAME_LENGTH) = [iachar(['a', 'n', 's', ' ', ' ', ' ', ' ']), GG_PAD(8:)]
integer, public, parameter :: else(GG_MAX_NAME_LENGTH) = [iachar(['e', 'l', 's', 'e', ' ', ' ', ' ']), GG_PAD(8:)]
integer, public, parameter :: ennd(GG_MAX_NAME_LENGTH) = [iachar(['e', 'n', 'd', ' ', ' ', ' ', ' ']), GG_PAD(8:)]
integer, public :: excnt
integer, public :: i5
integer, public :: id(GG_MAX_NAME_LENGTH)
integer, public :: ierr
integer, public :: j
integer, public :: k
integer, public :: location
integer, public :: ls
integer, public :: n
integer, public :: p
integer, public :: pts
integer, public :: r
character(len=:), public, allocatable :: symbol

Source Code

SUBROUTINE mat_parse()
integer            :: id(GG_MAX_NAME_LENGTH)
integer            :: excnt
integer            :: pts
integer,parameter  :: ans(GG_MAX_NAME_LENGTH)  = [iachar(['a','n','s',' ',' ',' ',' ']),GG_PAD(8:)]
integer,parameter  :: ennd(GG_MAX_NAME_LENGTH) = [iachar(['e','n','d',' ',' ',' ',' ']),GG_PAD(8:)]
integer,parameter  :: else(GG_MAX_NAME_LENGTH) = [iachar(['e','l','s','e',' ',' ',' ']),GG_PAD(8:)]
integer            :: p
integer            :: r
integer            :: i5
integer            :: ierr
integer            :: j
integer            :: k
integer            :: location
integer            :: ls
integer            :: n
character(len=:),allocatable :: symbol
!
   01 continue
      r = 0
      if (G_ERR .gt. 0) G_PTZ = 0
      if (G_ERR.le.0 .and. G_PT.gt.G_PTZ) r = G_RSTK(G_PT)

      if (r.eq.15) goto 93
      if (r.eq.16 .or. r.eq.17) goto 94
      G_SYM = GG_EOL
      G_ARGUMENT_POINTER = 0
      if (G_RIO .ne. G_INPUT_LUN) call mat_files(-G_RIO,G_BUF)
      G_RIO = G_INPUT_LUN
      G_LINECOUNT(3) = 0
      G_LINECOUNT(4) = 2
      G_LINE_POINTER(1) = 1
   10 continue  ! get a new line if the current line has ended
      if (G_SYM.eq.GG_EOL.and.mod(G_LINECOUNT(4)/2,2).eq.1) call mat_prompt(G_LINECOUNT(4)/4)
      if (G_SYM .eq. GG_EOL) call mat_getlin()
      G_ERR = 0
      G_PT = G_PTZ

   15 continue   ! (continue) processing current line
      excnt = 0
      G_LHS = 1
      call mat_copyid(id,ans) ! copy ans to id
      call mat_getsym()

      if (G_SYM .eq. colon) then
         call mat_getsym()
      endif

      if (G_SYM.eq.SEMI .or. G_SYM.eq.COMMA .or. G_SYM.eq.GG_EOL) goto 80

      if (G_SYM .eq. isname) then
         ! lhs begins with name
         call ints2str(G_SYN,symbol,ierr)              ! convert ID to a character variable
         call mat_comand(symbol)
         IF (G_ERR .GT. 0) goto 01
         IF (G_FUN .EQ. 99) goto 95
         IF (G_FIN .EQ. -15) goto 80
         IF (G_FIN .LT. 0) goto 91
         IF (G_FIN .GT. 0) goto 70
         ! if name is a function, must be rhs
         G_RHS = 0
         call mat_funs(G_SYN)
         IF (G_FIN .NE. 0)then
            goto 50
         endif
         ! peek one character ahead
         IF (G_CHRA.EQ.SEMI .OR. G_CHRA.EQ.COMMA .OR. G_CHRA.EQ.GG_EOL) call mat_copyid(ID,G_SYN)
         IF (G_CHRA .EQ. EQUAL) then
            ! lhs is simple variable
            call mat_copyid(ID,G_SYN)
            call mat_getsym()
            call mat_getsym()
            goto 50
         endif
         IF (G_CHRA .EQ. LPAREN .or. G_CHRA .EQ. LBRACE) then
            ! lhs is name(...)
            G_LINE_POINTER(5) = G_LINE_POINTER(4)
            call mat_copyid(ID,G_SYN)
            call mat_getsym()
            goto 32
         endif
         goto 50
      endif
      if (G_SYM .eq. less .or. G_SYM .eq. lbracket) goto 40
      if (G_SYM .eq. great .or. G_SYM .eq. rbracket) goto 45
      goto 50
!.......................................................................
!     lhs is name(...)
   32 continue
      call mat_getsym()
      excnt = excnt+1
      G_PT = G_PT+1
      call mat_copyid(G_IDS(1,G_PT), id)
      G_PSTK(G_PT) = excnt
      G_RSTK(G_PT) = 1
!     *call* expr
      goto 92
!.......................................................................
   35 continue
      call mat_copyid(id,G_IDS(1,G_PT))
      excnt = G_PSTK(G_PT)
      G_PT = G_PT-1
      if (G_SYM .eq. comma) goto 32
      if ((G_SYM .ne. rparen) .and. (G_SYM.ne.rbrace)) then
         call mat_err(3)
         goto 01
         return  ! ???? cannot unconditionally goto and return
      endif
      if ((G_SYM .eq. rparen) .or. (G_SYM.eq.rbrace)) call mat_getsym()
      if (G_SYM .eq. equal) goto 50
!     lhs is really rhs, forget scan just done
      G_ARGUMENT_POINTER = G_ARGUMENT_POINTER - excnt
      G_LINE_POINTER(4) = G_LINE_POINTER(5)
      G_CHRA = lparen
      G_SYM = isname
      call mat_copyid(G_SYN,id)
      call mat_copyid(id,ans)
      excnt = 0
      goto 50
!.......................................................................
!     multiple lhs
   40 continue
      G_LINE_POINTER(5) = G_LINE_POINTER(4)
      pts = G_PT
      call mat_getsym()
   41 continue
      if (G_SYM .ne. isname)then
         goto 43
      endif
      call mat_copyid(id,G_SYN)
      call mat_getsym()
      if (G_SYM .eq. great.or. G_SYM.eq.rbracket)then
         call mat_getsym()
         if (G_SYM .eq. equal) goto 50
         goto 43
      endif
      if (G_SYM .eq. comma) call mat_getsym()
      G_PT = G_PT+1
      G_LHS = G_LHS+1
      G_PSTK(G_PT) = 0
      call mat_copyid(G_IDS(1,G_PT),id)
      goto 41
!.......................................................................
   43 continue
      G_LINE_POINTER(4) = G_LINE_POINTER(5)
      G_PT = pts
      G_LHS = 1
      G_SYM = less
      G_CHRA = G_LIN(G_LINE_POINTER(4)-1)
      call mat_copyid(id,ans)
      goto 50
!.......................................................................
!     macros string
   45 continue
      call mat_getsym()
      if ((G_SYM.eq.less .or. G_SYM.eq.lbracket) .and. G_CHRA.eq.GG_EOL) then
         call mat_err(28) ! Empty macro
         goto 01
      endif
      G_PT = G_PT+1
      G_RSTK(G_PT) = 20
!     *call* expr
      goto 92
!.......................................................................
   46 continue
      G_PT = G_PT-1
      if ((G_SYM.ne.less .and. G_SYM.ne.lbracket) .and. G_SYM.ne.GG_EOL) then
         call mat_err(37) ! Improper MACROS
         goto 01
      endif
      if (G_SYM .eq. less .or. G_SYM.eq. lbracket) call mat_getsym()
      k = G_LINE_POINTER(6)
      G_LIN(k+1) = G_LINE_POINTER(1)
      G_LIN(k+2) = G_LINE_POINTER(2)
      G_LIN(k+3) = G_LINE_POINTER(6)
      G_LINE_POINTER(1) = k + 4
!     transfer stack to input line
      k = G_LINE_POINTER(1)
      location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
      n = G_VAR_ROWS(G_ARGUMENT_POINTER)*G_VAR_COLS(G_ARGUMENT_POINTER)
      do j = 1, n
         ls = location + j-1
         G_LIN(k) = int(GM_REALS(ls))
         if (G_LIN(k).lt.0 .or. G_LIN(k).ge.G_CHARSET_SIZE) then
            call mat_err(37) ! improper MACROS
            return
         endif
         if (k.lt.1024) k = k+1
         if (k.eq.1024) then
            call journal('sc',' input buffer limit is',k,'characters')
          endif
      enddo
      G_ARGUMENT_POINTER = G_ARGUMENT_POINTER-1
      G_LIN(K) = GG_EOL; G_LIN(K+1:)=blank
      G_LINE_POINTER(6) = k
      G_LINE_POINTER(4) = G_LINE_POINTER(1)
      G_LINE_POINTER(3) = 0
      G_LINE_POINTER(2) = 0
      G_LINECOUNT(1) = 0
      G_CHRA = blank
      G_PT = G_PT+1
      G_PSTK(G_PT) = G_LINE_POINTER(1)
      G_RSTK(G_PT) = 21
!     *call* parse
      goto 15
!.......................................................................
   49 continue
      G_PT = G_PT-1
      k = G_LINE_POINTER(1) - 4
      G_LINE_POINTER(1) = G_LIN(K+1)
      G_LINE_POINTER(4) = G_LIN(K+2)
      G_LINE_POINTER(6) = G_LIN(K+3)
      G_CHRA = BLANK
      call mat_getsym()
      goto 80
!.......................................................................
!     lhs finished, start rhs
   50 continue
      if (G_SYM .eq. equal) call mat_getsym()
      G_PT = G_PT+1
      call mat_copyid(G_IDS(1,G_PT),id)
      G_PSTK(G_PT) = excnt
      G_RSTK(G_PT) = 2
!     *call* expr
      goto 92
!.......................................................................
!     store results
   60 continue
      G_RHS = G_PSTK(G_PT)
      call MAT_STACK_PUT(G_IDS(1,G_PT))
      if (G_ERR .gt. 0) goto 01
      G_PT = G_PT-1
      G_LHS = G_LHS-1
      if (G_LHS .gt. 0) goto 60
      goto 70
!.......................................................................
!     update and possibly print operation counts
   70 continue
      k = G_FLOP_COUNTER(1)
      if (K .ne. 0) GM_REALS(GM_BIGMEM-3) = dble(k)
      GM_REALS(GM_BIGMEM-2) = GM_REALS(GM_BIGMEM-2) + dble(K)
      G_FLOP_COUNTER(1) = 0
      if (.not.(G_CHRA.eq.comma .or. (G_SYM.eq.comma .and. G_CHRA.eq.GG_EOL)))goto 80
      call mat_getsym()
      i5 = 10**5

      if (k .eq. 0) then
         call journal('   no flops')
      elseif (k .EQ. 1) then
         call journal('    1 flop')
      else
         call journal('sc','',k,' flops')
      endif
      goto 80
!.......................................................................
!     finish statement
   80 continue
      G_FIN = 0
      p = 0
      r = 0
      if (G_PT .gt. 0) p = G_PSTK(G_PT)
      if (G_PT .gt. 0) r = G_RSTK(G_PT)
      if (G_SYM.eq.comma .or. G_SYM.eq.semi) goto 15
      if (r.eq.21 .and. p.eq.G_LINE_POINTER(1)) goto 49
      if (G_PT .gt. G_PTZ) goto 91
      goto 10
!.......................................................................
!     simulate recursion
!.......................................................................
   91 continue
      call mat_clause()
      if (G_ERR .gt. 0) goto 01
      if (G_PT .le. G_PTZ) goto 15
      r = G_RSTK(G_PT)
      select case(R)
      case(3:5);   goto 92
      case(13:14); goto 15
      case(21);    goto 49
      case default
         write(*,*)'INTERNAL ERROR 91'
         call mat_err(22) ! recursion difficulties
         goto 01
      end select
!.......................................................................
   92 CONTINUE
      call mat_expr()
      if (G_ERR .gt. 0) goto 01
      r = G_RSTK(G_PT)
      select case(r)
      case(1);     goto 35
      case(2)
         if (G_SYM.eq.semi .or. G_SYM.eq.comma .or. G_SYM.eq.GG_EOL) goto 60
         if (G_SYM.eq.isname .and. mat_eqid(G_SYN,else)) goto 60
         if (G_SYM.eq.isname .and. mat_eqid(G_SYN,ennd)) goto 60
         call mat_err(40)
         if (G_ERR .gt. 0) goto 01
         goto 60
      case(3:5);   goto 91
      case(6:7);   goto 93
      case(10:11); goto 94
      case(18:19); goto 94
      case(20);    goto 46
      case default
         write(*,*)'Internal error 92'
         call mat_err(22) ! recursion difficulties
         goto 01
      end select
!.......................................................................
   93 continue
      call mat_term()
      if (G_ERR .gt. 0) goto 01
      r = G_RSTK(G_PT)
      select case(R)
      case(6:7);   goto 92
      case(8:9);   goto 94
      case(15);    goto 95
      case default
         write(*,*)'INTERNAL ERROR 93'
         call mat_err(22) ! recursion difficulties
         goto 01
      end select
!.......................................................................
   94 continue
      call mat_factor()
      if (G_ERR .gt. 0) goto 01
      r = G_RSTK(G_PT)
      select case(R)
      case(8:9);   goto 93
      case(10:11); goto 92
      case(12);    goto 94
      case(16:17); goto 95
      case(18:19); goto 92
      case default
         write(*,*)'INTERNAL ERROR 94'
         call mat_err(22) ! recursion difficulties
         goto 01
      end select
!.......................................................................
!     call mat_matfns by returning to LALA
   95 continue
      if(G_ARGUMENT_POINTER.lt.1)then
         !call journal('sc','*mat_parse* stack emptied',G_ARGUMENT_POINTER)
      else
         if (G_FIN.gt.0 .and. G_VAR_ROWS(G_ARGUMENT_POINTER).lt.0) call mat_err(14)
      endif
      if (G_ERR .gt. 0) goto 01
      return
!.......................................................................
end subroutine mat_parse