(*********************************************************************
 *  *** HAPPy PL/T P-code interpreter Version 0.0 ***                *
 *                                                                   *
 *          PL/T = Programming Language / Toy                        *
 *                                                                   *
 *        HAPPyのサンプルプログラム                                  *
 *          (作者  浅野比富美 Public Domain Software)                *
 *********************************************************************)
(*
　　このインタプリタは、ＰＬ／Ｔコンパイラでコンパイルしたオブジェクトを解
　釈実行する。
    なおこのソースコードは、標準Ｐａｓｃａｌの言語仕様の範囲内で書かれてい
  るので、他の環境に移植するのも容易にできるはずである。

    const,type,var の各部に * 印がついたものは、コンパイラ、逆アセンブラ、
  インタプリタ共通の定義項目である。
*)

program HAPPyPLTpCodeInterpreter(codef,cstf,input,output) ;

  label 9999 ;                          { プログラム出口          }

  const

{*} afterMST   =    4{word}   ;         { MST命令によるspの動き   }
{*} MaxCode    = 1000{番地}   ;         { P-code格納部上限        }
{*} MaxConst   = 1000{番地}   ;         { 定数格納部上限          }
    MaxData    = 6000{番地}   ;         { データ部上限            }

  type

   (*** P-codeオペレーションの定義 ***)
{*}  opType =
         ( iABS,  { absolute                             }
           iADD,  { add                                  }
           iCHK,  { check value                          }
           iCUP,  { call user procedure                  }
           iDIV,  { divide integers                      }
           iENT,  { enter procedure or function          }
           iEOF,  { eof standard function                }
           iEOL,  { eoln standard function               }
           iEQM,  { equal operator for multiple area     }
           iEQU,  { equal operator                       }
           iZJP,  { jump on zero                         }
           iFOR,  { start of for loop                    }
           iGEQ,  { grater than equal operator           }
           iGRT,  { grater than operator                 }
           iINC,  { increment                            }
           iIND,  { indirect fetch                       }
           iINX,  { indexed fetch                        }
           iIXA,  { indexed address                      }
           iLCA,  { load address of constant             }
           iLDA,  { load level p address                 }
           iLDC,  { load constant                        }
           iLEQ,  { less than equal operator             }
           iLES,  { less than operator                   }
           iLOD,  { load contents of address at level p  }
           iMOD,  { modulo operator                      }
           iMOV,  { move                                 }
           iMUL,  { multiple                             }
           iMST,  { mark stack                           }
           iNEG,  { negative                             }
           iNEM,  { not equal operator for multiple area }
           iNEQ,  { not equal operator                   }
           iNOT,  { logical not operator                 }
           iNXT,  { end of for loop                      }
           iRDC,  { read char                            }
           iRDI,  { read integer                         }
           iRET,  { return from procedure or function    }
           iRLN,  { readln standard procedure            }
           iSUB,  { subtract                             }
           iSTI,  { store indirect                       }
           iSTP,  { stop                                 }
           iSTR,  { store contents at address at level p }
           iUJP,  { uncondition jump                     }
           iWLN,  { writeln standard procedure           }
           iWRC,  { write char                           }
           iWRI,  { write integer                        }
           iWRS   { write string                         }
         ) ;

   (**** P-codeの形式定義 ****)
{*} pType = 0..255  ;                             { pオペランドの型    }
{*} qType = integer ;                             { qオペランドの型    }
{*} pCodeType = record
                  op : opType ;                   { 命令部             }
                  p  : pType  ;                   { pオペランド        }
                  q  : qType  ;                   { qオペランド        }
                end ;

{*} codeRange  =  0..MaxCode ;                    { P-code格納域範囲   }
    dataRange  =  0..MaxData ;                    { スタック範囲       }
    dataRange1 = -1..MaxData ;                    { スタック範囲(-1含) }

  (*** エラーメッセージ定義 ***)
    errorKind = (R001,R045,R046,R122) ;


  var

  (*** ファイル群 ***)
{*} codef   : file of pCodeType ;                 { P-codeファイル     }
{*} cstf    : file of char      ;                 { 定数ファイル       }

   (*** P-code仮想計算機記憶装置 ***)
{*} code    : array[codeRange]   of pCodeType ;   { P-code格納域       }
{*} cstTbl  : array[0..MaxConst] of char      ;   { 定数データ格納域   }
               { 現在のところ、文字列を格納する｡
                 各文字列の先頭に、文字列長が入っている構造をしている｡ }
    store   : array[dataRange] of integer   ;     { スタック域         }

   (*** P-code仮想計算機レジスタ ***)
    pc        : codeRange  ;            { プログラムカウンタ           }
    mp        : dataRange  ;            { スタック枠の始まりを保持する }
    sp        : dataRange1 ;            { スタックポインタ             }

(****************************)
(*   ﾗﾝﾀｲﾑｴﾗｰﾒｯｾｰｼﾞ出力処理 *)
(****************************)
  procedure runErr(kind : errorKind) ;
  begin
    writeln ;
    writeln('*** [ADDR=',pc-1:1,'] HAPPy PL/T Run-time error') ;
    write  ('-----  ');
    case kind of
      R001 : write('R001: 配列添字オーバー');
      R045 : write('R045: 0除算') ;
      R046 : write('R046: 剰余エラー');
      R122 : write('R122: スタック不足')
    end ;
    writeln(' : 処理打ち切り ***') ;
    goto 9999
  end ;

(****************************)
(*       解釈実行処理       *)
(****************************)
  procedure interpret ;
    label 2,3                  ;        { eqm,nem命令の終わり }
    var run       : Boolean    ;        { stp命令で偽になる   }
        test      : Boolean    ;        { fo,nxtr命令で使用   }
        ch        : char       ;        { rdc命令で使用       }
        ad,ad1    : dataRange  ;        { eqm,nqm,wrsで使用   }
        contAd    : dataRange  ;        { nxt命令で使用       }
        width     : integer    ;        { wrs命令で使用       }
        leng      : integer    ;        { wrs命令で使用       }
        i         : integer    ;        { for文カウンタ       }
        startVal  : integer    ;        { for,nxt命令で使用   }
        endVal    : integer    ;        { for,nxt命令で使用   }

  (**************************)
  (*  基準アドレス取得関数  *)
  (**************************)
    function base(p : integer) : dataRange ;
      var ad : dataRange ;
           i : integer   ;
    begin
      if p = 0 then base := mp
      else  begin
              ad := mp ;
              for i:=1 to p do ad := store[ad+1] ; { 静鎖をたどる }
              base := ad
            end
    end {base} ;

  begin {interpret}
    run   := true  ;

    while run do                        { stp 命令を実行するまで       }
      with code[pc] do
      begin
        pc := pc + 1 ;      { 命令をフェッチ後にﾌﾟﾛｸﾞﾗﾑｶｳﾝﾀを更新する  }

        case op of

          iABS :       (* absolute *)
                 store[sp] := abs(store[sp]) ;

          iADD : begin (* add *)
                   sp := sp - 1 ;
                   store[sp] := store[sp] + store[sp+1]
                 end ;

          iCHK :       (* check value *)
                 if store[sp] >= q then runErr(R001) ;

          iCUP : begin (* call user procedure *)
                   mp := sp - (p+3) ;
                   store[mp+3] := pc ;
                   pc := q
                 end ;

          iDIV : begin (* divide *)
                   if store[sp] = 0 then runErr(R045) ;     { 0除算 }
                   sp := sp - 1 ;
                   store[sp] := store[sp] div store[sp+1]
                 end ;

          iENT : begin (* enter procedure or function *)
                   if mp + p + q -1 > maxData then
                     runErr(R122) ;                         { スタック不足 }
                   sp := mp + q - 1
                 end ;

          iEOF : begin (* eof standard function *)
                   sp := sp + 1 ;
                   store[sp] := ord(eof(input))
                 end ;

          iEOL : begin (* eoln standard function *)
                   sp := sp + 1 ;
                   store[sp] := ord(eoln(input))
                 end ;

          iEQM : begin (* equal operator for multiple area *)
                   sp  := sp - 1 ;
                   ad  := store[sp] ;
                   ad1 := store[sp+1] ;
                   for i:=0 to q-1 do
                     if store[ad+i] <> store[ad1+i] then
                     begin
                       store[sp] := 0 ;
                       goto 2
                     end ;
                   store[sp] := 1 ;
                 2:
                 end ;

          iEQU : begin (* equal operator *)
                   sp := sp - 1 ;
                   store[sp] := ord(store[sp] = store[sp+1])
                 end ;

          iFOR : begin (* start of for loop *)
                   startVal := store[sp-1] ;
                   endVal   := store[sp]   ;
                   if p = 1 {to}     then test := startVal <= endVal
                            {downto} else test := startVal >= endVal ;
                   if test then store[store[sp-2]] := startVal {初期値を代入}
                   else
                   begin
                     sp := sp - 3 ;
                     pc := q
                   end
                 end ;

          iGEQ : begin (* grater than equal operator *)
                   sp := sp - 1 ;
                   store[sp] := ord(store[sp] >= store[sp+1])
                 end ;

          iGRT : begin (* grater than operator *)
                   sp := sp - 1 ;
                   store[sp] := ord(store[sp] > store[sp+1])
                 end ;

          iINC :       (* increment *)
                 store[sp] := store[sp] + q ;

          iIND :       (* indirect fetch *)
                 store[sp] := store[store[sp]] ;

          iINX : begin (* indexed fetch *)
                   sp := sp - 1 ;
                   store[sp] := store[store[sp]+store[sp+1]]
                 end ;

          iIXA : begin (* indexed address *)
                   sp := sp - 1 ;
                   store[sp] := store[sp] + store[sp+1] * q
                 end ;

          iLCA : begin (* load address of constant *)
                   sp := sp + 1 ;
                   store[sp] := q
                 end ;

          iLDA : begin (* load level p address *)
                   sp := sp + 1 ;
                   store[sp] := base(p) + q
                 end ;

          iLDC : begin (* load constant *)
                   sp := sp + 1 ;
                   store[sp] := q
                 end ;

          iLEQ : begin (* less than equal operator *)
                   sp := sp - 1 ;
                   store[sp] := ord(store[sp] <= store[sp+1])
                 end ;

          iLES : begin (* less than operator *)
                   sp := sp - 1 ;
                   store[sp] := ord(store[sp] < store[sp+1])
                 end ;

          iLOD : begin (* load contents of address at level p *)
                   sp := sp + 1 ;
                   store[sp] := store[base(p)+q]
                 end ;

          iMOD : begin (* modulo operator *)
                   if store[sp] <= 0 then runErr(R046) ; { 被演算子 <=0 }
                   sp := sp - 1 ;
                   store[sp] := store[sp] mod store[sp+1]
                 end ;

          iMOV : begin (* move *)
                   for i:=0 to q-1 do
                     store[store[sp-1]+i] := store[store[sp]+i] ;
                   sp := sp - 2
                 end ;

          iMUL : begin (* multiple *)
                   sp := sp - 1 ;
                   store[sp] := store[sp] * store[sp+1]
                 end ;

          iMST : begin (* mark stack *)
                   store[sp+2] := base(p) ;    { 静鎖 }
                   store[sp+3] := mp ;         { 動鎖 }
                   sp := sp + afterMST
                 end ;

          iNEG :       (* negative *)
                 store[sp] := -store[sp] ;

          iNEM : begin (* not equal operator for multiple area *)
                   sp  := sp - 1 ;
                   ad  := store[sp] ;
                   ad1 := store[sp+1] ;
                   for i:=0 to q-1 do
                     if store[ad+i] <> store[ad1+i] then
                     begin
                       store[sp] := 1 ;
                       goto 3
                     end ;
                   store[sp] := 0 ;
                 3:
                 end ;

          iNEQ : begin (* not equal operator *)
                   sp := sp - 1 ;
                   store[sp] := ord(store[sp] <> store[sp+1])
                 end ;

          iNOT :       (* logical not operator *)
                 if store[sp] = 0 then store[sp] := 1
                                  else store[sp] := 0 ;

          iNXT : begin (* next to *)
                   contAd := store[sp-2] ;
                   endVal := store[sp  ] ;
                   if p = 1 {to}     then test := store[contAd] < endVal
                            {downto} else test := store[contAd] > endVal ;
                   if test then
                   begin
                     if p = 1 then store[contAd] := store[contAd] + 1
                              else store[contAd] := store[contAd] - 1 ;
                     pc := q
                   end
                   else sp := sp - 3
                 end ;

          iRDC : begin (* read char *)
                   read(input,ch) ;
                   store[store[sp]] := ord(ch) ;
                   sp := sp - 1
                 end ;

          iRDI : begin (* read integer *)
                   read(input,store[store[sp]]) ;
                   sp := sp - 1
                 end ;

          iRET : begin (* return from procedure or function *)
                   if p = 0 then sp := mp - 1    { 手続きの戻り }
                   else                          { 関数  の戻り }
                   begin
                     store[mp] := store[sp] ;
                     sp := mp
                   end ;
                   pc := store[mp+3] ;
                   mp := store[mp+2]
                 end ;

          iRLN :       (* readln standard procedure *)
                 readln(input) ;

          iSUB : begin (* subtract *)
                   sp := sp - 1 ;
                   store[sp] := store[sp] - store[sp+1]
                 end ;

          iSTI : begin (* store indirect *)
                   store[store[sp-1]] := store[sp] ;
                   sp := sp - 2
                 end ;

          iSTP :       (* stop *)
                 run := false ;

          iSTR : begin (* store contents at address at level p *)
                   store[base(p)+q] := store[sp] ;
                   sp := sp - 1
                 end ;

          iUJP :       (* uncondition jump *)
                 pc := q ;

          iWLN :       (* writeln standard procedure *)
                writeln(output)  ;

          iWRC : begin (* write char *)
                   write(output,chr(store[sp-1]):store[sp]) ;
                   sp := sp -2
                 end ;

          iWRI : begin (* write integer *)
                   write(output,store[sp-1]:store[sp]) ;
                   sp := sp - 2
                 end ;

          iWRS : begin (* write string *)
                   width := store[sp]   ;
                   ad    := store[sp-1] ;
                   leng  := ord(cstTbl[ad]) ;
                   if width > leng then write(output,' ':width-leng)
                                   else leng := width ;
                   for i:=1 to leng do write(output,cstTbl[ad+i]) ;
                   sp := sp - 2
                 end ;

          iZJP : begin (* jump on zero *)
                   if store[sp] = 0 then pc := q ;
                   sp := sp - 1
                 end ;

        end {case op}
      end {with code[pc]}
  end {interpret} ;

(****************************)
(*      初期設定処理        *)
(****************************)
  procedure initialize ;
    var cc,i    : integer   ;
        dc      : integer   ;
        cstFlag : Boolean   ;
  begin
   (*** コードファイルの読み込み ***)
    reset(codef) ;
    cc := -1     ;
    while not eof(codef) do
    begin
      cc := cc + 1 ;
      read(codef,code[cc])
    end ;
    cstFlag := false ;             { 定数部を参照するlca命令があるか調べる }
    for i:=0 to cc do
      if code[i].op = iLCA then cstFlag := true ;

   (*** 定数ファイルの読み込み ***)
    if cstFlag then                { 定数部がなければ読み込まない          }
    begin
      reset(cstf) ;
      dc := 0     ;
      while not eof(cstf) do
      begin
        read(cstf,cstTbl[dc]) ;
        dc := dc + 1
      end
    end ;

   (*** レジスタ初期設定 ***)
    pc :=  0 ;
    mp :=  0 ;
    sp := -1
  end {initialize} ;

(****************************)
(*       メイン処理         *)
(****************************)
begin
  initialize ;                          { 初期設定 }
  interpret  ;                          { 解釈実行 }
9999:
end.