(*********************************************************************
 *  *** HAPPy PL/T Compiler Version 0.0 ***                          *
 *                                                                   *
 *          PL/T = Programming Language / Toy                        *
 *                                                                   *
 *        HAPPyのサンプルプログラム                                  *
 *          (作者  浅野比富美 Public Domain Software)                *
 *********************************************************************)
(*
  　標準Ｐａｓｃａｌ処理系ＨＡＰＰｙを使って、簡単なコンパイラを作ってみた
  い、という夢は、このような形で実現した。
  　ターゲット言語は、ＰＬ／Ｔ（Programming Language/ Toyの略)という。
　　ＰＬ／Ｔは、強い型付けを持つＰａｓｃａｌから型をとった単純な構造の言語
　で、実用言語ではないが、トイプログラムを作ることはできる。
　　言語処理系の規模が小さいので、言語処理系の入門には適している。
　　このコンパイラは、ＰＬ／Ｔソースを、１パスで独自のＰ−ｃｏｄｅにコンパ
　ルする。できたＰ−ｃｏｄｅは専用のインタプリタで解釈実行する。
    なおこのソースコードは、標準Ｐａｓｃａｌの言語仕様の範囲内で書かれてい
  るので、他の環境に移植するのも容易にできるはずである。

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

program HAPPyPLTcompiler(source,codef,cstf,output) ;

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

  const

{*} afterMST   =    4{word}   ;         { MST命令によるspの動き   }
{*} MaxCode    = 1000{番地}   ;         { P-code格納部上限        }
{*} MaxConst   = 1000{番地}   ;         { 定数格納部上限          }
    MaxLabel   =  100{個}     ;         { アセンブルラベル部上限  }
    MaxLevel   =   10{レベル} ;         { 手続き/関数の最大ネスト }
    MaxIDleng  =   10{文字}   ;         { 最大名前識別長          }
    MaxStrLeng =   70{文字}   ;         { 文字列格納域上限        }
    TabSize    =    8{幅}     ;         { 水平タブの幅            }

  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格納域範囲   }

   (**** 入力記号の種類 ****)
    symbol = (  (* 予約語
                     現在は予約語検査に単純リニアサーチをしているので
                     出現頻度の高い順にならべておく*)
              beginSy,  endSy,
              ifSy,     thenSy,
              whileSy,  doSy,
              elseSy,
              forSy,    toSy,
              repeatSy, untilSy,
              returnSy,
              downtoSy,
              procSy,   funcSy,
              varSy,    constSy,
                (* その他 *)
              identSy,                          { 名前                      }
              intconstSy,stringSy,              { 整数定数  文字列          }
              notOp,mulOp,addOp,relOp,          { 否定･乗法･加法･関係演算子 }
              lParent,rParent,                  { (   )                     }
              lBrack,rBrack,                    { [   ]                     }
              colon,dollar,                     { :   $                     }
              comma,semicolon,period,becomes) ; { ,   ;   .   :=            }

    rsvType = beginSy..constSy ;                { 予約語部分範囲            }
    opeType = (equ,neq,les,leq,grt,geq,         {  =   <>   <   <=   >   >= }
               add,sub,mul,divi,modd,           {  +   -    *   /    %      }
               noOp) ;                          { 演算子でない              }

   (*** 配列情報表 ***)
    aryPtType = ^aryType ;
    aryType   = record
                  next  : aryPtType ;             { 次の要素                }
                  eleNo : integer   ;             { 要素数                  }
                  size  : integer                 { この配列全体の大きさ    }
                end ;

   (*** 名前表 ***)
    idType     = packed array[1..MaxIDleng] of char ; { 名前の型 (文字列型) }
    idClass    = (konst,vars,proc,func);{ 名前の種類 (定数,変数,手続き,関数)}
    setIdClass = set of idClass ;       { 名前のサーチ処理で使用            }
    pfDclType  = (standard,declared) ;  { 手続き･関数の種別 (標準,宣言 )    }
    stdPF      = (pWrite,pWriteln,      { 標準手続き/標準関数の種類         }
                  pRead, pReadln,
                  pHalt,
                  fEof,  fEoln,
                  fAbs) ;
    idTblPtType = ^idTblType ;
    idTblType = record                            { 名前表                  }
                  name  : idType ;                { 名前                    }
                  llink : idTblPtType ;           { 小さい名前へのリンク    }
                  rlink : idTblPtType ;           { 大きい名前へのリンク    }
                  next  : idTblPtType ;           { proc/funcの引数リスト   }
                  case class : idClass of         { 名前のクラス            }
                    konst : (value : integer)  ;  { 定数 値                 }
                    vars  : (vlev  : integer   ;  { 変数 定義水準           }
                             adr   : integer   ;  {     割り付け番地        }
                             aptr  : aryPtType);  {     配列情報アドレス
                                                          配列でない時 nil  }
                    proc,                         { 手続き/関数             }
                    func  : (case pfDclKind : pfDclType of
                               standard : (pfId    : stdPF)   ; { 識別ID    }
                               declared : (pflev   : integer  ; { 定義水準  }
                                           pfLabel : integer) ; { ラベル名  }
                            )
                end ;

   (*** 式の関する定義 ***)
     expKind = (cst,varbl,expr) ;
     attr    = record
                 aryPtr    : aryPtType ;                 {  配列情報リンク  }
                 case kind : expKind of
                   cst   : (cval   : integer) ;          { 定数値           }
                   varbl : (access : (direct,indirect) ; { アクセス種別     }
                            disp   : integer  ;          { 変位             }
                            lev    : integer) ;          { 定義水準         }
                   expr  : (                ) ;
                 end ;

  (**** エラーメッセージの種類 ****)
    msgKind = (E002,E004,E006,E009,E012,E013,E014,E016,
               E017,E021,E030,E051,E052,E053,E054,E055,
               E058,E070,E101,E103,E104,E116,E125,E126,
               E129,E134,E138,E143,E144,E146,E148,E176,
               E188,E195,E202,E203,E205,E602,E604,E610,
               A001,A004,A005) ;


  var

  (*** 入出力ファイル ***)
    source  : text ;                              { PL/Tソースファイル }
{*} 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      ;   { 定数データ格納域   }
               { 現在のところ、文字列を格納する｡
                 各文字列の先頭に、文字列長が入っている構造をしている｡ }
    cstIndex: integer ;                           { 定数格納域指標     }
    cdIndex : integer ;                           { P-code格納域指標   }

    chTable : array[char] of                       { 文字表            }
                (space,number,alpha,
                 quotation,chLpar,chColon,chLt,chGt,
                 special,illegal) ;
    rsv     : array[rsvType] of idType  ;          { 予約語表          }
    spx     : array[opType]  of integer ;          { P-codeのsp増減数表}

    labelTab : array[0..MaxLabel] of    { ラベル表  添字はラベル番号   }
                 record
                   val : -1..MaxCode ;  { undefined ･･･ 同一ﾗﾍﾞﾙをﾘﾝｸ  }
                                        { defined   ･･･ ラベル値       }
                   st  : (undefined  ,  { 未定義状態                   }
                          defined)      { ラベルが定義れれた           }
                 end ;

    display    : array[0..MaxLevel] of idTblPtType ;{ 水準別名前リスト }
    dLevel     : integer ;              { 現在の名前定義水準           }

    gattr      : attr    ;              { 現在処理している式の属性     }

    dataAdr    : integer ;              { データ割りつけアドレス       }
    maxStk     : integer ;              { 最大sp増加値                 }
    newStk     : integer ;              { 現在のsp増減値               }

    labelV     : integer ;              { アセンブルラベル値           }
    mainLabel  : integer ;              { メインブロックの開始ラベル   }
    exitLabel  : integer ;              { ブロックの出口ラベル         }
    entAd      : integer ;              { ent命令アドレス              }

    spaceId    : idType  ;              { 名前エリアの初期化用         }
    ch         : char    ;              { PL/Tソース読み込み用         }
    debug      : Boolean ;              { デバックオプションフラグ     }
    lineNum    : integer ;              { PL/Tソースの行番号           }
    curLineNum : integer ;              { 今読んだ記号の行番号         }
    colum      : integer ;              { PL/Tソースのカラム位置       }
    curColum   : integer ;              { 今読んだ記号のカラム位置     }
    eofFlag    : Boolean ;              { eof検出時 真                 }

   (*** 記号入力処理 inSymbol の 戻り値 ***)
    sy  : symbol  ;                     { 入力した記号種別             }
    vi  : integer ;                     { 整数定数値
                                             intconstSyの時有効        }
    ope : opetype ;                     { 演算子の種類
                                             addOp,mulOp,relOpの時有効 }
    str : array[0..MaxStrLeng] of char; { 文字列格納域
                                                str[0]は文字列長
                                                stringSyの時有効       }
    id  : idType  ;                     { 名前   identSyの時有効       }


(****************************)
(*       エラー処理         *)
(****************************)
(* 継続してエラー検出するためには、エラーリカバリの仕組みを作る必要があり、
   構造が複雑になってしまう。それを避けるため、このコンパイラでは、エラーが
   発生すると即コンパイルを打ち切るようにした。*)
  procedure error(kind : msgKind) ;
  begin
    writeln ;
    write(curLineNum:1,'行 ',curColum:1,'カラム付近 : ') ;
    case kind of
      E002 : write('E002: 名前が必要');
      E004 : write('E004: '')'' が必要');
      E006 : write('E006: 不当な記号が現れた');
      E009 : write('E009: ''('' が必要');
      E012 : write('E012: '']'' が必要');
      E013 : write('E013: endが必要');
      E014 : write('E014: '';'' が必要');
      E016 : write('E016: ''='' が必要');
      E017 : write('E017: beginが必要');
      E021 : write('E021: ''.'' が必要');
      E030 : write('E030: 不当文字が現れた');
      E051 : write('E051: := が必要');
      E052 : write('E052: thenが必要');
      E053 : write('E053: untilが必要');
      E054 : write('E054: doが必要');
      E055 : write('E055: toあるいはdowntoが必要');
      E058 : write('E058: 項(因子)誤り');
      E070 : write('E070: 配列の要素数誤り');
      E101 : write('E101: 名前(',id,')が再度定義された');
      E103 : write('E103: 名前(',id,')の持つ意味が不適当');
      E104 : write('E104: 名前(',id,')が定義されていない');
      E116 : write('E116: 標準手続きの引数に誤り');
      E125 : write('E125: 標準関数の引数に誤り');
      E126 : write('E126: 実引数と仮引数が不一致');
      E129 : write('E129: 代入不可能');
      E134 : write('E134: 演算対象誤り');
      E138 : write('E138: 配列の次元が宣言と違う');
      E143 : write('E143: 関係演算子の演算対象誤り');
      E144 : write('E144: for文の初期値あるいは終値誤り');
      E146 : write('E146: 条件式誤り');
      E148 : write('E148: 配列の添字範囲外');
      E176 : write('E176: 関数はreturn文が1つは必要');
      E188 : write('E188: for文制御変数誤り');
      E195 : write('E195: return文戻り値誤り');
      E202 : write('E202: 文字列は行をまたがれない');
      E203 : write('E203: 整数定数の最大値を越た');
      E205 : write('E205: 長さ0の文字列は許されない');
      E602 : write('E602: 文字列が長すぎる');
      E604 : write('E604: 手続き/関数の入れ子が深い');
      E610 : write('E610: プログラム終了前にEOF検出');
      A001 : write('A001: P-code命令数オーバー');
      A004 : write('A004: 内部ラベル数オーバー');
      A005 : write('A005: 定数テーブルオーバー');
    end ;
    writeln ;
    writeln('**** Fail in compile ****') ;
    goto 9999                                     { プログラム停止 }
  end ;

(*==========================================================================*)
(*                      語彙解析部 (記号入力処理)                           *)
(*==========================================================================*)
  procedure inSymbol ;
    var stringFlag : Boolean ;             { 文字列処理中の時 真       }

  (**************************)
  (*   次の文字入力処理     *)
  (**************************)
    procedure nextCh ;
    begin
      if eofFlag then error(E610) ;        { EOF検出                   }
      eofFlag := eof(source) ;
      if not eofFlag then
        if eoln(source) then
        begin
          if stringFlag then error(E202) ; { 文字列は行を越えられない  }
          lineNum := lineNum + 1 ;
          colum := 0 ;
          write('.') ;                     { コンパイルの様子を示す    }
          if lineNum mod 50 = 1 then writeln ;
          ch := ' ' ;                      { 空白に置き換え            }
          readln(source)
        end
        else                               { 行末でない通常の読み込み  }
        begin
          read(source,ch) ;
          if ch = chr(9) then              { 水平タブ                  }
          begin
            colum := (colum + TabSize) div TabSize * TabSize ;
                                           { タブサイズ分進める        }
            ch    := ' '                   { 空白に置き換え            }
          end
          else colum := colum + 1
        end
    end ;

  (**************************)
  (*       数字の処理       *)
  (**************************)
    procedure numbers ;
      var wi : integer ;
    begin
      sy := intconstSy ;
      vi := 0 ;
      repeat
        wi := ord(ch) - ord('0') ;
        if vi > (Maxint - wi) div 10 then error(E203) ; { 数値オーバー }
        vi  := 10 * vi + wi ;
        nextCh
      until chTable[ch] <> number
    end ;

  (**************************)
  (*      名前の処理        *)
  (**************************)
    procedure idents ;
      label 9 ;
      const Aord  = 65  ;                         { ord('A')    }
            SPord = 32  ;                         { ord(' ')    }
      var   s : rsvType ;
            i : integer ;
            w : integer ;
    begin
      id := spaceId ;                             { 空白クリア }
      i  := 0 ;
      repeat
        if i < MaxIDleng then
        begin
          i := i + 1 ;
          w := ord(ch) ;
          if w - Aord in [0{'A'}..25{'Z'}] then
            ch := chr(w + SPord) ;                { 小文字変換 }
          id[i] := ch
        end ;
        nextCh
      until not (chTable[ch] in [alpha,number]) ;
      sy := identSy ;

     (* 予約語かどうか調べる *)
      for s := beginSy to constSy do   { 単純リニアサーチ               }
        if id = rsv[s] then            {   気になる人はもっと良い方法で }
          begin sy := s ; goto 9 end ; {   どうぞ･･･                    }
   9:
    end ;

  (**************************)
  (*      文字列の処理      *)
  (**************************)
    procedure strings ;
      var i : integer ;
    begin
      i := 0 ;
      repeat
        stringFlag := true ;                     { nextChで使うフラグ   }
        repeat
          nextCh ;
          if i = MaxStrLeng then error(E602) ;   { 文字列が長すぎる｡
                   最後の ' も格納するので最大文字列長はMaxStrLeng未満  }
          i := i + 1 ;
          str[i] := ch
        until ch = '''' ;                { '自身は ''と指定するため     }
        stringFlag := false ;
        nextCh
      until ch <> '''' ;
      i := i - 1 ;                                { 最後の ' を取り除く }
      if i = 0 then error(E205) ;                 { 長さ0の文字列は駄目 }
      str[0] := chr(i) ;                          { 文字列長設定        }
      sy := stringSy
    end ;

  (**************************)
  (*      左括弧の処理      *)
  (**************************)
    procedure lpars ;

    (************************)
    (*  注釈読み飛ばし処理  *)
    (************************)
      procedure skipComment ;
      begin
        nextCh ;
       (* コンパイラオプションの処理 *)
        if ch = '$' then
        begin
          nextCh ;
          if ch = 'd' then                        { デバッグオプション      }
          begin                                   { d- ･･･チェックなし      }
            nextCh ;                              { d+ ･･･ 配列添字チェック }
            if      ch = '+' then debug := true   { dの次が+,-以外はﾃﾞﾊﾞｯｸﾞ }
            else if ch = '-' then debug := false  { ｵﾌﾟｼｮﾝとみなさない      }
          end
        end ;

        repeat
          while ch <> '*' do nextCh ;
          nextCh
        until ch = ')' ;
        nextCh ;
        inSymbol                                  { 再帰によって記号を読む  }
      end (* skipComment *) ;

    begin (* lpras *)
      nextCh ;
      if ch = '*' then skipComment
                  else sy := lParent
    end ;

  (**************************)
  (*      コロンの処理      *)
  (**************************)
    procedure colons ;
    begin
      nextCh ;
      if ch = '=' then
        begin sy := becomes ; nextCh end          { := }
      else sy := colon                            { :  }
    end ;

  (**************************)
  (*       < の処理         *)
  (**************************)
    procedure lts ;
    begin
      sy := relOp ;
      nextCh ;
      if      ch = '=' then
        begin ope := leq ; nextCh end             { <= }
      else if ch = '>' then
        begin ope := neq ; nextCh end             { <> }
      else    ope := les                          { <  }
    end ;

  (**************************)
  (*       > の処理         *)
  (**************************)
    procedure gts ;
    begin
      sy := relOp ;
      nextCh ;
      if      ch = '=' then
        begin ope := geq ; nextCh end             { >= }
      else ope := grt                             { >  }
    end ;

  (**************************)
  (*    特別な文字の処理    *)
  (**************************)
    procedure specials ;
    begin
      case ch of
        '+' : begin sy := addOp ;  ope := add    end ;
        '-' : begin sy := addOp ;  ope := sub    end ;
        '*' : begin sy := mulOp ;  ope := mul    end ;
        '/' : begin sy := mulOp ;  ope := divi   end ;
        '%' : begin sy := mulOp ;  ope := modd   end ;
        '=' : begin sy := relOp ;  ope := equ    end ;
        '!' : sy := notOp     ;
        '$' : sy := dollar    ;
        '.' : sy := period    ;
        ',' : sy := comma     ;
        ';' : sy := semicolon ;
        ')' : sy := rParent   ;
        '[' : sy := lBrack    ;
        ']' : sy := rBrack    ;
       end ;
       nextCh
     end ;

(****************************)
(*    記号入力処理メイン    *)
(****************************)
  begin (* inSymbol *)
    stringFlag := false ;
    while ch = ' ' do nextCh ;               { 空白読み飛ばし               }
    curLineNum := lineNum ;                  { これから読む記号の位置を退避 }
    curColum   := colum   ;                  {   (エラーメッセージ用)       }
    case chTable[ch] of
      number    : numbers ;                  { 数字   }
      alpha     : idents  ;                  { 英字   }
      quotation : strings ;                  { '      }
      chLpar    : lpars   ;                  { (      }
      chColon   : colons  ;                  { :      }
      chLt      : lts     ;                  { <      }
      chGt      : gts     ;                  { >      }
      special   : specials;                  { 特殊   }
      illegal   : error(E030)                { 不当文字が現れた }
    end
  end ;

(*==========================================================================*)
(*                        意味解析に関する処理群                            *)
(*==========================================================================*)

(****************************)
(*      名前の登録処理      *)
(****************************)
  procedure enterId(fcp : idTblPtType) ;
    var lcp,lcp1 : idTblPtType ;
        left     : Boolean ;
  begin
    lcp := display[dLevel] ;
    if lcp = nil then display[dLevel] := fcp
    else
    begin
      repeat
        lcp1 := lcp ;
        if lcp^.name = fcp^.name then error(E101) { 名前の再定義       }
        else if lcp^.name < fcp^.name then  { 登録する名前の方が大きい }
          begin lcp := lcp^.rlink ; left := false  end
        else
          begin lcp := lcp^.llink ; left := true   end
      until lcp = nil ;
      if left then lcp1^.llink := fcp
              else lcp1^.rlink := fcp
    end ;
    fcp^.llink := nil ;
    fcp^.rlink := nil ;
    fcp^.next  := nil
  end ;

(****************************)
(*     名前のサーチ処理     *)
(****************************)
  function searchId(kind:setIdClass) : idTblPtType ;
    label 9 ;
    var lev : integer ;
        lcp : idTblPtType ;
  begin
    for lev:=dLevel downto 0 do                  { ブロックの中の方が優先 }
    begin
      lcp := display[lev] ;
      while lcp <> nil do
        if      id = lcp^.name then
          if lcp^.class in kind then goto 9      { 見つかった             }
                                else error(E103) { 名前の持つ意味が不適当 }
        else if id > lcp^.name then lcp := lcp^.rlink
        else     { < }              lcp := lcp^.llink
    end ;
    error(E104) ;                                { 名前が定義されていない }
 9: searchId := lcp ;
  end ;

  (****************************)
  (*  配列構造同値チェック関数*)
  (****************************)
  (* PL/Tでは型名がないので、型の適合に名前同値は使えない。
     配列の構造が同じであるかで、代入可能等のチェックを行っている。
     構造が違う時，真を返す。*)
    function notCompatible(ap1,ap2 : aryPtType) : Boolean ;
      var ok : Boolean ;
    begin
      ok := true ;
      while ok and (ap1 <> nil) and (ap2 <> nil) do
      begin
        ok  := ap1^.eleNo = ap2^.eleNo ;
        ap1 := ap1^.next ;
        ap2 := ap2^.next
      end ;
      notCompatible := not (ok and (ap1 = nil) and (ap2 = nil))
    end ;

(*==========================================================================*)
(*                        ここよりコード生成部                              *)
(*==========================================================================*)

(****************************)
(*     ラベル生成処理       *)
(****************************)
  function creLabel : integer ;
  begin
    if labelV > MaxLabel then error(A004) ; { ラベル数超過             }
    with labelTab[labelV] do
    begin
      val := -1 ;                 { ﾗﾍﾞﾙ未定義時の同一ﾗﾍﾞﾙﾘﾝｸの終了ﾏｰｸ }
      st  := undefined            { 未定義の意味                       }
    end ;
    creLabel := labelV ;
    labelV   := labelV + 1
  end ;

(****************************)
(*    ラベルの定義処理      *)
(****************************)
  procedure putLabel(labelNum : integer) ;
    var cur,nxt : integer ;
  begin
    with labelTab[labelNum] do
    begin
      if val <> -1 then                 { 前方参照がある場合           }
      begin
        cur := val ;
        repeat                          { 前方参照を順次解決していく   }
          nxt := code[cur].q ;
          code[cur].q := cdIndex + 1 ;
          cur := nxt
        until nxt = -1
      end ;
      st  := defined ;
      val := cdIndex + 1                { 現在のアドレスがラベル値     }
    end
  end ;

(****************************)
(*    ラベルの参照処理      *)
(****************************)
  procedure labelSearch(labelNum : integer) ;
  begin
    with labelTab[labelNum] do
      if st = undefined then
      begin
        code[cdIndex].q := val ;        { 前方参照のためアドレスリンク }
        val := cdIndex
      end
      else code[cdIndex].q := val       { 定義済の時は　ラベル値を設定 }
  end {labelSearch} ;

(****************************)
(*  コード(op部)出力処理    *)
(****************************)
  procedure putCode(mnemonic : opType) ;
  begin
    cdIndex := cdIndex + 1 ;
    if cdIndex > MaxCode then error(A001) ;       { 命令数が多すぎる }
    with code[cdIndex] do
    begin
      op := mnemonic ;
      p  := 0 ;
      q  := 0
    end ;
    newStk := newStk + spx[mnemonic]  ;
    if newStk > maxStk then maxStk := newStk      { 最大のsp増加数を得る }
  end ;

(****************************)
(* ジャンプ関連命令出力処理 *)
(****************************)
  procedure putJump(mnemonic: opType; value: integer) ;
  begin
    putCode(mnemonic) ;
    labelSearch(value)
  end ;

(****************************)
(*pｵﾍﾟﾗﾝﾄﾞのみの命令出力処理*)
(****************************)
  procedure putCodeP(mnemonic: opType; fp: pType) ;
  begin
    putCode(mnemonic) ;
    code[cdIndex].p := fp
  end ;

(****************************)
(*qｵﾍﾟﾗﾝﾄﾞのみの命令出力処理*)
(****************************)
  procedure putCodeQ(mnemonic: opType; fq: qType) ;
  begin
    putCode(mnemonic) ;
    code[cdIndex].q := fq
  end ;

(******************************)
(*p,qｵﾍﾟﾗﾝﾄﾞがある命令出力処理*)
(******************************)
  procedure putCodePQ(mnemonic: opType; fp: pType; fq: qType) ;
  begin
    putCode(mnemonic) ;
    with code[cdIndex] do
    begin
      p := fp ;
      q := fq
    end
  end ;

(**********************************)
(* ﾗﾍﾞﾙｵﾍﾟﾗﾝﾄﾞがある命令出力処理  *)
(**********************************)
  procedure putCodeL(mnemonic: opType; flabel: integer) ;
  begin
    putCode(mnemonic) ;
    labelSearch(flabel)
  end ;

(***********************************)
(* p,ﾗﾍﾞﾙｵﾍﾟﾗﾝﾄﾞがある命令出力処理 *)
(***********************************)
  procedure putCodePL(mnemonic: opType; fp: pType; flabel: integer) ;
  begin
    putCode(mnemonic) ;
    code[cdIndex].p := fp ;
    labelSearch(flabel)
  end ;

(****************************)
(*     ent命令出力処理      *)
(****************************)
  procedure putENT ;
  begin
    putCode(iENT) ;
    entAd := cdIndex                    { ent命令ｱﾄﾞﾚｽはentOperandで使用 }
  end ;

(****************************)
(*     lca命令出力処理      *)
(****************************)
(*   str[0] : 文字列長   qオペランドには文字列長エリアを指すようにする。
     cstIndex は 現在の定数エリア最終使用済場所+1を示す。*)
  procedure putLCA  ;
    var i : integer ;
  begin
    putCode(iLCA) ;
    if cstIndex + ord(str[0]) > MaxConst then
      error(A005) ;                               { 定数ﾃｰﾌﾞﾙｵｰﾊﾞｰ       }
    code[cdIndex].q := cstIndex ;                 { 文字列長エリアを指す }
    for i:=0 to ord(str[0])+1 do
    begin
      cstTbl[cstIndex] := str[i] ;
      cstIndex := cstIndex + 1
    end
  end ;

(****************************)
(*     inc命令出力処理      *)
(****************************)
(* 最適化のため inc命令の前がlda,ldc,inc命令ならば
   それらの命令のqオペランドを該当分増加させる｡   *)
  procedure putINC(qOpe : qType) ;
  begin
    with code[cdIndex] do
     if op in [iLDA,iLDC,iINC] then q := q + qOpe
                               else putCodeQ(iINC,qOpe)
  end ;

(****************************)
(*       ロード処理         *)
(****************************)
  procedure load ;
  begin
    case gattr.kind of
      cst   : putCodeQ(iLDC,gattr.cval) ;
      varbl : if gattr.access = direct then
                putCodePQ(iLOD,dLevel-gattr.lev,gattr.disp)
              else
               (* ind命令を出力する。ただし、
                  最適化のため lda命令の次がind命令ならば
                  lda命令をlod命令に置き換える｡
                  また、ixa命令の次がind命令ならば
                   ixa命令をinx命令に置き換える *)
                with code[cdIndex] do
                  if      op = iLDA then op := iLOD
                  else if op = iIXA then begin op:=iINX; p:=0; q:=0 end
                  else putCode(iIND) ;
      expr  : ;
    end ;
    gattr.kind := expr     { 次回同じものをロードしないようにするため }
  end ;

(****************************)
(*    ロードアドレス処理    *)
(****************************)
  procedure loadAddress ;
  begin
    if gattr.access = direct then
      putCodePQ(iLDA,dLevel-gattr.lev,gattr.disp) ;
    gattr.kind   := varbl ;
    gattr.access := indirect
  end ;

(*****************************)
(* ent命令オペランド設定処理 *)
(*****************************)
  procedure entOperand ;
  begin
    with code[entAd] do                 { entAdは putENT処理で設定される }
    begin
      p := maxStk ;
      q := dataAdr
    end
  end ;

(*******************************)
(*  P-codeオブジェクト出力処理 *)
(*******************************)
  procedure putObject ;
    var i : integer ;
  begin
   (* P-codeの出力 *)
    rewrite(codef) ;
    for i := 0 to cdIndex do write(codef,code[i]) ;

   (* 定数部の出力 ･･･ 定数部がなければ出力しない *)
    if cstIndex <> 0 then
    begin
      rewrite(cstf) ;
      for i:=0 to cstIndex-1 do write(cstf,cstTbl[i])
    end
  end ;

(*========================コード生成部終了 =================================*)

(****************************)
(*      ブロック処理        *)
(****************************)
  procedure block(fcp : idTblPtType) ;
    var lcp        : idTblPtType ;
        argAd      : integer     ;
        returnFlag : Boolean     ;

  (**************************)
  (*  項目の切れ目判定関数  *)
  (**************************)
    function fin(separetor : symbol) : Boolean ;
      var finFlag : Boolean ;
    begin
      finFlag := sy <> separetor ;
      if not finFlag then inSymbol ;
      fin := finFlag
    end ;

(*==========================================================================*)
(*                           定義/宣言に関する処理                          *)
(*==========================================================================*)

  (**************************)
  (*      定数定義処理      *)
  (**************************)
    procedure constDcl ;
      var constIdP : idTblPtType ;
          lcp      : idTblPtType ;
          lop      : opeType ;

    (*************************)
    (*   列挙定数定義処理    *)
    (*************************)
      procedure enumConst ;
        var enumIdP : idTblPtType ;
            enumV   : integer ;
      begin
        enumV := 0 ;                              { 列挙定数値は0から始まる }
        inSymbol ;
        repeat
          if sy <> identSy then error(E002) ;     { 名前が必要 }
          new(enumIdP,konst) ;
          enumIdP^.name  := id ;
          enumIdP^.class := konst ;
          enumIdP^.value := enumV ;
          enterId(enumIdP) ;
          enumV := enumV + 1 ;                    { 列挙定数値は1ずつ増える }
          inSymbol
        until fin(comma) ;
        if sy <> rParent then error(E004)         { ) が必要   }
      end (* enumConst *) ;

    begin (* constDcl *)
      repeat
        if sy  = lParent then enumConst           { 列挙定数の処理 }
        else
        begin
          if sy <> identSy then error(E002) ;     { 名前が必要 }
          new(constIdP,konst) ;
          constIdP^.name  := id ;
          constIdP^.class := konst ;
          inSymbol ;
          if (sy = relOp) and (ope = equ) then inSymbol
                                          else error(E016) ; { = が必要  }
          if sy = addOp then                                 { 符号 +  - }
          begin
            lop := ope ;
            inSymbol
          end
          else lop := noOp ;
          if      sy = intconstSy then constIdP^.value := vi
          else if sy = identSy then
          begin
            lcp := searchId([konst]) ;            { 定数名よりサーチ   }
            constIdP^.value := lcp^.value
          end
          else if (sy = stringSy) and (ord(str[0]) = 1)     { 文字定数 }
            then constIdP^.value := ord(str[1])
          else error(E006) ;                      { 不当な記号が現れた }
          if lop = sub then constIdP^.value := -constIdP^.value ;
          enterId(constIdP)
        end ;

        inSymbol ;
        if sy = semicolon then inSymbol
      until sy in [constSy,varSy,procSy,funcSy,beginSy]
    end ;

  (**************************)
  (*    配列変数宣言処理    *)
  (**************************)
    function arrayVar(varIdP : idTblPtType) : integer ;
      var lcp   : idTblPtType ;
          aryP  : aryPtType   ;
          aryP1 : aryPtType   ;
          aryP2 : aryPtType   ;
          aryP3 : aryPtType   ;
          aSize : integer     ;
    begin
      inSymbol ;
      aryP1 := nil ;
      repeat
        new(aryP) ;
        if varIdP^.aptr = nil then varIdP^.aptr := aryP ;
        aryP^.next := aryP1 ;
        aryP1 := aryP ;
        if sy = identSy then
        begin
          lcp := searchId([konst]) ;              { 定数名     }
          aryP^.eleNo := lcp^.value
        end
        else if sy = intconstSy then aryP^.eleNo := vi
        else error(E006) ;                        { 不当な記号 }
        if aryP^.eleNo <= 0 then error(E070) ;    { 配列数誤り }
        inSymbol
      until fin(comma) ;
      if sy <> rBrack then error(E012) ;          { ] が必要   }
      inSymbol ;

   (* 正順につなぎ替え サイズを計算する｡
      配列のサイズには物理的限界があるが、本コンパイラではノーチェック｡ *)
      aSize := 1   ;
      aryP3 := nil ;
      repeat
        with aryP1^ do
        begin
          size  := eleNo * aSize ;
          aSize := size  ;
          aryP2 := next  ;
          next  := aryP3 ;
          aryP3 := aryP1 ;
          aryP1 := aryP2
        end
      until aryP1 = nil ;

      arrayVar := aSize                           { 配列全体の大きさを返却 }
    end ;

  (**************************)
  (*      変数宣言処理      *)
  (**************************)
    procedure varDcl ;
      var varIdP : idTblPtType ;
    begin
      repeat
        repeat
          if sy <> identSy then error(E002) ;     { 名前が必要 }
          new(varIdP,vars) ;
          varIdP^.class := vars    ;
          varIdP^.name  := id      ;
          varIdP^.vlev  := dLevel  ;
          varIdP^.adr   := dataAdr ;
          varIdP^.aptr  := nil     ;
          inSymbol ;
          if sy = lBrack then dataAdr := dataAdr + arrayVar(varIdP)
                         else dataAdr := dataAdr + 1 ;
          enterId(varIdP)
        until fin(comma) ;
        if sy <> semicolon then error(E014) ;     { ; が必要 }
        inSymbol
      until sy in [constSy,varSy,procSy,funcSy,beginSy]
    end ;

  (****************************)
  (*  手続き/関数の引数処理   *)
  (****************************)
   procedure paramList(fcp : idTblPtType) ;
     var idP   : idTblPtType ;
         lcp   : idTblPtType ;
         dummy : integer     ;
   begin
     inSymbol ;
     repeat
       repeat
         if sy <> identSy then error(E002) ;      { 名前が必要 }
         new(idP,vars) ;
         idP^.name  := id      ;
         idP^.class := vars    ;
         idP^.vLev  := dLevel  ;
         idP^.adr   := dataAdr ;
         IdP^.aptr  := nil     ;
         inSymbol ;
         if sy = lBrack then dummy := arrayVar(idP) ;
         dataAdr := dataAdr + 1 ;
         enterId(idP) ;
         if fcp^.next = nil then fcp^.next := idP { 仮引数をリンク }
                            else lcp^.next := idP ;
         lcp := idP
       until fin(comma)
     until fin(semicolon) ;                       { , ; で継続する }
     if sy <> rParent then error(E004) ;          { ) が必要       }
     inSymbol ;

    (* 仮引数が配列そのものの時は、配列をコピーするためのエリアを確保する *)
     lcp := fcp^.next ;
     while lcp <> nil do
       with lcp^ do
       begin
         if aptr <> nil then                      { 配列の時 }
         begin
           adr     := dataAdr ;                   { 割りつけ }
           dataAdr := dataAdr + aptr^.size        { 配列の大きさ分進める }
         end ;
         lcp := next
       end
   end ;

  (****************************)
  (*   手続き/関数宣言処理    *)
  (****************************)
    procedure procFunc(kind : symbol) ;
      var idP        : idTblPtType ;
          pf         : idClass ;
          oldDataAdr : integer ;
          oldMaxStk  : integer ;
          oldnewStk  : integer ;
          oldExtLb   : integer ;
    begin
     (* 入れ子構造をとるため、現在の各種状況値を退避し、新たに設定する *)
      oldDataAdr := dataAdr   ;
      oldMaxStk  := maxStk    ;
      oldNewStk  := newStk    ;
      oldExtLb   := exitLabel ;
      dataAdr    := afterMST  ;
      newStk     := afterMST  ;
      maxStk     := afterMST  ;
      exitLabel  := 0 ;

      if sy <> identSy then error(E002) ;     { 名前が必要 }
      if kind = procSy then begin new(idP,proc) ; pf := proc end
                       else begin new(idP,func) ; pf := func end ;
      idP^.name      := id ;
      idP^.class     := pf ;
      idP^.pfDclKind := declared ;
      idP^.pflev     := dLevel   ;
      idP^.pfLabel   := creLabel ;
      enterId(idP) ;
      dLevel := dLevel + 1 ;             { 手続き/関数名と引数は定義水準が違う}
      if dLevel > maxLevel then error(E604) ; { 手続き/関数の入れ子が深すぎる }
      display[dLevel] := nil ;
      inSymbol ;
      if sy = lParent then paramList(idP) ;   { 仮引数の処理 }
      if sy <> semicolon then error(E014) ;   { ; が必要     }

     (* ブロックの処理 *)
      inSymbol   ;
      block(idP) ;
      if sy <> semicolon then error(E014) ;   { ; が必要     }
      inSymbol ;

     (* 本来は、この時点でdisplay[dLevel]にぶら下がる動的に確保した名前情報
        等をdisposeしていく必要があるが、HAPPyのdisposeは、カッコだけで効果
        がないので、dispose処理を省略する *)

     (* 各種状況値を復元する *)
      dLevel    := dLevel - 1 ;
      dataAdr   := oldDataAdr ;
      newStk    := oldNewStk  ;
      maxStk    := oldMaxStk  ;
      exitLabel := oldExtLb
    end ;

(*==========================================================================*)

  (****************************)
  (*    式の処理の前方宣言    *)
  (****************************)
  (*  expression処理中でvariable処理,stdCall処理,dclCall処理を呼び、
      それらの処理中でexpression処理を呼び合っているので
      前方宣言が必要 *)
    procedure expression ; forward ;

  (****************************)
  (*        変数の処理        *)
  (****************************)
  (*  単純変数, 配列変数,添字付変数の処理を行う *)
    procedure variable(fcp : idTblPtType) ;
      var aryP  : aryPtType ;
    begin
      gattr.kind   := varbl     ;
      gattr.access := direct    ;
      gattr.lev    := fcp^.vlev ;
      gattr.disp   := fcp^.adr  ;
      gattr.aryPtr := fcp^.aptr ;
      if gattr.aryPtr <> nil then loadAddress ;  { 配列変数はここでﾛｰﾄﾞｱﾄﾞﾚｽ }

      if sy = lBrack then                         { 添字付変数 }
      begin
        inSymbol    ;
        aryP := fcp^.aptr ;
        repeat
          if aryP = nil then error(E138) ;        { 配列次元不一致　}
          expression ;
          if gattr.kind = cst then
          begin
            if (0 > gattr.cval) or ( gattr.cval >= aryP^.eleNo) then
              error(E148) ; { 添字範囲外 }
            with aryP^ do putINC(gattr.cval * size div eleNo)
          end
          else
          begin
            load ;
            if debug then                  { デバッグオプション有効の時    }
              putCodeQ(iCHK,aryP^.eleNo) ; { 配列添字 0〜eleNo未満チェック }
            with aryP^ do putCodeQ(iIXA,size div eleNo)
          end ;
          aryP := aryP^.next
        until fin(comma) ;
        if sy <> rBrack then error(E012) ;        { ] が必要 }
        inSymbol ;

        gattr.aryPtr := aryP  ;
        gattr.kind   := varbl ;
        gattr.access := indirect
      end
    end ;

(*=========================================================================*)
(*                        標準手続き/標準関数の処理                        *)
(*=========================================================================*)

  (****************************)
  (*   eof/eoln標準関数処理   *)
  (****************************)
    procedure eofEolnFunc(pfKind : stdPf) ;
    begin
      if sy = lParent then error(E116) ;          { 標準手続きの引数誤り }
      if pfKind = fEof then putCode(iEOF)
                       else putCode(iEOL)
    end ;

  (****************************)
  (*     abs標準関数処理      *)
  (****************************)
    procedure absFunc ;
    begin
      if sy <> lParent then error(E009) ;         { ( が必要       }
      inSymbol ;
      expression ;
      if gattr.aryPtr <> nil then error(E125) ; { 標準関数引数誤り }
      load ;
      putCode(iABS) ;
      if sy <> rParent then error(E004) ;         { ) が必要       }
      inSymbol
    end ;

  (****************************)
  (*    halt標準手続き処理    *)
  (****************************)
    procedure haltProc ;
    begin
      if sy = lParent then error(E116) ;    { 標準手続きの引数誤り }
      putCode(iSTP)
    end ;

  (*******************************)
  (* write/writeln標準手続き処理 *)
  (*******************************)
    procedure writeProc(pfKind : stdPf) ;
      const DefaultWidth = 12 ;               { 整数のデフォルト出力桁 }
      var   kind  : (strings,chars,ints) ;
            width : integer ;

      (***********************)
      (*    出力幅の処理     *)
      (***********************)
      procedure widthRountine ;
      begin
         if sy = colon then
          begin
            inSymbol ;
            expression ;
            if gattr.aryPtr <> nil then error(E125) ; { 標準関数引数誤り }
            load
          end
          else  putCodeQ(iLDC,width)
        end (* widthRoutine *) ;

    begin (* writeProc *)
      if sy = lParent then
      begin
        inSymbol ;
        repeat
          if sy = stringSy then
          begin
            if ord(str[0]) = 1 then               { 文字定数 }
              begin putCodeQ(iLDC,ord(str[1])) ;
                    kind  := chars ;
                    width := 1
              end
            else                                  { 文字列 }
              begin putLCA ;
                    kind  := strings ;
                    width := ord(str[0])
              end ;
            inSymbol ;
            if sy = dollar then error(E006) ;     { $は指定不可  }
            widthRountine ;                       { 出力桁の処理 }
            if kind = chars then putCode(iWRC)
                            else putCode(iWRS)
          end
          else { sy <> stringSy }
          begin
            expression ;
            if gattr.aryPtr <> nil then error(E116) ; { 標準手続き引数誤り }
            load ;
            if sy = dollar then                   { 文字型出力指令 }
              begin  kind  := chars ;
                     width := 1     ;
                     inSymbol
              end
            else
              begin  kind  := ints ;
                     width := DefaultWidth        { : がなければデフォルト桁 }
              end ;
            widthRountine ;                       { 出力桁の処理 }
            if kind = ints then putCode(iWRI)     { 整数出力     }
                           else putCode(iWRC)     { 文字型出力   }
          end
        until fin(comma) ;
        if sy <> rParent then error(E004) ;       { ) がない　   }
        inSymbol
      end
      else { sy <> lParent }
        if pfKind = pWrite then error(E009) ;     { ( が必要     }
      if pfKInd = pWriteln then putCode(iWLN)
    end ;

  (****************************)
  (*    read標準手続き処理    *)
  (****************************)
    procedure readProc(pfKind : stdPf) ;
      var lcp : idTblPtType ;
    begin
      if sy = lParent then
      begin
        inSymbol ;
        repeat
          if sy <> identSy then error(E002) ;       { 名前が必要 }
          lcp := searchId([vars]) ;
          inSymbol      ;
          variable(lcp) ;
          if gattr.aryPtr <> nil then error(E116) ; { 標準手続きの引数誤り }
          loadAddress   ;
          if sy = dollar then
          begin
            putCode(iRDC) ;                         { 文字型の入力 }
            inSymbol
          end
          else putCode(iRDI)
        until fin(comma) ;
        if sy <> rParent then error(E004) ;         { ) が必要 }
        inSymbol
      end
      else { sy <> lParent }
        if pfKind = pRead then error(E009) ;        { ( が必要 }
      if pfKInd = pReadln then putCode(iRLN)
    end ;

  (*************************************)
  (*   標準手続き/標準関数呼出し処理   *)
  (*************************************)
    procedure stdCall(fcp : idTblPtType) ;
    begin
      case fcp^.pfId of
        pWrite,
        pWriteln : writeProc(fcp^.pfId) ;
        pRead,
        pReadLn  : readProc(fcp^.pfId)  ;
        fEof,
        fEoln    : eofEolnFunc(fcp^.pfId) ;
        pHalt    : haltProc ;
        fAbs     : absFunc  ;
      end
    end ;

(*=========================================================================*)

  (****************************)
  (* 定義手続き/関数呼出し処理*)
  (****************************)
    procedure dclCall(fcp : idTblPtType) ;
      var lcp   : idTblPtType ;
          argNo : integer ;
    begin
      putCodeP(iMST,dLevel-fcp^.pflev) ;
      lcp := fcp^.next ;                          { 仮引数のリンク   }
      argNo := 0 ;
      if sy = lParent then                        { 実引数がある時   }
      begin
        inSymbol ;
        repeat
          if lcp = nil then error(E126) ;         { 引数不一致       }
          argNo := argNo + 1 ;                    { 引数の数ｶｳﾝﾄｱｯﾌﾟ }
          expression ;
          (* 仮引数と実引数の配列の構造が同じかチェック *)
          if notCompatible(lcp^.aptr,gattr.aryPtr) then error(E126) ;
          if gattr.aryPtr = nil then load ;
          lcp := lcp^.next
        until fin(comma) ;
        if sy <> rParent then error(E004) ;       { ) が必要   }
        inSymbol
      end ;
      if lcp <> nil then error(E126) ;            { 引数不一致 }
      putCodePL(iCUP,argNo,fcp^.pfLabel)
    end ;

(*=========================================================================*)
(*                      　　　　　式の処理　　　　　　　                   *)
(*=========================================================================*)
    procedure expression ;
      var lop   : opeType   ;
          laPtr : aryPtType ;

    (************************)
    (*    単純式の処理      *)
    (************************)
      procedure simpleExpression ;
        var sign : Boolean ;
            neg  : Boolean ;
            lop  : opeType ;

      (**********************)
      (*     項の処理       *)
      (**********************)
        procedure term ;
          var lop : opeType ;

        (********************)
        (*    因子の処理    *)
        (********************)
          procedure factor ;

          (******************)
          (* 名前因子の処理 *)
          (******************)
            procedure factIdent ;
              var lcp : idTblPtType ;
            begin
              lcp := searchId([konst,vars,func]) ;
              inSymbol ;
              case lcp^.class of
                konst : begin
                          gattr.aryPtr := nil ;
                          gattr.kind   := cst ;
                          gattr.cval   := lcp^.value
                        end ;
                vars  : variable(lcp) ;
                func  : begin
                          if lcp^.pfDclKind = standard then stdCall(lcp)
                                                       else dclCall(lcp) ;
                          gattr.aryPtr := nil ;
                          gattr.kind   := expr
                        end
              end
            end (* factIdent *) ;

          begin (* factor *)
            if not (sy in [identSy,intconstSy,lParent,stringSy,notOp]) then
              error(E058) ;                       { 項(因子)に誤りがある    }
            case sy of
              identSy    : factIdent ;
              intconstsy : begin
                             gattr.aryPtr := nil ;
                             gattr.kind   := cst ;
                             gattr.cval   := vi  ;
                             inSymbol
                           end ;
              lParent    : begin
                             inSymbol   ;
                             expression ;
                             load       ;
                             if sy <> rParent then error(E004) ; { ) が必要 }
                             inSymbol
                           end ;
              stringSy   : begin
                             if ord(str[0]) <> 1 then error(E058) ;{項に誤り}
                             gattr.kind := cst ;
                             gattr.cval := ord(str[1]) ; { 値は文字の順序数 }
                             inSymbol
                           end ;
              notOp      : begin
                             inSymbol ;
                             factor   ;
                             if gattr.aryPtr <> nil then
                               error(E134) ;                 { 演算対象誤り }
                             load ;
                             putCode(iNOT)
                           end
            end
          end (* factor *) ;

        begin (* term *)
          factor ;
          while sy = mulOp do                         { * / %        }
          begin
            if gattr.aryPtr <> nil then error(E134) ; { 演算対象誤り }
            load ;
            lop := ope ;
            inSymbol   ;
            factor ;
            if gattr.aryPtr <> nil then error(E134) ; { 演算対象誤り }
            load ;
            case lop of
              mul  : putCode(iMUL) ;
              divi : putCode(iDIV) ;
              modd : putCode(iMOD)
            end
          end
        end (* term *) ;

      begin (* simpleExpression *)
        sign := sy = addOp ;            { + - }
        if sign then
        begin
          neg := ope = sub ;            { -   }
          inSymbol ;
        end ;

        term ;
        if sign then
        begin
          if gattr.aryPtr <> nil then error(E134) ; { 演算対象誤り }
          if neg then
            if gattr.kind = cst then gattr.cval := -gattr.cval
            else begin
                   load ;
                   putCode(iNEG)
                 end
        end ;

        while sy = addOp do
        begin
          load ;
          lop := ope ;
          inSymbol ;
          term ;
          if gattr.aryPtr <> nil then error(E134) ; { 演算対象誤り }
          if gattr.kind = cst then
          begin
            if gattr.cval <> 0 then
              if lop = add then putINC( gattr.cval)
                           else putINC(-gattr.cval) ;
            gattr.kind := expr                      { ロードしたことにする }
          end
          else
          begin
            load ;
            if lop = add then putCode(iADD)
                         else putCode(iSUB)
          end
        end
      end (* simpleExpression *) ;

  (****************************)
  (*      式の処理メイン      *)
  (****************************)
    begin (* expression *)
      simpleExpression ;
      if sy = relOp then
      begin
        laPtr := gattr.aryPtr    ;
        if laPtr = nil then load ;
        lop := ope ;
        inSymbol   ;

        simpleExpression ;
        if gattr.aryPtr = nil then load ;
        if notCompatible(laPtr,gattr.aryPtr) then  { 配列構造が違えば駄目    }
          error(E143) ;
        if lop in [leq,les,geq,grt] then { 配列は <= < >= > の比較ができない }
          if (laPtr <> nil) or (gattr.aryPtr <> nil) then error(E143) ;

        case lop of
          leq : putCode(iLEQ) ;
          les : putCode(iLES) ;
          geq : putCode(iGEQ) ;
          grt : putCode(iGRT) ;
          equ : if laPtr = nil then putCode(iEQU)
                               else putCodeQ(iEQM,laPtr^.size) ; { 配列の比較 }
          neq : if laPtr = nil then putCode(iNEQ)
                               else putCodeQ(iNEM,laPtr^.size) ; { 配列の比較 }
        end ;

        gattr.aryPtr := nil ;
        gattr.kind   := expr            { 再ロードさせないため }
      end
    end ;

(*=========================================================================*)
(*                      　　　　　文の処理　　　　　　　                   *)
(*=========================================================================*)
    procedure statement ;
      var lcp : idTblPtType ;

    (****************************)
    (*      代入文の処理        *)
    (****************************)
      procedure assignment(fcp : idTblPtType) ;
        var lattr : attr ;
      begin
        variable(fcp)  ;
        lattr := gattr ;                          { 左辺の属性退避   }
        if sy <> becomes then error(E051) ;       { := が必要        }
        inSymbol   ;
        expression ;
        if notCompatible(gattr.aryPtr,lattr.aryPtr) then
          error(E129) ;                           { 代入不可能       }
        if gattr.aryPtr = nil then load ;         { 整数値ならロード }
        if lattr.access = direct then
          putCodePQ(iSTR,dLevel-fcp^.vlev,fcp^.adr)
        else
          if lattr.aryPtr = nil then putCode(iSTI)
                                else putCodeQ(iMOV,lattr.aryPtr^.size)
      end ;

    (****************************)
    (*        if文の処理        *)
    (****************************)
      procedure ifStatement ;
        var label1,label2 : integer ;
      begin
        inSymbol   ;
        expression ;
        if gattr.aryPtr <> nil then error(E146) ; { 条件式誤り  }
        load ;
        label1 := creLabel   ;
        putJump(iZJP,label1) ;
        if sy <> thenSy then error(E052) ;        { then が必要 }
        inSymbol  ;
        statement ;
        if sy = elseSy then
        begin
          label2 := creLabel   ;
          putJump(iUJP,label2) ;
          putLabel(label1) ;
          inSymbol  ;
          statement ;
          putLabel(label2)
        end
        else putLabel(label1)
      end ;

    (****************************)
    (*       while文の処理      *)
    (****************************)
      procedure whileStatement ;
        var loopL,exitL : integer ;
      begin
        inSymbol ;
        loopL := creLabel ;
        putLabel(loopL)   ;
        expression ;
        if gattr.aryPtr <> nil then error(E146) ; { 条件式誤り  }
        load ;
        exitL := creLabel   ;
        putJump(iZJP,exitL) ;
        if sy <> doSy then error(E054) ;          { do が必要   }
        inSymbol  ;
        statement ;
        putJump(iUJP,loopL) ;
        putLabel(exitL)
      end ;

    (****************************)
    (*      repeat文の処理      *)
    (****************************)
      procedure repeatStatement ;
        var loopL : integer ;
      begin
        loopL := creLabel ;
        putLabel(loopL)   ;
        inSymbol ;
        repeat  statement until fin(semicolon) ;
        if sy <> untilSy then error(E053) ;       { until が必要 }
        inSymbol   ;
        expression ;
        if gattr.aryPtr <> nil then error(E146) ; { 条件式誤り   }
        load ;
        putJump(iZJP,loopL)
      end ;

    (****************************)
    (*        for文の処理       *)
    (****************************)
    (*  Pascalと違い、PL/Tでは制御変数に配列変数を記述できる。*)
      procedure forStatement ;
        var lcp         : idTblPtType ;
            lsy         : symbol ;
            loopL,exitL : integer ;
      begin
        inSymbol ;
        if sy <> identSy then error(E006) ;       { 不当な記号         }
        lcp := searchId([vars]) ;
        inSymbol      ;
        variable(lcp) ;                           { ←ここがミソ       }
        if gattr.aryPtr <> nil then error(E188) ; { 制御変数誤り       }
        loadAddress   ;                       { 制御変数アドレスロード }
        if sy <> becomes then error(E051) ;       { := が必要          }
        inSymbol ;
        expression ;
        if gattr.aryPtr <> nil then error(E144) ; { 初期値誤り         }
        load ;                                    { 初期値ロード       }
        if not (sy in [toSy,downtoSy]) then
          error(E055);                          { toあるいはdownto必要 }
        lsy := sy  ;
        inSymbol   ;
        expression ;
        if gattr.aryPtr <> nil then error(E144) ; { 終値誤り           }
        load ;                                    { 終値ロード         }
        if sy <> doSy then error(E054) ;          { do が必要          }
        exitL := creLabel ;
        if lsy = toSy then putCodePL(iFOR,1,exitL)
                      else putCodePL(iFOR,2,exitL) ;
        loopL := creLabel ;
        putLabel(loopL)   ;
        inSymbol  ;
        statement ;
        if lsy = toSy then putCodePL(iNXT,1,loopL)
                      else putCodePL(iNXT,2,loopL) ;
        putLabel(exitL)
      end ;

    (****************************)
    (*      return文の処理      *)
    (****************************)
      procedure returnStatement ;
      begin
        inSymbol ;
        if exitLabel = 0 then exitLabel := creLabel ; { ブロック出口    }
        if fcp <> nil then                   { fcp は block手続きの引数 }
          if fcp^.class = func then
          begin
            returnFlag := true ;             { return文あり             }
            expression ;                     { 関数値のとなる式         }
            if gattr.aryPtr <> nil then error(E195) ;      { 戻り値誤り }
            load
          end ;
        putJump(iUJP,exitLabel)
      end ;

  (****************************)
  (*      文の処理メイン      *)
  (****************************)
    begin (* statement *)
      if sy in [identSy,beginSy,ifSy,
                whileSy,forSy,returnSy,repeatSy] then
        case sy of
          identSy  : begin
                       lcp := searchId([vars,proc]) ;
                       inSymbol ;
                       if lcp^.class = vars then assignment(lcp)
                       else           { proc }
                        if lcp^.pfDclKind = standard  then stdCall(lcp)
                                           {declared} else dclCall(lcp)
                     end ;
          beginSy  : begin
                       inSymbol ;
                       repeat statement until fin(semicolon) ;
                       if sy <> endSy then error(E013) ;   { endが必要 }
                       inSymbol
                     end ;
          ifSy     : ifStatement     ;
          whileSy  : whileStatement  ;
          repeatSy : repeatStatement ;
          forSy    : forStatement    ;
          returnSy : returnStatement ;
        end ;

      if not (sy in [semicolon,endSy,untilSy,elseSy]) then
        error(E006)                                        { 不当な記号 }
    end (* statement *) ;

(*======================= 文の処理終わり ==================================*)

(****************************)
(*      本体の処理メイン    *)
(****************************)
  begin  (* block *)
   (* PL/T ではconst,var,proc,funcの記述順は自由 *)
    while sy in [constSy,varSy,procSy,funcSy] do
      case sy of
        constSy : begin inSymbol ; constDcl         end ;
        varSy   : begin inSymbol ; varDcl           end ;
        procSy  : begin inSymbol ; procFunc(procSy) end ;
        funcSy  : begin inSymbol ; procFunc(funcSy) end
      end ;

    if sy <> beginSy then error(E017) ;        { begin が必要        }

    inSymbol ;

   (***** 本体の処理 *****)

    if fcp = nil then putLabel(mainLabel)      { メインブロック      }
                 else putLabel(fcp^.pfLabel) ; { 手続き/関数ブロック }
    putENT ;                                   { ent命令出力         }

   (* 引数の処理 *)
    if fcp <> nil then                  { メインブロックでない時     }
    begin
      returnFlag := false ;             { return文があったかの判定用 }
      lcp := fcp^.next    ;
      argAd := afterMST   ;             { 引数は管理域の後に割り付け }
      while lcp <> nil do
      begin
        if lcp^.aptr <> nil then        { 配列の時は中身をコピーする }
        begin
          putCodePQ(iLDA,0,lcp^.adr) ;              { 転送先アドレス }
          putCodePQ(iLOD,0,argAd)    ;              { 転送元アドレス }
          putCodeQ(iMOV,lcp^.aptr^.size)            { 転送命令       }
        end ;
        argAd := argAd + 1 ;            { 次の引数のアドレス         }
        lcp := lcp^.next
      end
    end ;

    repeat  statement until fin(semicolon) ;
    if sy <> endSy then error(E013) ;          { end が必要          }
    inSymbol ;

   (* return文有無のチェック *)
    if fcp <> nil then
      if fcp^.class = func then                { ユーザ宣言関数      }
        if not returnFlag then error(E176) ;   { return文が1つもない }

    if exitLabel <> 0 then putLabel(exitLabel) ; { 出口ラベルの生成  }
    if fcp = nil then putCode(iSTP)            { メインブロックはstp }
    else
      if fcp^.class = proc then putCodeP(iRET,0)
                           else putCodeP(iRET,1) ;

    entOperand                               { ent命令オペランド設定 }
  end ;

(****************************)
(*     コンパイル処理       *)
(****************************)
  procedure compile ;
  begin
    mainLabel := creLabel   ;
    putJump(iUJP,mainLabel) ;           { メインブロックのみの時は不要ﾀﾞｹﾄﾞ  }
    exitLabel := 0 ;                    { ブロック出口ラベル不生成としておく }
    inSymbol   ;
    block(nil) ;                        { メインブロックの処理 }
    if sy <> period then error(E021)    { . が必要             }
  end ;

(****************************)
(*      初期設定処理        *)
(****************************)
  procedure initialize ;
    var i : integer    ;

  (***************************)
  (*     標準名登録処理      *)
  (***************************)
    procedure StdName ;
      var idP : idTblPtType ;
    begin
      new(idP,konst) ;
      idP^.name  := 'maxint    ' ;
      idP^.class := konst  ;
      idP^.value := maxint ;
      enterId(idP) ;

      new(idP,proc,standard) ;
      idP^.name      := 'write     ' ;
      idP^.class     := proc ;
      idP^.pfDclKind := standard ;
      idP^.pfId      := pWrite   ;
      enterId(idP) ;

      new(idP,proc,standard) ;
      idP^.name      := 'writeln   ' ;
      idP^.class     := proc ;
      idP^.pfDclKind := standard ;
      idP^.pfId      := pWriteln ;
      enterId(idP) ;

      new(idP,proc,standard) ;
      idP^.name      := 'read      ' ;
      idP^.class     := proc ;
      idP^.pfDclKind := standard ;
      idP^.pfId      := pRead    ;
      enterId(idP) ;

      new(idP,proc,standard) ;
      idP^.name      := 'readln    ' ;
      idP^.class     := proc ;
      idP^.pfDclKind := standard ;
      idP^.pfId      := pReadln  ;
      enterId(idP) ;

      new(idP,proc,standard) ;
      idP^.name      := 'halt      ' ;
      idP^.class     := proc ;
      idP^.pfDclKind := standard ;
      idP^.pfId      := pHalt    ;
      enterId(idP) ;

      new(idP,proc,standard) ;
      idP^.name      := 'abs       ' ;
      idP^.class     := func ;
      idP^.pfDclKind := standard ;
      idP^.pfId      := fAbs     ;
      enterId(idP) ;

      new(idP,func,standard) ;
      idP^.name      := 'eof       ' ;
      idP^.class     := func ;
      idP^.pfDclKind := standard ;
      idP^.pfId      := fEof     ;
      enterId(idP) ;

      new(idP,func,standard) ;
      idP^.name      := 'eoln      ' ;
      idP^.class     := func ;
      idP^.pfDclKind := standard ;
      idP^.pfId      := fEoln    ;
      enterId(idP) ;
    end ;

  (***************************)
  (*  P-code sp増減表設定    *)
  (***************************)
  (*  当該ブロックで最大のsp変位をent命令のp部に設定するためのもの。
      この機能により、解釈実行時に、spの値がスタックを越えないか、
      各命令実行毎に判定する必要がなくなる *)
    procedure initPcode ;
      var i : opType ;
    begin
      for i:=iABS to iWRS do spx[i] := 0 ;
      spx[iADD] :=-1 ; spx[iDIV] :=-1 ; spx[iEOF] :=+1 ;
      spx[iEOL] :=+1 ; spx[iEQM] :=-1 ; spx[iEQU] :=-1 ;
      spx[iGEQ] :=-1 ; spx[iGRT] :=-1 ; spx[iINX] :=-1 ;
      spx[iIXA] :=-1 ; spx[iLCA] :=+1 ; spx[iLDA] :=+1 ;
      spx[iLDC] :=+1 ; spx[iLEQ] :=-1 ; spx[iLES] :=-1 ;
      spx[iLOD] :=+1 ; spx[iMOD] :=-1 ; spx[iMOV] :=-2 ;
      spx[iMUL] :=-1 ; spx[iNEM] :=-1 ; spx[iNEQ] :=-1 ;
      spx[iNXT] :=-3 ; spx[iRDC] :=-1 ; spx[iRDI] :=-1 ;
      spx[iRLN] :=-1 ; spx[iSUB] :=-1 ; spx[iSTI] :=-2 ;
      spx[iSTR] :=-1 ; spx[iWLN] :=-1 ; spx[iWRC] :=-2 ;
      spx[iWRI] :=-2 ; spx[iWRS] :=-2 ; spx[iZJP] :=-1
    end ;

  (***************************)
  (*     予約語設定処理      *)
  (***************************)
    procedure initRsv ;
    begin
      rsv[beginSy ] := 'begin     ' ;
      rsv[endSy   ] := 'end       ' ;
      rsv[ifSy    ] := 'if        ' ;
      rsv[thenSy  ] := 'then      ' ;
      rsv[whileSy ] := 'while     ' ;
      rsv[doSy    ] := 'do        ' ;
      rsv[elseSy  ] := 'else      ' ;
      rsv[forSy   ] := 'for       ' ;
      rsv[toSy    ] := 'to        ' ;
      rsv[repeatSy] := 'repeat    ' ;
      rsv[untilSy ] := 'until     ' ;
      rsv[returnSy] := 'return    ' ;
      rsv[downtoSy] := 'downto    ' ;
      rsv[procSy  ] := 'procedure ' ;
      rsv[funcSy  ] := 'function  ' ;
      rsv[varSy   ] := 'var       ' ;
      rsv[constSy ] := 'const     ' ;
    end ;

  (***************************)
  (*     文字表設定処理      *)
  (***************************)
    procedure initChTable ;
      var c : char ;
    begin
      for c:=chr(0) to chr(255) do chTable[c] := illegal ; { まず全部不当文字 }
      for c:='0'    to '9'      do chTable[c] := number  ; { 数字 }
      for c:='A'    to 'Z'      do chTable[c] := alpha   ; { 英字 }
      for c:='a'    to 'z'      do chTable[c] := alpha   ; { 英字 }
      chTable[  '_' ] := alpha     ;                       { _ を英字に含める }
      (* 空白と水平タブは 文字表によって振り分けず 直接処理するので設定不要 *)
      chTable[ '''' ] := quotation ;
      chTable[  '(' ] := chLpar    ;
      chTable[  ':' ] := chColon   ;
      chTable[  '<' ] := chLt      ;
      chTable[  '>' ] := chGt      ;
      chTable[  '.' ] := special   ;
      chTable[  ',' ] := special   ;
      chTable[  ';' ] := special   ;
      chTable[  '=' ] := special   ;
      chTable[  '+' ] := special   ;
      chTable[  '-' ] := special   ;
      chTable[  '*' ] := special   ;
      chTable[  '/' ] := special   ;
      chTable[  '%' ] := special   ;
      chTable[  ')' ] := special   ;
      chTable[  '.' ] := special   ;
      chTable[  '[' ] := special   ;
      chTable[  ']' ] := special   ;
      chTable[  '$' ] := special   ;
      chTable[  '!' ] := special   ;
    end (*initChTable*);

  begin (*initialize*)
    reset(source)     ;                 { PL/T ソースファイルのオープン }
    initChTable       ;                 { 文字表設定                    }
    initRsv           ;                 { 予約語設定                    }
    initPcode         ;                 { P-code sp 増減表設定          }
    dLevel     := 0   ;                 { 0水準に標準名を登録するため   }
    display[0] := nil ;
    stdName           ;                 { 標準名の登録                  }

    dLevel     := 1   ;                 { メインブロックは 水準1        }
    display[1] := nil ;

    for i:=1 to MaxIDleng do spaceId[i] := ' ' ; {名前処理の高速化のため}

    labelV   := 0        ;
    dataAdr  := 0        ;         { データ割りつけアドレス             }
    maxStk   := afterMST ;         { mst命令が生成されると仮定するため  }
    newStk   := afterMST ;
    cdIndex  := -1       ;         { P-code格納域指標初期設定           }
    cstIndex := 0        ;         { 定数  格納域指標初期設定           }
    lineNum  := 1        ;
    colum    := 0        ;
    eofFlag  := false    ;         { eof未検出                          }
    ch       := ' '      ;         { inSymbolで最初の文字を読ませるため }
    debug    := false              { デバッグオプションオフ             }
  end ;

(****************************)
(*       メイン処理         *)
(****************************)
begin
  writeln('HAPPy PL/T Compiler Version 0.0') ;
  initialize ;
  compile    ;
  putObject  ;
  writeln    ;
  writeln(' *** Compile completed. ***') ;
  write(' *** code =',cdIndex+1:5,' words  ') ;
  write('constant data =',cstIndex:5,' words ***') ;
9999:
end.