最近の記事

<< 2016/12 >>
日 月 火 水 木 金 土
01 02 03
04 05 06 07 08 09 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30 31

このブログについて

（制作中）

カテゴリ一覧

最近のコメント

最近のトラックバック

バックナンバー

RSS

文書整形 -- テキストの書き出し ― 2016年12月10日 18:40

指令以外の行は、テキストである。これを書き出すルーチンtext()の 臨時第一版を示す。この版は下請けルーチンput()を呼び出すだけである。

RATFORでは、 

# text.r4 -- process text lines (interim version 1)
      subroutine text(inbuf)
      character inbuf(INSIZE)

      call put(inbuf)
      return
      end

WATCOM fortran 77では、 

c text.f -- process text lines (interim version 1)
      subroutine text(inbuf)
      integer*1 inbuf(82)               ! INSIZE(82)

      call put(inbuf)
      return
      end

下請けルーチンput()では、ページのレイアウトを考慮した出力が作り出される。

RATFOR版は、以下の通り。 

# put.r4 -- put out line with proper spacing and indenting
      subroutine put(buf)
      character buf(MAXLINE)
      integer min
      integer i
      include cpage.ri
      include cparam.ri

      if (lineno == 0 | lineno > bottom)
          call phead

      for (i = 1; i <= tival; i = i + 1) # indenting
          call putc(BLANK)
      tival = inval
      call putlin(buf,STDOUT)
      call skip(min(lsval-1,bottom-lineno))
      lineno = lineno + lsval
      if (lineno > bottom)
          call pfoot
      return
      end

WATCOM fortran77版は、以下の通り。 

c put.f -- put out line with proper spacing and indenting
      subroutine put(buf)
      integer*1 buf(82)                 ! MAXLINE(82)
      integer min
      integer i
      include cpage.fi
      include cparam.fi

      if ((lineno .eq. 0) .or. (lineno .gt. bottom)) then
          call phead
      end if

      i = 1                             ! indenting
      while (i .le. tival) do
          call putc(32)                 ! BLANK(32)
          i = i + 1
      end while

      tival = inval
      call putlin(buf,6)                ! STDOUT(6)
      call skip(min(lsval-1,bottom-lineno))
      lineno = lineno + lsval

      if (lineno .gt. bottom) then
          call pfoot
      end if
      return
      end

ページ見出し、ヘッダーとフッターは、phead()、pfoot()で書き出す。 put()は、これらを適当な位置で書き出すよう制御する。

phead()のRATFOR版は、以下の通り。 

# phead.r4 -- put out page header
      subroutine phead
      include cpage.ri

      curpag = newpag
      newpag = newpag + 1
      if (m1val > 0) {
         call skip(m1val - 1)
         call puttl(header,curpag)
         }
      call skip(m2val)
      lineno = m1val + m2val + 1
      return
      end

WATCOM fortran 77版は、以下の通り。 

c phead.f -- put out page header
      subroutine phead
      include cpage.fi

      curpag = newpag
      newpag = newpag + 1
      if (m1val .gt. 0) then
         call skip(m1val-1)
         call puttl(header,curpag)
      end if
      call skip(m2val)
      lineno = m1val + m2val + 1
      return
      end

pfoot()のRATFOR版は、以下の通り。 

# pfoot.r4 -- put out page footer
      subroutine pfoot
      include cpage.ri

      call skip(m3val)
      if (m4val > 0) {
         call puttl(footer,curpag)
         call skip(m4val - 1)
         }

      return
      end

WATCOM fortran 77版は、以下の通り。 

c pfoot.f -- put out page footer
      subroutine pfoot
      include cpage.fi

      call skip(m3val)
      if (m4val .gt. 0) then
         call puttl(footer,curpag)
         call skip(m4val - 1)
      endif

      return
      end

phead()、pfoot()とも、ページ見出しの書き出しはputtl()を使用する。 puttl()は、書き出す内容にPAGEMUN記号("#")が含まれていた場合、 その場所にページ番号を入れ込む。

puttl()のRATFOR版は、以下の通り。 

# puttl.r4 -- put title line with optional page number
      subroutine puttl(buf,pageno)
      character buf(MAXLINE)
      integer pageno
      integer i

      for (i = 1; buf(i) != EOS; i = i + 1)
          if (buf(i) == PAGENUM)
              call putdec(pageno,1)
          else
              call putc(buf(i))
      return
      end

WATCOM fortran 77版は、以下の通り。 

c puttl.for -- put title line with optional page number
      subroutine puttl(buf,pageno)
      integer*1 buf(82)                 ! MAXLINE(82)
      integer pageno
      integer i

      i = 1
      while (buf(i) .ne. -2) do         ! EOS(-2)
          if (buf(i) .eq. 35) then      ! PAGENUM('#',35)
              call putdec(pageno,1)
          else
              call putc(buf(i))
          end if
          i = i + 1
      end while
      return
      end

ページ見出しは、gettl()でページ見出し用のバッファーにセットする。

gettl()のRATFOR版は、以下の通り。 

# gettl.r4 -- copy title from buf to ttl
      subroutine gettl(buf,ttl)
      character buf(MAXLINE),ttl(MAXLINE)
      integer i

      i = 1                             # skip command name
      while ( buf(i) != BLANK & buf(i) != TAB & buf(i) != NEWLINE )
          i = i + 1
      call skipbl(buf,i)                # find argument
      if (buf(i) == SQUORT | buf(i) == DQUORT) # strip quorte if found
          i = i + 1
      call scopy(buf, i, ttl, 1)
      return
      end

WATCOM fortran 77版は、以下の通り。 

c gettl.for -- copy title from buf to ttl
      subroutine gettl(buf,ttl)
      integer*1 buf(82),ttl(82)         ! MAXLINE(82) MAXLINE(82)
      integer i

      i = 1                             ! skip command name
      while ((buf(i) .ne. 32)           ! BLANK(32)
     1    .and. (buf(i) .ne. 9)         ! TAB(9)
     2    .and. (buf(i) .ne. 10)) do    ! NEWLINE(10)
          i = i + 1
      end while

      call skipbl(buf,i)                ! find argument
      if ((buf(i) .eq. 39)
     1    .or. (buf(i) .eq. 34)) then   ! strip quorte if found SQUOTE(''',39) DQUOTE('"',34)
          i = i + 1
      end if
      call scopy(buf,i,ttl,1)
      return
      end

".sp"指令や".bp"指令は、space()で空行を出力しページレイアウトを 調整する。

space()のRATFOR版は、以下の通り。 

# space.r4 -- space n lines or to bottom of page
      subroutine space(n)
      integer n
      integer min
      include cpage.ri

      call brk
      if (lineno > bottom)
          return
      if (lineno == 0)
          call phead
      call skip(min(n, bottom + 1 - lineno))
      lineno = lineno + n
      if (lineno > bottom)
          call pfoot
      return
      end

WATCOM fortran 77版は、以下の通り。 

c space.f -- space n lines or to bottom of page
      subroutine space(n)
      integer n
      integer min
      include cpage.fi

      call brk
      if (lineno .gt. bottom) then
          return
      end if
      if (lineno .eq. 0) then
          call phead
      end if
      call skip(min(n,bottom+1-lineno))
      lineno = lineno + n
      if (lineno .gt. bottom) then
          call pfoot
      end if
      return
      end

by Kida Hiroya [コンピューター] [RATFOR] [コメント(50)｜トラックバック(0)]

文書整形 -- 指令の解析 ― 2016年12月05日 21:03

指令の解析は容易であり、comtyp()で行う。メインルーチンから呼び出される comand()から、最初にcomtyp()が呼び出される。comand()は、comtyp()の返す値に従い、 必要な処理を行っていく。comand()は以下の通りである。

RATFORでは、 

# comand.r4 -- perform formatting command
      subroutine comand( buf )
      character buf(MAXLINE)
      integer comtyp, getval
      integer ct, spval, val
      integer argtyp

      include cpage.ri
      include cparam.ri

      ct = comtyp(buf)
      if (ct == UNKOWN) # igore unknown commands
          return

      val = getval(buf,argtyp)
      if (ct == FI) {
          call brk
          fill = YES
          }
      else if (ct == NF) {
          call brk
          fill = NOC
          }
      else if (ct == BR)
          call brk
      else if (ct == LS)
          call set(lsval,val,argtyp,1,1,HUGE)
      else if (ct == HE)
          call gettl(buf,header)
      else if (ct == FO)
          call gettl(buf,footer)
      else if (ct == SP) {
          call set(spval,val,argtyp,1,0,HUGE)
          call space(spval)
          }
      else if (ct == BP) {
          if (lineno > 0)
              call space(HUGE)
          call set(curpage,val,argtyp,curpage+1,-HUGE,HUGE)
          newpag = curpag
          }
      else if (ct == PL) {
          call set(plval,val,argtyp,PAGELEN,m1val+m2val+m3val+m4val+1,HUGE)
          bottom = plval - m3val - m4val
          }
      else if (ct == IN) {
          call set(inval,val,argtyp,0,0,rmval-1)
          tival = inval
          }
      else if (ct == RM)
          call set(rmval,val,argtyp,PAGEWIDTH,tival+1,HUDGE)
      else if (ct == TI) {
          call brk
          call set(tival,val,argtyp,0,0,rmval-1)
          }
      else if (ct == CE) {
          call brk
          call set(ceval,val,argtyp,1,0,HUGE)
          }
      else if (ct .eq. 14) then ! UL(14)
          call set(ulval,val,argtyp,1,0,HUGE)

      return
      end

WATCOM fortran 77では、 

c comand.f -- perform formatting command
      subroutine comand( buf )
      integer*1 buf(82)                 ! MAXLINE(82)
      integer comtyp, getval
      integer ct, spval, val
      integer*1 argtyp

      include cpage.fi
      include cparam.fi

      ct = comtyp(buf)
      if (ct .eq. 0) then               ! UNKOWN(0)
          return
      end if

      val = getval(buf,argtyp)
      if (ct .eq. 4) then               ! FI(4)
          call brk
          fill = 1                      ! YES(1)
      else if (ct .eq. 9) then          ! NF(9)
          call brk
          fill = 0                      ! NOC(0)
      else if (ct .eq. 2) then          ! BR(2)
          call brk
      else if (ct .eq. 8) then          ! LS(8)
          call set(lsval,val,argtyp,1,1,1000) ! HUGE(1000)
      else if (ct .eq. 6) then          ! HE(6)
          call gettl(buf,header)
      else if (ct .eq. 5) then          ! FO(5)
          call gettl(buf,footer)
      else if (ct .eq. 12) then         ! SP(12)
          call set(spval,val,argtyp,1,0,1000) ! HUGE(1000)
          call space(spval)
      else if (ct .eq. 1) then          ! BP(1)
          if (lineno .gt. 0) then
              call space(1000)          ! HUGE(1000)
          end if
          call set(curpage,val,argtyp,curpage+1,-1000,1000) ! HUGE(1000)
          newpag = curpag
      else if (ct .eq. 10) then         ! PL(10)
          call set(plval,val,argtyp,66, ! PAGELEN(66)
     1        m1val+m2val+m3val+m4val+1,1000) ! HUGE(1000)
          bottom = plval - m3val - m4val
      else if (ct .eq. 7) then          ! IN(7)
          call set(inval,val,argtyp,0,0,rmval-1)
          tival = inval
      else if (ct .eq. 11) then         ! RM(11)
          call set(rmval,val,argtyp,60,tival+1,1000) ! PAGEWIDTH(60) HUGE(1000)
      else if (ct .eq. 13) then         ! TI(13)
          call brk
          call set(tival,val,argtyp,0,0,rmval-1) 
      else if (ct .eq. 3) then          ! CE(3)
          call brk
          call set(ceval,val,argtyp,1,0,1000) ! HUGE(1000)
      else if (ct .eq. 14) then ! UL(14)
          call set(ulval,val,argtyp,1,0,1000) ! HUGE(1000)
      end if

      return
      end

実際の指令の解析は、comtyp()が行う。

RATFOR版は、以下の通り。 

c comtyp.r4 -- decode command type
      integer function comtyp(buf)
      character buf(MAXLINE)

      if (buf(2) == LETB & buf(3) == LETP)
         comtyp = BP
      else if (buf(2) == LETB & buf(3) == LETR)
         comtyp = BR
      else if (buf(2) == LETC & buf(3) == LETE)
         comtyp = CE
      else if (buf(2) == LETF & buf(3) == LETI)
         comtyp = FI
      else if (buf(2) == LETF & buf(3) == LETO)
         comtyp = FO
      else if (buf(2) == LETH & buf(3) == LETE)
         comtyp = HE
      else if (buf(2) == LETI & buf(3) == LETN)
         comtyp = IN
      else if (buf(2) == LETL & buf(3) == LETS)
         comtyp = LS
      else if (buf(2) == LETN & buf(3) == LETF)
         comtyp = NF
      else if (buf(2) == LETP & buf(3) == LETL)
         comtyp = PL
      else if (buf(2) == LETR & buf(3) == LETM)
         comtyp = RM
      else if (buf(2) == LETS & buf(3) == LETP)
         comtyp = SP
      else if (buf(2) == LETT & buf(3) ==  LETI)
         comtyp = TI
      else if (buf(2) == LETU & buf(3) == LETL)
         comtyp = UL
      else
         comtyp = UNKOWN
      end if
      return
      end

WATCOM fortran77版は、以下の通り。 

c comtyp.for -- decode command type
      integer function comtyp(buf)
      integer*1 buf(82)                 ! MAXLINE(82)

      if ((buf(2) .eq. 98) .and. (buf(3) .eq. 112)) then      ! LETB('b',98) LETP('p',112)
         comtyp = 1                         ! BP(1)
      else if ((buf(2) .eq. 98) .and. (buf(3) .eq. 114)) then ! LETB('b',98) LETR('r',114)
         comtyp = 2                     ! BR(2)
      else if ((buf(2) .eq. 99) .and. (buf(3) .eq. 101)) then ! LETC('c',99) LETE('r',101)
         comtyp = 3                     ! CE(3)
      else if ((buf(2) .eq. 102) .and. (buf(3) .eq. 105)) then ! LETF('f',102) LETI('i',105)
         comtyp = 4                     ! FI(4)
      else if ((buf(2) .eq. 102) .and. (buf(3) .eq. 111)) then ! LETF('f',102) LETO('o',111)
         comtyp = 5                     ! FO(5)
      else if ((buf(2) .eq. 104) .and. (buf(3) .eq. 101)) then ! LETH('h',104) LETE('e',101)
         comtyp = 6                     ! HE(6)
      else if ((buf(2) .eq. 105) .and. (buf(3) .eq. 110)) then ! LETI('i',105) LETN('n',110)
         comtyp = 7                     ! IN(7)
      else if ((buf(2) .eq. 108) .and. (buf(3) .eq. 115)) then ! LETL('l',108) LETS('n',115)
         comtyp = 8                     ! LS(8)
      else if ((buf(2) .eq. 110) .and. (buf(3) .eq. 102)) then ! LETN('n',110) LETF('f',102)
         comtyp = 9                     ! NF(9)
      else if ((buf(2) .eq. 112) .and. (buf(3) .eq. 108)) then ! LETP('n',112) LETL('l',108)
         comtyp = 10                    ! PL(10)
      else if ((buf(2) .eq. 114) .and. (buf(3) .eq. 109)) then  ! LETR('r',114) LETM('m',109)
         comtyp = 11                    ! RM(11)
      else if ((buf(2) .eq. 115) .and. (buf(3) .eq. 112)) then  ! LETS('s',115) LETP('p',112)
         comtyp = 12                    ! SP(12)
      else if ((buf(2) .eq. 116) .and. (buf(3) .eq. 105)) then  ! LETT('t',116) LETI('i',105)
         comtyp = 13                    ! TI(13)
      else if ((buf(2) .eq. 117) .and. (buf(3) .eq. 108)) then  ! LETU('u',117) LETL('l',108)
         comtyp = 14                    ! UL(14)
      else
         comtyp = 0                     ! UNKOWN(0)
      end if
      return
      end

指令の引数は、getval()で取得する。取得した値は、set()で設定する。

getval()のRATFOR版は、以下の通り。 

# getval.r4 - evaluate optional numeric argument
      integer function getval(buf,argtyp)
      character buf(MAXLINE)
      integer ctoi
      integer argtyp, i

      i = 1                        # skip command name
      while (buf(i) != BLANK & buf(i) != TAB & buf(i) != NEWLINW)
          i = i + 1
      call skipbl(buf,i)           # find argument
      argtyp = buf(i)
      if (argtyp == PLUS | argtyp == MINUS)
         i = i + 1
      getval = ctoi(buf,i)
      return
      end

WATCOM fortran版は、以下の通り。 

c getval.for - evaluate optional numeric argument
      integer function getval(buf,argtyp)
      integer*1 buf(82)                 ! MAXLINE(82)

      integer ctoi
      integer argtyp, i

      i = 1                             ! skip command name
      while ((buf(i) .ne. 32)           ! BLANK(32)
     1    .and. (buf(i) .ne. 9)         ! TAB(9)
     2    .and. (buf(i) .ne. 10)) do    ! NEWLINE(10)
          i = i + 1
      end while
      call skipbl(buf,i)                ! find argument
      argtyp = buf(i)
      if ((argtyp .eq. 43) .or. (argtyp .eq. 45)) then ! PLUS('+',43) MINUS('-',45)
         i = i + 1
      end if
      getval = ctoi(buf,i)
      return
      end

set()のRATFOR版は、以下の通り。 

# set.r4 -- set parameter and check range
      subroutine set( param, val, argtyp, defval, minval, maxval )
      integer param, val, defval, minval, maxval
      character argtyp
      integer max,min

      if (argtyp == NEWLINE)
         param = defval
      else if (argtyp == PLUS)
         param = param + val
      else if (argtyp == MINUS)
         param = param - val
      else
         param = val

      param = min( param, maxval )
      param = max( param, minval )

      return
      end

WATCOM fortran版は、以下の通り。 

c set.for -- set parameter and check range
      subroutine set( param, val, argtyp, defval, minval, maxval )
      integer param, val, defval, minval, maxval
      integer*1 argtyp
      integer max,min

      if (argtyp .eq. 10) then          ! defaulted  NEWLINE(10)
         param = defval
      else if (argtyp .eq. 43) then     ! relative + PLUS('+',43)
         param = param + val
      else if (argtyp .eq. 45) then     ! relative - NIMUS('-',45)
         param = param - val
      else
         param = val
      endif
      param = min( param, maxval )
      param = max( param, minval )

      return
      end

by Kida Hiroya [コンピューター] [RATFOR] [コメント(50)｜トラックバック(0)]

文書整形 -- 指令の解読 ― 2016年10月04日 17:49

指令は行頭から始まるので、とりあえず一文字目がなんであるかで、 その行が指令なのか、其れ以外なのか判断できる。そこで、メインルーチンは、 とりあえず、下記のように書ける。

RATFORでは、 

# xformat -- text formater main program
      program xformat
      character inbuf(INSIZE)
      character getlin

      include cpage.ri

      call initfile
      call init

      while (getlin(inbuf,STDIN) != EOF)
          if (inbuf(1) == COMMAND)
              call comand(inbuf)        # it's a command
          else
              call text(inbuf)          # it's a text
      stop
      end

WATCOM fortran 77では、 

c xformat -- text formater main program
      program xformat
      integer*1 inbuf(82)               ! INSIZE(82)
      integer*1 getlin

      include cpage.fi

      call initfile
      call init

      while (getlin(inbuf,5) .ne. -1) do ! STDIN(5) EOF(-1)
          if (inbuf(1) .eq. 46) then    ! COMMAND('.',46)
              call comand(inbuf)        ! it's a command
          else
              call text(inbuf)          ! it's a text
          end if
      end while
      stop
      end

ここで,サブルーチンinitは、大域変数を初期化するルーチンである。

RATFORでは、以下の通り。 

# init.r4 -- set initial value
      subroutine init

      include cparam.ri
      include cpage.ri
      include cout.ri

# cparam
      fill  = YES
      lsval = 1
      inval = 0
      rmval = PAGEWIDTH
      tival = 0
      ceval = 0
      ulval = 0
# cpage
      curpag = 0
      newpag = 1
      lineno = 0
      plval  = PAGELEN
      m1val  = 4
      m2val  = 1
      m3val  = 4
      m4val  = 1
      bottom = plval - m3val - m4val
      header(1) = EOS
      footer(1) = EOS
# cout
      outp   = 0
      outw   = 0
      outwds = 0
      outbuf(1) = EOS
#
      return
      end

WATCOM fortran77では、以下の通り。 

c init.f -- set initial value
      subroutine init

      include cparam.fi
      include cpage.fi
      include cout.fi

c cparam
      fill  = 1                         ! YES(1)
      lsval = 1
      inval = 0
      rmval = 60                        ! PAGEWIDTH(60)
      tival = 0
      ceval = 0
      ulval = 0
c cpage
      curpag = 0
      newpag = 1
      lineno = 0
      
      plval  = 66                       ! PAGELEN(66)
      m1val  = 4
      m2val  = 1
      m3val  = 4
      m4val  = 1
      bottom = plval - m3val - m4val
      header(1) = -2                    ! EOS(-2)
      footer(1) = -2                    ! EOS(-2)
c cout
      outp   = 0
      outw   = 0
      outwds = 0
      outbuf(1) = -2                    ! EOS(-2)
c
      return
      end

by Kida Hiroya [コンピューター] [RATFOR] [コメント(11)｜トラックバック(0)]

文書整形 -- 指令一覧 ― 2016年09月23日 21:23

文書整形とは、文書中に埋め込まれた指令に従い、文書の体裁をそろえ、印刷装置向けの 出力を作成することです。文書の体裁をそろえる指定は、以下の通り。 

   .bp N   ページ番号をNにする。
   .br     中断をおこす。
   .ce N   次行からN行中央そろえをする。
   .fi     詰め合わせを開始する。
   .fo     フッターを設定する。
   .he     ヘッダーを設定する。
   .in N   N文字、字下げする。
   .ls N   改行をN行にする。
   .nf     詰め合わせをしない。
   .pl N   1ページあたりの行数をNにする。
   .rm N   右マージンをN文字にする。
   .sp N   N行の空白を作る。
   .ti N   N文字、一時字下げする。
   .ul N   N行、語に下線を引く。

指令は、行頭から始まり、行末までである。1行中に、指令と文書が混じることもないし、 1行中に、指令が複数書かれることもない。

指令には、数値の引数をとるものがある。数値は、そのものずばりNと書くことも、+n,-nと 現在の値に対して相対値を書くこともできる。すなわち、 

   .rm 10
と 
   .rm +10
は違った意味を持つ。前者は右マージンを10にするが、後者は右マージンを現在値+10にする。

by Kida Hiroya [コンピューター] [RATFOR] [コメント(6)｜トラックバック(0)]

コマンドの処理 ７ docmd()(再掲)とメインルーチンedit ― 2016年08月01日 09:18

コマンドの処理　７　docmd()(再掲)とメインルーチンedit

行の複写指令を含めたdocmd()を以下に示す。docmd()は指令文字を一つ一つ 比較しながら分岐を行い、各指令の前提条件確認し、指令を実行する。

docmd()のRATFOR版は以下の通り。 

# docmd.r4 -- handle all commands except globals
      integer function docmd(lin,i,glob,status)
      character lin(MAXLINE)
      integer i,glob,status

      integer append,doprnt,defalt,nextln,prevln,move,ckp,getone
      integer dodel,getrhs,subst,getfn,doread,dowrit
      integer line3
      character file(MAXLINE)
      integer pflag,gflag,optpat

      include clines.ri
      include cfile.ri
      include cpat.ri

      pflag = NO
      status = ERR
      if (lin(i) == APPENDCOM) {
          if (lin(i+1) == NEWLINE)
              status = append(line2,glob)
          }
      else if (lin(i) == CHANGE) {
          if (lin(i+1) == NEWLINE)
              if (defalt(curln,curln,status) == OK)
                  if (delete(line1,line2,status) == OK)
                      status = append(prevln(line1),glob)
          }
      else if (lin(i) == DELETE) {
          if (ckp(lin,i+1,pflag,status) == OK)
              if (defalt(curln,curln,status) == OK)
                  if (dodel(line1,line2,status) == OK)
                      if (nextln(curln) == 0)
                          curln = nextln(curln)
          }
      else if (lin(i) == INSERT) {
          if (lin(i+1) == NEWLINE)
              status = append(prevln(line2),glob)
          }
      else if (lin(i) == PRINTCUR) {
          if (ckp(lin,i+1,pflag,status) == OK) {
              call putdec(line2,1)
              call putc(NEWLINE)
              }
          }
      else if (lin(i) == COPYCMD) {
          i = i + 1
          if (getone(lin,i,line3,status) == EOF)
              status = ERR
          if (status == OK)
              if (ckp(lin,i,pflag,status) == OK)
                  if (defalt(curln,curln,status) == OK)
                      status = kopy(line3)
          }
      else if (lin(i) == MOVECOM) {
          i = i + 1
          if (getone(lin,i,line3,status) == EOF)
              status = ERR
          if (status == OK)
              if (ckp(lin,i,pflag,status) == OK)
                  if (defalt(curln,curln,status) ==OK)
                      status = move(line3)
          }
      else if (lin(i) == SUBSTITUTE) {
          i = i + 1
          if (optpat(lin,i) == OK)
              if (getrhs(lin,i,sub,gflag) == OK)
                  if (ckp(lin,i+1,pflag,status) == OK)
                      if (defalt(curln,curln,status) == OK)
                          status = subst(sub,gflag)
          }
      else if (lin(i) == ENTER) {
          if (nlines == 0) then
              if (getfn(lin,i,file) == OK) {
                  call scopy(file,1,savfil,1)
                  call clrbuf
                  call setbuf
                  status = doread(0,file)
              }
          }
      else if (lin(i) == PRINTFIL) {
          if (nlines == 0)
              if (getfn(lin,i,file) == OK) {
                  call scopy(file,1,savfil,1)
                  call putlin(savfil,STDOUT)
                  call putc(NEWLINE)
                  status = OK
              }
          }
      else if (lin(i) == READCOM) {
          if (getfn(lin,i,file) == OK)
              status = doread(line2,file)
          }
      else if (lin(i) ==WRITECOM) {
          if (getfn(lin,i,file) == OK)
              if (defalt(1,lastln,status) == OK)
                  status = dowrit(line1,line2,file)
              end if
          }
      else if (lin(i) == PRINT) {
          if (lin(i+1) == NEWLINE)
              if (defalt(curln,curln,status) == OK)
                  status = doprnt(line1,line2)
          }
      else if (lin(i) == QUIT) {
          if (lin(i+1) == NEWLINE & nlines == 0 & glob == NO)
              status = EOF
          }
      # else status is ERR
      end if

      if (status == OK & pflag == YES)
          status = doprnt(curln,curln)
      docmd = status
      return
      end

WATCOM fortran77版は以下の通り。 

c docmd.f -- handle all commands except globals
      integer function docmd(lin,i,glob,status)
      integer*1 lin(82)                 ! MAXLINE(82)
      integer i,glob,status

      integer append,doprnt,defalt,nextln,prevln,move,ckp,getone
      integer delcmd,getrhs,subst,getfn,doread,dowrit
      integer line3,pflag,gflag,optpat
      integer*1 file(82),sub(82)        ! MAXLINE(82) MAXPAT(82)

      include clines.fi
      include cfile.fi
      include cpat.fi

      pflag = 0                         ! NO(0)
      status = -3                       ! ERR(-3)
      if (lin(i) .eq. 97) then          ! APPENDCOM(97 'a')
          if (lin(i+1) .eq. 10) then    ! NEWLINE(10)
              status = append(line2,glob)
          end if
      else if (lin(i) .eq. 99) then     ! CHANGE(99,'c')
          if (lin(i+1) .eq. 10) then    ! NEWLINE(10)
              if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                  if (delete(line1,line2,status) .eq. -2) then ! OK(-2)
                      status = append(prevln(line1),glob)
                  end if
              end if
          end if
      else if (lin(i) .eq. 107) then    ! COPYCMD(107, 'k')
          i = i + 1
          if (getone(lin,i,line3,status) .eq. -1) then ! EOF(-1)
              call putdec(line3,1)
              call putc(10)
              status = -3               ! ERR(-3)
          end if 
          if (status .eq. -2) then           ! OK(-2)
              if (ckp(lin,i,pflag,status) .eq. -2) then ! OK(-2)
                  if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                      status = kopy(line3)
                  end if
              end if
          end if
      else if (lin(i) .eq. 100) then    ! DELETE(100,'d')
          if (ckp(lin,i+1,pflag,status) .eq. -2) then ! OK(-2)
              if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                  if (delcmd(line1,line2,status) .eq. -2) then ! OK(-2)
                      if (nextln(curln) .ne. 0) then
                          curln = nextln(curln)
                      end if
                   end if
              end if
          end if
      else if (lin(i) .eq. 105) then    ! INSERT(105,'i')
          if (lin(i+1) .eq. 10) then    ! NEWLINE(10)
              status = append(prevln(line2),glob)
          end if
      else if (lin(i) .eq. 61) then     ! PRINTCUR(61,'=')
          if (ckp(lin,i+1,pflag,status) .eq. -2) then ! OK(-2)
              call putdec(line2,1)
              call putc(10)             ! NEWLINE(10)
          end if
      else if (lin(i) .eq. 109) then    ! MOVECOM(109,'m')
          i = i + 1
          if (getone(lin,i,line3,status) .eq. -1) then ! EOF(-1)
              status = -3               ! ERR(-3)
          end if
          if (status .eq. -2) then      ! OK(-2)
              if (ckp(lin,i,pflag,status) .eq. -2) then ! OK(-2)
                  if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                      status = move(line3)
                  end if
              end if
          end if
      else if (lin(i) .eq. 115) then    ! SUBSTITUTE(115,'s')
          i = i + 1
          if (optpat(lin,i)) then
              if (getrhs(lin,i,sub,gflag) .eq. -2) then ! OK(-2)
                  if (ckp(lin,i+1,pflag,status) .eq. -2) then ! OK(-2)
                      if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                          status = subst(sub,gflag)
                      end if
                  end if
              end if
          end if
      else if (lin(i) .eq. 101) then    ! ENTER(101,'e')
          if (nlines .eq. 0) then
              if (getfn(lin,i,file) .eq. -2) then ! OK(-2)
                  call scopy(file,1,savfil,1)
                  call clrbuf
                  call setbuf
                  status = doread(0,file)
              end if
          end if
      else if (lin(i) .eq. 102) then    ! PRINTFIL(102,'f')
          if (nlines .eq. 0) then
              if (getfn(lin,i,file) .eq. -2) then ! OK(-2)
                  call scopy(file,1,savfil,1)
                  call putlin(savfil,6) ! STDOUT(6)
                  call putc(10)         ! NEWLINE(10)
                  status = -2           ! OK(-2)
              end if
          end if
      else if (lin(i) .eq. 114) then    ! READCOM(114,'r')
          if (getfn(lin,i,file) .eq. -2) then ! OK(-2)
              status = doread(line2,file)
          end if
      else if (lin(i) .eq. 119) then    ! WRITECOM(119'w')
          if (getfn(lin,i,file) .eq. -2) then ! OK(-2)
              if (defalt(1,lastln,status) .eq. -2) then
                  status = dowrit(line1,line2,file)
              end if
          end if
      else if (lin(i) .eq. 112) then    ! PRINT(112 'p')
          if (lin(i+1) .eq. 10) then    ! NEWLINE(10)
              if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                  status = doprnt(line1,line2)
              end if 
          end if
      else if (lin(i) .eq. 113) then    ! QUIT(113 'q')
          if ((lin(i+1) .eq. 10) .and.  ! NEWLINE(10)
     1       (nlines .eq. 0) .and. (glob .eq. 0)) then ! NO(0)
              status = -1               ! EOF(-1)
          end if
      ! else status is ERR
      end if

      if ((status .eq. -2) .and. (pflag .eq. 1)) then ! OK(-2) YES(1)
          status = doprnt(curln,curln)
      end if
      docmd = status
      return
      end
メインルーチンeidtは、標準入力から指令を読み取り、前処理を行い、問題がなければ、 docmd()を呼び出す。

editのRATFOR版は以下の通り。 

# edit.r4 (in memory) -- text editor
      program edit
      integer*1 getlin,lin(MAXLINE)
      integer getlst,doglob,docmd,ckglob,doread
      integer i,status,cursav
      integer getarg

      include cfile.fi
      include clines.fi
      include cpat.fi

      call initfile
      call setbuf

      pat(1) = EOS
      status = ERR

      if (getarg(1,savfil,MAXLINE != EOF)
          if (doread(0,savfil) == ERR)
              call remark('?.')

      while (getlin(lin,STDIN) != EOF) {
          i = 1
          cursav = curln
          if (getlst(lin,i,status) == OK)
              if (ckglob(lin,i,status) == OK)
                  status = doglob(lin,i,cursav,status)
              else if (status != ERR)
                  status = docmd(lin,i,NO,status)
              ! else error, do nothing

          if (status == ERR) {
               call remark('?.')
               curln = cursav
               }
          else if (status == EOF)
               break
          ! else OK, loop
          }
      call clrbuf

      stop
      end

WATCOM fortran77版は以下の通り。 

c edit.f (in memory) -- text editor
      program edit
      integer*1 getlin,lin(82)          ! MAXLINE(82)
      integer getlst,doglob,docmd,ckglob,doread
      integer i,status,cursav
      integer getarg

      include cfile.fi
      include clines.fi
      include cpat.fi

      call initfile
      call setbuf

      pat(1) = -2                       ! EOS(-2)
      status = -3                       ! ERR(-3)

      if (getarg(1,savfil,82) .ne. -1) then  ! MAXLINE(82) EOF(-1)
          if (doread(0,savfil) .eq. -3) then ! ERR(-3)
              call remark('?.')
          end if
      end if

      while (getlin(lin,5) .ne. -1) do  ! STDIN(5) EOF(-1)
          i = 1
          cursav = curln
          if (getlst(lin,i,status) .eq. -2) then       ! OK(-2)
              if (ckglob(lin,i,status) .eq. -2) then   ! OK(-2)
                  status = doglob(lin,i,cursav,status)
              else if (status .ne. -3) then            ! ERR(-3)
                  status = docmd(lin,i,0,status)       ! NO(0)
              ! else error, do nothing
              end if
          end if
          if (status .eq. -3) then      ! ERR(-3)
               call remark('?.')
               curln = cursav
          else if (status .eq. -1) then ! EOF(-1)
               exit
          ! else OK, loop
          end if
      end while
      call clrbuf

      stop
      end

by Kida Hiroya [コンピューター] [RATFOR] [コメント(50)｜トラックバック(0)]

コマンドの処理 ６ 広域指定gとx ― 2016年07月29日 15:18

指令a,c,i,qを除く任意の指令の前には、広域指定を 付けることができる。

広域指定gは、 

     g/文型/指令
とすると、文型に合致する各行について、指令を実行する。 広域指定xは、 
     x/文型/指令
とすると、文型に一致しない各行について、指令を実行する。 
     g/%#/p
では、RATFORの行頭から始まるコメント行を　すべて、印刷する。 
     x/%#/p
では、RATFORの行頭から始まるコメント行以外の行すべてを　印刷する。

広域指定は、まず、ckglob()で該当行のMARK位置にYESを記録する。 ついで、doglob()でMARK位置がYESの行について、docmd()で指令を実行する。

ckglob()のRATFOR版は以下の通り。 

# ckglob.r4 -- if global prefix, mark lines to be affected
      integer function ckglob(lin,i,status)
      character lin(MAXLINE)
      integer i,status
      integer defalt,getind,gettxt,nextln,optpat
      integer k,line,match,gflag

      include cbuf.fi
      include clines.fi
      include cpat.fi
      include ctxt.fi

      if (lin(i) != GLOBAL & lin(i) != EXCLUDE)
          status = EOF
      else {
          if (lin(i) == GLOBAL)
              gflag = YES
          else
              gflag = NO
          i = i + 1
          if (optpat(lin,i) == ERR | defalt(1,lastln,status) == ERR)
              status = ERR
          else {
              i = i + 1
              for (line = line1; line <= line2; line = line + 1) {
                  k = gettxt(line)
                  if ((match(txt,pat) == gflag)
                      call setgflag(buf(k+8),YES)
                  else
                      call setgflag(buf(k+8),NO)
                  }
              for (line = nextln(line2); line != line1; line = nextln(line)) {
                  k = getind(line)
                  call setgflag(buf(k+8),NO)
                  }
              status = OK
              }
          }
      ckglob = status
      return
      end

WATCOM fortran77版は以下の通り。 

c ckglob.f -- if global prefix, mark lines to be affected
      integer function ckglob(lin,i,status)
      integer*1 lin(81)                 ! MAXLINE(81)
      integer i,status
      integer defalt,getind,gettxt,nextln,optpat
      integer k,line,match,gflag

      include cbuf.fi
      include clines.fi
      include cpat.fi
      include ctxt.fi

      if (lin(i) .ne. 103               ! GLOBAL('g',103)
     1     .and. lin(i) .ne. 120) then  ! EXCLUDE('x',120)
          status = -1                   ! EOF(-1)
      else 
          if (lin(i) .eq. 103) then     ! GLOBAL('g',103)
              gflag = 1                 ! YES(1)
          else
              gflag = 0                 ! NO(0)
          end if
          i = i + 1
          if (optpat(lin,i) .eq. -3     ! ERR(-3)
     1        .or. defalt(1,lastln,status) .eq. -3) then ! ! ERR(-3)
              status = -3               ! ERR(-3)
          else
              i = i + 1
              line = line1
              while (line .le. line2) do
                  k = gettxt(line)
                  if (match(txt,pat) .eq. gflag) then
                      call setgflag(buf(k+8),1) ! YES(1)
                  else
                      call setgflag(buf(k+8),0) ! NO(0)
                  end if
                  line = line + 1
              end while
              line = nextln(line2)
              while (line .ne. line1) do
                  k = getind(line)
                  call setgflag(buf(k+8),0) ! NO(0)
                  line = nextln(line)
              end while
              status = -2               ! OK(-2)
          end if
      end if
      ckglob = status
      return
      end

doglob()のRATFOR版は以下の通り。 

# doglob.r4 -- do command at lin(i) on all marked lines
      integer function doglob(lin,i,cursav,status)
      character lin(MAXLINE)
      integer i,cursav,status
      integer docmd,getind,getlst,nextln
      integer getgflag
      integer count,istart,k,line

      include cbuf.fi
      include clines.fi

      status = OK
      count = 0
      line = line1
      istart = i
      repeat
          k = getind(line)
          if (getgflag(buf(k+MARK)) == YES) {
              call setgflag(buf(k+MARK),NO)
              curln = line
              cursav = curln
              i = istart
              if (getlst(lin,i,status) == OK) 
                  if (docmd(lin,i,YES,status) == OK)
                      count = 0
              }
          else {
              line = nextln(line)
              count = count + 1
              }
      until (count > lastln | status != OK)
      doglob = status
      return
      end

WATCOM fortran77版は以下の通り。 

c doglob.f -- do command at lin(i) on all marked lines
      integer function doglob(lin,i,cursav,status)
      integer*1 lin(82)                 ! MAXLINE(82)
      integer i,cursav,status
      integer docmd,getind,getlst,nextln
      integer getgflag
      integer count,istart,k,line

      include cbuf.fi
      include clines.fi

      status = -2                       ! OK(-2)
      count = 0
      line = line1
      istart = i
      loop
          k = getind(line)
          if (getgflag(buf(k+8)) .eq. 1) then  ! MARK(8) YES(1)
              call setgflag(buf(k+8),0) ! MARK(8) NO(0)
              curln = line
              cursav = curln
              i = istart
              if (getlst(lin,i,status) .eq. -2) then ! OK(-2)
                  if (docmd(lin,i,1,status) .eq. -2) then ! YES(1) OK(-2)
                      count = 0
                  end if
              end if
          else
              line = nextln(line)
              count = count + 1
          end if
      until ((count .gt. lastln) .or. (status .ne. -2)) ! OK(-2)
      doglob = status
      return
      end

by Kida Hiroya [コンピューター] [RATFOR] [コメント(50)｜トラックバック(0)]

コマンドの処理 ５ 入出力 ― 2016年07月20日 10:49

editは、 

     edit ファイル名

とすれば、指定されたファイル名のファイルがあれば、それをバッファに読み込み編集作業を 開始するようにする。ファイルがなければ、作成する。

さらに、ファイルの読み込み、書き込みのための指令を以下に示す。

読み込み指令は、バッファを空にしてから読み込む指令"e"と、現在のバッファーを 変更せずにその場所に読み込む"r"がある。 

     e ファイル名
     (.)r ファイル名

また、ファイルへの書き出し命令"w"がある。 

     (.,.)w ファイル名

編集中のファイルをすべて書き出すには、"1,$w ファイル名"とする。

ファイル名が一度指定されると、それを記憶できるようにしておくと便利である。 ファイル名を省略した場合、記憶してあるファイル名を使うことにする。このファイル名を 記憶する場所は、以下の通り。

RATFOR版を以下に示す。 

# cfile.ri -- remember file name
      common /cfile/savfil
      character savfil(MAXLINE) # remembered file name

WATCOM fortran77版を以下に示す。 

c cfile.fi -- remember file name
      common /cfile/savfil
      integer*1 savfil(82) ! remembered file name MAXLINE(82)

これらのコマンドのdocmd()の部分を　以下に示す。 

      else if (lin(i) == ENTER) {
          if (nlines == 0)
              if (getfn(lin,i,file) == OK) {
                  call scopy(file,1,savefil,1)
                  call clrbuf
                  call setbuf
                  status = doread(0,file)
                  }
          }
      else if (lin(i) == PRINTFIL) {
          if (nlines == 0)
              if (getfn(lin,i,file) == OK) {
                  call scopy(file,1,savefil,1)
                  call putlin(savefil,STDOUT)
                  call putc(NEWLINE)
                  status = OK
                  }
          }
      else if (lin(i) == READCOM) {
          if (getfn(lin,i,file) == OK)
              status = doread(line2,file)
          }
      else if (lin(i) == WRITECOM) {
          if (getfn(lin,i,file) == OK)
              if (defalt(1,lastn,status) == OK)
                  status = dowrit(line1,line2,file)
          }

getfn()はファイル名の取得と検査を行う。

RATFOR版は以下の通り。 

# getfn.r4 -- get file name lin(i)...
      integer function getfn(lin,i,file)
      character lin(MAXLINE),file(MAXLINE)
      integer i
      integer j,k

      include cfile.ri

      getfn = ERR
      if (lin(i+1) == BLANK)
          j = i + 2
          call skipbl(lin,j)
          for (k = 1; lin(j) != MEWLINE; k = k + 1) {
              file(k) = lin(j)
              j = J + 1
              }
          file(k) = EOS
          if (k > 1)
              getfn = OK
      else if (lin(i+1) == NEWLINE & savfil(1) != EOS) {
          call scopy(savfil,1,file,1) # or old one
          getfn = OK
      # else error
      if (getfn == OK & savfil(1) != EOS)
          call scopy(file,1,savfil,1) # save if no old one
      return
      end

WATCOM fortran77版は以下の通り。 

c getfn.f -- get file name lin(i)...
      integer function getfn(lin,i,file)
      integer*1 lin(81),file(81)        ! MAXLINE(81)
      integer i
      integer j,k

      include cfile.fi

      getfn = -3                        ! ERR(-3)
      if (lin(i+1) .eq. 32) then        ! BLANK(32)
          j = i + 2
          call skipbl(lin,j)
          k = 1
          while (lin(j) .ne. 10) do     ! NEWLINE(10)
              file(k) = lin(j)
              j = J + 1
              k = k + 1
          end while
          file(k) = -2                  ! EOS(-2)
          if (k .gt. 1) then
              getfn = -2                ! OK(-2)
          end if
      else if ((lin(i+1) .eq. 10) .and. (savfil(1) .ne. -2)) then ! NEWLINE(10) EOS(-2)
          call scopy(savfil,1,file,1)   ! or old one
          getfn = -2                    ! OK(-2)
      ! else error
      end if
      if ((getfn .eq. -2) .and. (savfil(1) .ne. -2)) then ! OK(-2) EOS(-2)
          call scopy(file,1,savfil,1)   ! save if no old one
      end if
      return
      end

doread()のRAFOR版は以下の通り。 

# doread.r4 -- read "file" after "line"
      integer function doread(line,file)
      integer line
      character file(MAXLINE)
      character lin(MAXLINE)
      integer getlin,inject
      integer count,fd
      integer fopen

      include clines.ri

      fd = fopen(fd,file,READ)
      if (fd == ERR)
          doread = ERR
      else {
          curln = line
          doread = OK
          for (count = 0; getlin(lin,fd) != EOF; count = count + 1) {
              doread = inject(lin)
              if (doread == ERR)
                  break
              }
          call fclose(fd)
          call putdec(count,1)
          call putc(NEWLINE)
          }
      return
      end

WATCOM fortran77版は以下の通り。 

c doread.f -- read "file" after "line"
      integer function doread(line,file)
      integer line
      integer*1 file(81)                ! MAXLINE(81)
      integer*1 lin(81)                 ! MAXLINE(81)
      integer getlin,inject
      integer count,fd
      integer fopen

      include clines.fi

      fd = fopen(fd,file,82)            ! READ(82)
      if (fd .eq. -3 ) then             ! ERR(-3)
          doread = -3                   ! ERR(-3)
      else
          curln = line
          doread = -2                   ! OK(-2)
          count = 0
          while (getlin(lin,fd) .ne. -1) do ! EOF(-1)
              doread = inject(lin)
              if (doread .eq. -3) then ! ERR(-3)
                  exit
              end if
              count = count + 1
          end while
          call fclose(fd)
          call putdec(count,1)
          call putc(10)               ! NEWLINE
      end if
      return
      end

dowrit()のRAFOR版は以下の通り。 

# dowrit.r4 -- write "from" through "to" into file
      integer function dowrit(from,to,file)
      integer from,to
      character file(MAXLINE)
      integer gettxt
      integer fcreate,fopen
      integer fd,k,line

      include ctxt.ri

      fd = fcreate(file)
      if (fd == ERR)
          dowrit = ERR
      else {
          fd = fopen(fd,file,WRITE)
          if (fd == ERR)
              dwrit = ERR
          else {
              for (line = from; line <= to; line = line + 1) {
                  k = gettxt(line)
                  call putlin(txt,fd)
                  }
              call fclose(fd)
              call putdec(to-from+1,1)
              call putc(NEWLINE)
              dowrit = OK
              }
          }
      return
      end

WATCOM fortran77版は以下の通り。 

c dowrit.f -- write "from" through "to" into file
      integer function dowrit(from,to,file)
      integer from,to
      integer*1 file(81)                ! MAXLINE(81)
      integer gettxt
      integer fcreate,fopen
      integer fd,k,line

      include ctxt.fi

      fd = fcreate(file)
      if (fd .eq. -3) then   ! ERR(-3)
          dowrit = -3                   ! ERR(-3)
      else
          fd = fopen(fd,file,87)        ! WRITE(87)
          if (fd .eq. -3 ) then         ! ERR(-3)
              dwrit = -3                ! ERR(-3)
          else
              line = from
              while (line .le. to) do
                  k = gettxt(line)
                  call putlin(txt,fd)
                  line = line + 1
              end while
              call fclose(fd)
              call putdec(to-from+1,1)
              call putc(10)             ! NEWLINE(10)
              dowrit = -2               ! OK(-2)
          end if
      end if
      return
      end

by Kida Hiroya [コンピューター] [RATFOR] [コメント(50)｜トラックバック(0)]

コマンドの処理 ３ COPY(修正版) ― 2016年07月03日 09:50

転写指令copy行の転写を行う。形式は、 

     (.,.)k行３

指定された範囲を行３の後ろに転写する。転写だから指令を"c"にしたいが、 すでに使ってしまったので、苦しいが"k"とする。 転写指令ののためのdocmdの該当部分は、以下の通り。 

      else if (lin(i) == COPYCMD) {
          i = i + 1
          if (getone(lin,i,line3,status) == EOF)
              status = ERR
          if (status == OK)
              if (ckp(lin,i,pflag,status) == OK)
                  if (defalt(curln,curln,status) == OK)
                      status = kopy(line3)
          }

実際の転写はkopy()で行う。

Kopy()のRATFOR版は、以下の通り。 

# kopy.r4 -- copy lines into aonother line
      integer function kopy(line3)
      integer line3
      integer line,junk
      integer gettxt,inject,nextln

      include ctxt.fi
      include clines.fi

      kopy = ERR
      if (line3 <= line1 | line3 < line2)
          return
      curln = line3
      for (line = line1; line <= line2; line = nextln(line)) {
          junk = gettxt(line)
          kopy = inject(txt)
      }
      return
      end

Kopy()のWATCOM fortran77版は、以下の通り。 

c kopy.f -- copy lines into aonother line
      integer function kopy(line3)
      integer line3
      integer line,junk
      integer gettxt,inject,nextln

      include ctxt.fi
      include clines.fi

      kopy = -3                         ! ERR(-3)
      if ((line3 .le. line1) .or. (line3 .lt. line2)) then
          return
      end if
      curln = line3
      line = line1
      while (line .le. line2) do
          junk = gettxt(line)
          kopy = inject(txt)
          line = nextln(line)
      end while
      return
      end

by Kida Hiroya [コンピューター] [RATFOR] [コメント(50)｜トラックバック(0)]

コマンドの処理 ２ MOVE ― 2016年06月30日 20:30

移動指令moveは文書行の並べ替えを行う。 

     /format/m/end/-1p
とすると、最初に見つけた"format"を含む行を　"end"を含む行の1行前に移動し、印刷する。

先に示したdocmdの該当部分は、つぎのようになる。 

      else if (lin(i) == MOVECOM) {
          i = i + 1
          if (getone(lin,i,line3,status) == EOF)
              status = ERR
          if (status == OK)
              if (ckp(lin,i,pflag,status) == OK)
                  if (defalt(curlin,curln,status) == OK)
                      status = move(line3)
          }

RATFOR版move()はは、以下の通り。 

# move.r4 -- move line1 through line2 after line3
      integer function move(line3)
      integer line3

      integer getind,nextln,prevln
      integer k0,k1,k2,k3,k4,k5

      include clines.ri

      if (line1 <= 0 | (line1 <= line3 & line3 <= line2)) then
         move = ERR
      else
          k0 = getind(prevln(line1))
          k3 = getind(nextln(line2))
          k1 = getind(line1)
          k2 = getind(line2)
          call relink(k0,k3,k0,k3)
          if (line3 < line1) {
              curln = line3
              line3 = line3 - (line2 - line1 + 1)
              }
          else
              curln = line3 + (line2 - line1 + 1)
          k4 = getind(line3)
          k5 = getind(nextln(line3))
          call relink(k4,k1,k2,k5)
          call relink(k2,k5,k4,k1)
          move = OK
      end if
      return
      end

WATCOM fortran 77版move()は、以下の通り。 

c move.f -- move line1 through line2 after line3
      integer function move(line3)
      integer line3

      integer getind,nextln,prevln
      integer k0,k1,k2,k3,k4,k5

      include clines.fi

      if ((line1 .le. 0)
     1 .or. (line1 .le. line3 .and. line3 .le. line2)) then
         move = -3                      ! ERR(-3)
      else
          k0 = getind(prevln(line1))
          k3 = getind(nextln(line2))
          k1 = getind(line1)
          k2 = getind(line2)
          call relink(k0,k3,k0,k3)
          if (line3 .gt. line1) then
              curln = line3
              line3 = line3 - (line2 - line1 + 1)
          else
              curln = line3 + (line2 - line1 + 1)
          end if
          k4 = getind(line3)
          k5 = getind(nextln(line3))
          call relink(k4,k1,k2,k5)
          call relink(k2,k5,k4,k1)
          move = -2                     ! OK(-2)
      end if
      return
      end

by Kida Hiroya [コンピューター] [RATFOR] [コメント(50)｜トラックバック(0)]

editメインルーチンdocmd() ― 2016年06月12日 11:09

編集機能は、一部の指令を除いて、基本的に個々の下請けルーチンで行う。 ここのルーチンに分岐するメインインルーチンがdocmd()である。長いけれど、コマンドを調べて 分岐するcase分けである。

挿入指令(.)i、変更指令(.,.)c、行番号打ち出し指令(.)=は、これまでのルーチンで実現できる。

挿入指令(.)iは、以下の通り。 

      else if (lin(i) == INSERT) {
          status = append(prevln(line2),glob)
          }

変更指令(.,.)cは、以下の通り。 

      else if (lin(i) == CHANGE) {
          if (lin(i+1) == NEWLINE)
              if (defalt(curln,curln,status) == OK)
                  if (delete(line1,line2,status) == OK)
                      status = append(prevln(line1),glob)
          }
S
行番号打ち出し指令(.)=は、以下の通り。 
      else if (lin(i) == PRINTCUR) {
          if (ckp(lin,i+1,pflag,status) == OK) {
              call putdec(line2,1)
              call putc(NEWLINE)
              }
          }

docmd()のRATFOR版を以下に示す。 

# docmd.r4 -- handle all commands except globals
      integer function docmd(lin,i,glob,status)
      character lin(MAXLINE)
      integer i,glob,status

      integer append,doprnt,defalt,nextln,prevln,move,ckp,getone
      integer dodel,getrhs,subst,getfn,doread,dowrit
      integer line3
      character file(MAXLINE)
      integer pflag,gflag,optpat

      include clines.ri
      include cfile.ri
      include cpat.ri

      pflag = NO
      status = ERR
      if (lin(i) == APPENDCOM) {
          if (lin(i+1) == NEWLINE)
              status = append(line2,glob)
          }
      else if (lin(i) == CHANGE) {
          if (lin(i+1) == NEWLINE)
              if (defalt(curln,curln,status) == OK)
                  if (delete(line1,line2,status) == OK)
                      status = append(prevln(line1),glob)
          }
      else if (lin(i) == DELETE) {
          if (ckp(lin,i+1,pflag,status) == OK)
              if (defalt(curln,curln,status) == OK)
                  if (dodel(line1,line2,status) == OK)
                      if (nextln(curln) == 0)
                          curln = nextln(curln)
          }
      else if (lin(i) == INSERT) {
          if (lin(i+1) == NEWLINE)
              status = append(prevln(line2),glob)
          }
      else if (lin(i) == PRINTCUR) {
          if (ckp(lin,i+1,pflag,status) == OK) {
              call putdec(line2,1)
              call putc(NEWLINE)
              }
          }
      else if (lin(i) MOVECOM) {
          i = i + 1
          if (getone(lin,i,line3,status) == EOF)
              status = ERR
          if (status == OK)
              if (ckp(lin,i,pflag,status) == OK)
                  if (defalt(curln,curln,status) ==OK)
                      status = move(line3)
          }
      else if (lin(i) == SUBSTITUTE) {
          i = i + 1
          if (optpat(lin,i) == OK)
              if (getrhs(lin,i,sub,gflag) == OK)
                  if (ckp(lin,i+1,pflag,status) == OK)
                      if (defalt(curln,curln,status) == OK)
                          status = subst(sub,gflag)
          }
      else if (lin(i) == ENTER) {
          if (nlines == 0) then
              if (getfn(lin,i,file) == OK) {
                  call scopy(file,1,savfil,1)
                  call clrbuf
                  call setbuf
                  status = doread(0,file)
              }
          }
      else if (lin(i) == PRINTFIL) {
          if (nlines == 0)
              if (getfn(lin,i,file) == OK) {
                  call scopy(file,1,savfil,1)
                  call putlin(savfil,STDOUT)
                  call putc(NEWLINE)
                  status = OK
              }
          }
      else if (lin(i) == READCOM) {
          if (getfn(lin,i,file) == OK)
              status = doread(line2,file)
          }
      else if (lin(i) ==WRITECOM) {
          if (getfn(lin,i,file) == OK)
              if (defalt(1,lastln,status) == OK)
                  status = dowrit(line1,line2,file)
              end if
          }
      else if (lin(i) == PRINT) {
          if (lin(i+1) == NEWLINE)
              if (defalt(curln,curln,status) == OK)
                  status = doprnt(line1,line2)
          }
      else if (lin(i) == QUIT) {
          if (lin(i+1) == NEWLINE & nlines == 0 & glob == NO)
              status = EOF
          }
      # else status is ERR
      end if

      if (status == OK & pflag == YES)
          status = doprnt(curln,curln)
      docmd = status
      return
      end

WATCOM Fortran77版は以下の通り。 

c docmd.f -- handle all commands except globals
      integer function docmd(lin,i,glob,status)
      integer*1 lin(82)                 ! MAXLINE(82)
      integer i,glob,status

      integer append,doprnt,defalt,nextln,prevln,move,ckp,getone
      integer dodel,getrhs,subst,getfn,doread,dowrit
      integer line3
      integer*1 file(82)                ! MAXLINE(82)
      integer pflag,gflag,optpat

      include clines.fi
      include cfile.fi
      include cpat.fi

      pflag = 0                         ! NO(0)
      status = -3                       ! ERR(-3)
      if (lin(i) .eq. 97) then          ! APPENDCOM(97 'a')
          if (lin(i+1) .eq. 10) then    ! NEWLINE(10)
              status = append(line2,glob)
          end if
      else if (lin(i) .eq. 99) then     ! CHANGE(99,'c')
          if (lin(i+1) .eq. 10) then    ! NEWLINE(10)
              if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                  if (delete(line1,line2,status) .eq. -2) then ! OK(-2)
                      status = append(prevln(line1),glob)
                  end if
              end if
          end if
      else if (lin(i) .eq. 100) then    ! DELETE(100,'d')
          if (ckp(lin,i+1,pflag,status) .eq. -2) then ! OK(-2)
              if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                  if (dodel(line1,line2,status) .eq. -2) then ! OK(-2)
                      if (nextln(curln) .ne. 0) then
                          curln = nextln(curln)
                      end if
                   end if
              end if
          end if
      else if (lin(i) .eq. 105) then    ! INSERT(105,'i')
          if (lin(i+1) .eq. 10) then    ! NEWLINE(10)
              status = append(prevln(line2),glob)
          end if
      else if (lin(i) .eq. 61) then     ! PRINTCUR(61,'=')
          if (ckp(lin,i+1,pflag,status) .eq. -2) then ! OK(-2)
              call putdec(line2,1)
              call putc(10)             ! NEWLINE(10)
          end if
      else if (lin(i) .eq. 109) then    ! MOVECOM(109,'m')
          i = i + 1
          if (getone(lin,i,line3,status) .eq. -1) then ! EOF(-1)
              status = -3               ! ERR(-3)
          end if
          if (status .eq. -2) then      ! OK(-2)
              if (ckp(lin,i,pflag,status) .eq. -2) then ! OK(-2)
                  if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                      status = move(line3)
                  end if
              end if
          end if
      else if (lin(i) .eq. 115) then    ! SUBSTITUTE(115,'s')
          i = i + 1
          if (optpat(lin,i)) then
              if (getrhs(lin,i,sub,gflag) .eq. -2) then ! OK(-2)
                  if (ckp(lin,i+1,pflag,status) .eq. -2) then ! OK(-2)
                      if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                          status = subst(sub,gflag)
                      end if
                  end if
              end if
          end if
      else if (lin(i) .eq. 101) then    ! ENTER(101,'e')
          if (nlines .eq. 0) then
              if (getfn(lin,i,file) .eq. -2) then ! OK(-2)
                  call scopy(file,1,savfil,1)
                  call clrbuf
                  call setbuf
                  status = doread(0,file)
              end if
          end if
      else if (lin(i) .eq. 102) then    ! PRINTFIL(102,'f')
          if (nlines .eq. 0) then
              if (getfn(lin,i,file) .eq. -2) then ! OK(-2)
                  call scopy(file,1,savfil,1)
                  call putlin(savfil,6) ! STDOUT(6)
                  call putc(10)         ! NEWLINE(10)
                  status = -2           ! OK(-2)
              end if
          end if
      else if (lin(i) .eq. 114) then    ! READCOM(114,'r')
          if (getfn(lin,i,file) .eq. -2) then ! OK(-2)
              status = doread(line2,file)
          end if
      else if (lin(i) .eq. 119) then    ! WRITECOM(119'w')
          if (getfn(lin,i,file) .eq. -2) then ! OK(-2)
              if (defalt(1,lastln,status) .eq. -2) then
                  status = dowrit(line1,line2,file)
              end if
          end if
      else if (lin(i) .eq. 112) then    ! PRINT(112 'p')
          if (lin(i+1) .eq. 10) then    ! NEWLINE(10)
              if (defalt(curln,curln,status) .eq. -2) then ! OK(-2)
                  status = doprnt(line1,line2)
              end if 
          end if
      else if (lin(i) .eq. 113) then    ! QUIT(113 'q')
          if ((lin(i+1) .eq. 10) .and.  ! NEWLINE(10)
     1       (nlines .eq. 0) .and. (glob .eq. 0)) then ! NO(0)
              status = -1               ! EOF(-1)
          end if
      ! else status is ERR
      end if

      if ((status .eq. -2) .and. (pflag .eq. 1)) then ! OK(-2) YES(1)
          status = doprnt(curln,curln)
      end if
      docmd = status
      return
      end

by Kida Hiroya [コンピューター] [RATFOR] [コメント(50)｜トラックバック(0)]