{*********************************************************************
 *  *** Pascal クロスリファレンサ ***                                *
 *                                                                   *
 *    sourceファイルを読み、名前の出現行を印字する。                 *
 *    また、プログラムの構造に係わるような主な予約語の出現回数を     *
 *    印字する。                                                     *
 *      == 本来名前には有効範囲があり、それを意識した作りでなければ  *
 *         完全ではないが、今後に期待したい                          *
 *                                                                   *
 *        HAPPyのサンプルプログラム                                  *
 *          (作者  浅野比富美 Public Domain Software)                *
 *********************************************************************}

program xref(source,output) ;

  const
    MaxIDlen  = 10 ;                    { 名前の最大識別文字長 }
                                        { HAPPyの名前の最大識別長は32だけど
                                          長すぎて苦しいので10で我慢}
    MinRSVlen =  2 ;                    { 予約語の最小文字長   }
    MaxRSVlen = 10 ;                    { 予約語の最大文字長+1 }

  type
    string = packed array[1..MaxIDlen] of char ; { 名前の文字列 }
    chKind = (number,letter,other) ;    { 文字の種類  数字/英字/その他 }
    symbol =                            { 予約語の種類及び名前 }
             (IFsy,DOsy,OFsy,TOsy,INsy,ORsy,ENDsy,FORsy,VARsy,
              DIVsy,MODsy,SETsy,ANDsy,NOTsy,NILsy,THENsy,
              ELSEsy,WITHsy,GOTOsy,CASEsy,TYPEsy,FILEsy,
              BEGINsy,UNTILsy,WHILEsy,ARRAYsy,CONSTsy,
              LABELsy,REPEATsy,RECORDsy,DOWNTOsy,PACKEDsy,
              PROGRAMsy,FUNCTIONsy,PROCEDUREsy,
              identsy) ;
    IDlistptr = ^IDlist   ;             { 名前のリストポインタ }
    lnumptr   = ^lnumlist ;             { 行番号リストポインタ }
    IDlist    = record                  { 名前のリスト }
                  IDENT  : string    ;  {   名前       }
                  lnump  : lnumptr   ;  {   行番号リストへのポインタ }
                  leftp  : IDlistptr ;  {   小さい名前リストへのポインタ }
                  rightp : IDlistptr ;  {   大きい名前リストへのポインタ }
                end ;
    lnumlist  = record                  { 行番号リスト }
                  lnum : integer ;      {   出現行番号   }
                  next : lnumptr ;      {   次の行番号リストへのポインタ }
                end ;

  var
    source     : text ;                    { Pascalソースファイル }
    chtype     : array[char] of chKind ;   { 文字の種別表   }
    rsv        : array[symbol] of          { 予約語テーブル }
                   record nam   : string  ;{   予約語の名前 }
                          count : integer ;{   出現カウンタ }
                   end ;
    rsvent     : array[MinRSVlen..MaxRSVlen]
                   of symbol ;          { 長さ別予約語テーブルエントリ }
    linenum    : integer     ;          { 行番号カウンタ }
    inpchar    : char        ;          { 読み込み文字   }
    ID         : string      ;          { 名前 }
    clearID    : string      ;          { 名前格納エリアの空白初期化用ワーク }
    root       : IDlistptr   ;          { 名前リストの根       }
    WKidlist   : IDlist      ;          { 名前リストの作業用   }
    WKlnumlist : lnumlist    ;          { 行番号リストの作業用 }

{******************************}
{*        初期設定            *}
{******************************}
  procedure init ;
    var c : char    ;                   { for文の制御変数 }
        i : integer ;                   { for文の制御変数 }
        s : symbol  ;                   { for文の制御変数 }
  begin
    rsv[IFsy       ].nam:='if        ' ; rsv[DOsy       ].nam:='do        ' ;
    rsv[OFsy       ].nam:='of        ' ; rsv[TOsy       ].nam:='to        ' ;
    rsv[INsy       ].nam:='in        ' ; rsv[ORsy       ].nam:='or        ' ;
    rsv[ENDsy      ].nam:='end       ' ; rsv[FORsy      ].nam:='for       ' ;
    rsv[VARsy      ].nam:='var       ' ; rsv[DIVsy      ].nam:='div       ' ;
    rsv[MODsy      ].nam:='mod       ' ; rsv[SETsy      ].nam:='set       ' ;
    rsv[ANDsy      ].nam:='and       ' ; rsv[NOTsy      ].nam:='not       ' ;
    rsv[NILsy      ].nam:='nil       ' ; rsv[THENsy     ].nam:='then      ' ;
    rsv[ELSEsy     ].nam:='else      ' ; rsv[WITHsy     ].nam:='with      ' ;
    rsv[GOTOsy     ].nam:='goto      ' ; rsv[CASEsy     ].nam:='case      ' ;
    rsv[TYPEsy     ].nam:='type      ' ; rsv[FILEsy     ].nam:='file      ' ;
    rsv[BEGINsy    ].nam:='begin     ' ; rsv[UNTILsy    ].nam:='until     ' ;
    rsv[WHILEsy    ].nam:='while     ' ; rsv[ARRAYsy    ].nam:='array     ' ;
    rsv[CONSTsy    ].nam:='const     ' ; rsv[LABELsy    ].nam:='label     ' ;
    rsv[REPEATsy   ].nam:='repeat    ' ; rsv[RECORDsy   ].nam:='record    ' ;
    rsv[DOWNTOsy   ].nam:='downto    ' ; rsv[PACKEDsy   ].nam:='packed    ' ;
    rsv[PROGRAMsy  ].nam:='program   ' ; rsv[FUNCTIONsy ].nam:='function  ' ;
    rsv[PROCEDUREsy].nam:='procedure ' ;
    for s:=IFsy to PROCEDUREsy do rsv[s].count := 0  ; { 予約語出現数クリア }

    rsvent[2]:=IFsy       ; rsvent[3]:=ENDsy       ; rsvent[4]:=THENsy ;
    rsvent[5]:=BEGINsy    ; rsvent[6]:=REPEATsy    ; rsvent[7]:=PROGRAMsy ;
    rsvent[8]:=FUNCTIONsy ; rsvent[9]:=PROCEDUREsy ;
    rsvent[10]:=identsy   ; { 10文字用エントリはfor文のリピートのために必要}

    for c:=chr(0) to chr(255) do chtype[c] := other  ; { まず全部をその他に }
    for c:='A'    to 'Z'      do chtype[c] := letter ; { 大文字は英字       }
    for c:='a'    to 'z'      do chtype[c] := letter ; { 小文字は英字       }
    for c:='0'    to '9'      do chtype[c] := number ; { 数字は  数字       }

    root    := nil ;                    { 名前リストの根の初期設定     }
    with WKidlist,WKlnumlist do         { リスト作業用エリアの初期設定 }
    begin
     lnump := nil ; leftp := nil ; rightp := nil ; { WKidlist   }
     next  := nil                                  { WKlnumlist }
    end ;

    for i:=1 to MaxIDlen do clearID[i] := ' ' ;

    reset(source)  ;                    { ｿｰｽﾌｧｲﾙを検査ﾓｰﾄﾞにする  }
    linenum := 1   ;                    { 行番号カウンタ初期化     }
    inpchar := ' '                      { 読み込み文字を初期化     }
  end {init} ;

{******************************}
{*      名前取得              *}
{******************************}
  function  getID : Boolean ;           { eof時に偽  通常は真 }
    label 999 ;                         { getID関数終了のラベル eof時飛ぶ }
    var   kind : symbol ;               { 名前か予約語かの判断に使う }

  {******************************}
  {*      1文字読み込み         *}
  {******************************}
    procedure nextch ;
    begin
      if eof(source) then goto 999 ;    { eof検出時 getID関数終了｡
                                          Pascalではプログラムの最後が
                                          end. だからこれで良い }
      if eoln(source) then              { 改行コードの時 }
      begin
        readln(source) ;                { 改行コード読み飛ばし }
        linenum := linenum + 1 ;        { 行番号カウントアップ }
        inpchar := ' '                  { 空白に置き換え       }
      end
      else read(source,inpchar)         { 改行でなければそのまま読む }
    end {nextch} ;

  {******************************}
  {*      注釈読み飛ばし        *}
  {******************************}
    procedure skipcomment ;
      var endflag : Boolean ;           { 注釈の終わりの時 真  }

    {****************************}
    {*   ｼﾌﾄJISｺｰﾄﾞ1ﾊﾞｲﾄ目ﾁｪｯｸ  *}
    {****************************}
      function iskanji(ch:char) : Boolean ;
      begin
        iskanji := ( (chr(129)<=ch) and (ch<=chr(159)) ) or
                   ( (chr(224)<=ch) and (ch<=chr(239)) )
      end {iskanji} ;

    begin {skipcomment}
      repeat
        nextch ;
        while iskanji(inpchar) do       { ｼﾌﾄJISｺｰﾄﾞの1バイト目ならば  }
        begin
          nextch ; nextch               { 2バイト分読み飛ばし          }
        end ;
        if inpchar = '*' then
             endflag := (source^ = ')') or (source^ = '}')
                            { source^ には次の文字が入っているのがミソ }
        else endflag := inpchar = '}'
      until endflag ;
      nextch                            { nextchしなくてもうまくいく   }
    end {skipcomment} ;

  {******************************}
  {*      名前の処理            *}
  {******************************}
    function name : symbol ;
      label 9 ;                         { 予約語の時jump  }
      var   length : integer ;          { 名前の長さ      }
             s     : symbol  ;          { for文の制御変数 }
    begin
      ID := clearID ;
      WKlnumlist.lnum := linenum ;
      length := 0 ;
      repeat
        if ('A'<=inpchar) and (inpchar<='Z') then { 大文字の時   }
          inpchar:=chr(ord(inpchar)+ord(' ')) ;   { 小文字に変換 }
        length := length + 1 ;
        if length <= MaxIDlen then ID[length] := inpchar ; {最大長以降は無視}
        nextch
      until chtype[inpchar] = other ;
      name := identsy ;
      if length in [MinRSVlen..MaxRSVlen-1] then  { 予約語の長さ内にある時 }
        for s:=rsvent[length] to pred(rsvent[length+1]) do
          if ID = rsv[s].nam then       { 予約語の時 }
          begin
            name := s ;
            rsv[s].count := rsv[s].count + 1 ; { 出現回数カウントアップ }
            goto 9
          end ;
    9:end {name} ;

  begin {getID}
    kind  := IFsy ;                     { とりあえず予約語の何かとする }
    repeat                              { 名前が見つかるまで }
      if       chtype[inpchar] = letter then  kind := name { 名前処理 }
      else  if chtype[inpchar] = number then { 数字の時 }
        repeat
          nextch ;
          if (inpchar='e') or (inpchar='E') then nextch
        until chtype[inpchar] <> number
      else  if inpchar = '''' then      { 文字列の時 }
      begin                             { '自身を指定する時 '' とすること }
        repeat                          { になっているので そこを考慮する }
          repeat
            nextch
          until inpchar = '''' ;
          nextch
        until inpchar <> '''' ;
        nextch
      end
      else  if inpchar = '{' then  skipcomment
      else  if inpchar = '(' then
      begin
        nextch ;
        if inpchar = '*' then skipcomment
      end
      else {if chtype[inpchar] = ohter  then} nextch
    until kind=identsy ;
  999 :                                 { eof検出時に飛んでくる }
    getID := not eof(source)            { eofでなければ 名前は取れている }
  end {getID} ;

{******************************}
{*     名前の登録処理         *}
{******************************}
  procedure enterID(var tree : IDlistptr) ;      { 変数引数なのがミソ }

  {******************************}
  {*    行番号リスト登録処理    *}
  {******************************}
    procedure enterNUM(var numlistp : lnumptr) ; { 変数引数なのがミソ }
    begin
      if numlistp = nil then            { 行番号リスト最後尾の時 }
      begin
        new(numlistp) ;
        numlistp^ := WKlnumlist
      end
      else enterNUM(numlistp^.next)     { 途中を探している時 再帰呼び出し }
    end {enterNUM} ;

  begin {enterID}
    if tree = nil then                  { 登録する場所が見つかった時 }
    begin
      new(tree)         ;
      tree^ := WKidlist ;
      tree^.IDENT := ID ;
      enterNUM(tree^.lnump)
    end
    else {if tree<>nil}                 { 登録する場所を探している時 }
      with tree^ do
        if      ID<IDENT then enterID(leftp)  { 今の名前が小さい時は左に登録}
        else if ID>IDENT then enterID(rightp) { 今の名前が大きい時は右の登録}
        else     {=}          enterNUM(lnump) { 同じ名前の時は行番号を登録  }
  end {enterID} ;

{******************************}
{*   クロスリファレンス印字   *}
{******************************}
  procedure print(tree : IDlistptr) ;

  {******************************}
  {* １つの名前印字と行番号印字 *}
  {******************************}
    procedure printName ;
      const width = 5       ;           { 行番号印字幅 }
      var   lnump : lnumptr ;
            colum : integer ;           { 出力済カラム (改行制御に使う) }
    begin
      write(tree^.IDENT)   ;
      lnump := tree^.lnump ;
      colum := MaxIDlen    ;
      repeat                            { 行番号リストの終わりまで }
        write(lnump^.lnum:width);
        colum := colum + width  ;
        lnump := lnump^.next    ;
        if (lnump <> nil) and  (colum > 74) then
        begin                           { 続きがあり、74カラムを越えていれば}
          writeln ;                     { 次の行を名前の長さ分だけ進める    }
          write(' ':MaxIDlen) ;
          colum  := MaxIDlen
        end
      until lnump = nil ;
      writeln
    end {printName} ;

  begin {print}                         { 2分木をこのように処理すると  }
    if tree <> nil then                 { アルファベット順に出力される }
    begin                               { からおもしろい               }
      print(tree^.leftp)  ;
      printName ;
      print(tree^.rightp)
    end
  end {print} ;

{******************************}
{*     予約語出現回数印字     *}
{******************************}
  procedure printCount ;
  begin
    writeln ;
    writeln('==== 主な予約語の出現回数 =====') ;
    with rsv[RECORDsy   ] do writeln(nam,count:5) ;
    with rsv[ARRAYsy    ] do writeln(nam,count:5) ;
    with rsv[FILEsy     ] do writeln(nam,count:5) ;
    with rsv[SETsy      ] do writeln(nam,count:5) ;
    with rsv[PROCEDUREsy] do writeln(nam,count:5) ;
    with rsv[FUNCTIONsy ] do writeln(nam,count:5) ;
    with rsv[IFsy       ] do writeln(nam,count:5) ;
    with rsv[ELSEsy     ] do writeln(nam,count:5) ;
    with rsv[CASEsy     ] do writeln(nam,count:5) ;
    with rsv[FORsy      ] do writeln(nam,count:5) ;
    with rsv[WHILEsy    ] do writeln(nam,count:5) ;
    with rsv[REPEATsy   ] do writeln(nam,count:5) ;
    with rsv[WITHsy     ] do writeln(nam,count:5) ;
    with rsv[GOTOsy     ] do writeln(nam,count:5)
  end {printCount} ;

{******************************}
{*        メイン処理          *}
{******************************}
begin {main}
  init ;                                { 初期設定               }

  while getID do enterID(root) ;        { 名前を取り 登録        }
                                        { ソースのeof検出で終わり}
  print(root) ;                         { クロスリファレンス印字 }
  printCount                            { 予約語出現回数印字     }
end.