スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

F#で入門 コンパイラ 、インタプリタ編 記号表(1)

 さて今回から記号表(symbol table)というものを、取り上げていきたいと思います。
例えば
トークンルールを
let tnR1 =  
    [
    "RPAR","\(";
    "LPAR","\)";
    "SEMI","\;";
    "EQ","=";
    "ADD","\+";
    "MUL","\*";
    "ID","[a-z][a-z0-9]*";
    "NUM","0|[1-9][0-9]*";
    "FNUM","(0|[1-9][0-9]*)\.([0-9]+)"
    ]
文法ルールを
let grammersStrLst1 =
   ["1:Program = DeclStmts ";
    
    "11:DeclStmts = DeclStmt SEMI DeclStmts2";
   
    "31:DeclStmts2  = EPSILON";
    "41:DeclStmts2  = DeclStmts";
    "51:DeclStmt = ID ID InitDefs";
    "61:InitDefs =  EPSILON";
    "71:InitDefs = EQ Exp";
    "72:Exp = Term"
    "73:Exp = Term ADD Term"
    "74:Term = Fact"
    "75:Term = Fact MUL Fact"
    
    "81:Fact = ID";
    "91:Fact = NUM";
    "92:Fact = FNUM";
    "93:Fact = RPAR Exp LPAR"
  
    ]
としておいて、
int x = 2;float y;int k = x + 3;
というプログラムの一部の宣言部分を読み込む場合、
int,x,float,y,k,xはすべてIDトークンとして読み込まれます。
そのintとは何か、xとは何かの意味の対応をつけてやり、あとで使えるように表にしてやる必要があります。このような表を記号表(symbol table)といいます。(表といっても、局所変数等を扱う場合はノード毎にdictionaryやmapをもつツリー構造を使う場合が多いです。)
int x = 2;float y;int k = x + 3;
で考えると、最初のintは組み込み型(事前に定義された型名)として解決され(これを参照(ref)の解決といいます。)xは初期値2のint型の変数として定義され、つぎのfloatは組み込み型として解決され、次のyは初期値未定のfloat変数として定義さて、次の行のxはすでに定義されているint型の変数への参照として解決され、intは組み込み型として解決され、kは初期値(x+3)のint型の変数として定義されます。
このように、参照の解決と、定義が繰り返されているわけです。この記号と意味との対応をsymbol tableとしてまとめていくのですが、今回はその準備として上のトークンルールと、文法ルールより、LR1TokenizeAndParseクラスより、自動生成される具象構文木を、もっと扱いやすい抽象構文木(AST)に変換するまでをやりたいと思います。
そもそも上の文法で書けるのは、宣言文だけですので、広域変数のみをもつプログラム言語の例としてみてください。
ちなみに上のプログラム例から生成される具象構文木は次のようになります。
    (1)1:Program = DeclStmts
       (11)11:DeclStmts = DeclStmt SEMI DeclStmts2
           (51)51:DeclStmt = ID ID InitDefs
               [ID int (1,1)]
               [ID x (1,5)]
               (71)71:InitDefs = EQ Exp
                   [EQ = (1,7)]
                   (72)72:Exp = Term
                       (74)74:Term = Fact
                           (91)91:Fact = NUM
                               [NUM 2 (1,9)]
           [SEMI ; (1,10)]
           (41)41:DeclStmts2  = DeclStmts
               (11)11:DeclStmts = DeclStmt SEMI DeclStmts2
                   (51)51:DeclStmt = ID ID InitDefs
                       [ID float (1,11)]
                       [ID j (1,17)]
                       (61)61:InitDefs =  EPSILON
                   [SEMI ; (1,18)]
                   (41)41:DeclStmts2  = DeclStmts
                       (11)11:DeclStmts = DeclStmt SEMI DeclStmts2
                           (51)51:DeclStmt = ID ID InitDefs
                               [ID int (1,19)]
                               [ID k (1,23)]
                               (71)71:InitDefs = EQ Exp
                                   [EQ = (1,25)]
                                   (73)73:Exp = Term ADD Term
                                       (74)74:Term = Fact
                                           (81)81:Fact = ID
                                               [ID x (1,27)]
                                       [ADD + (1,29)]
                                       (74)74:Term = Fact
                                           (91)91:Fact = NUM
                                               [NUM 3 (1,31)]
                           [SEMI ; (1,32)]
                           (31)31:DeclStmts2  = EPSILON
これを、もっとコンパクトに取扱いしやすいように、抽象構文木に変換して行きたいと思います。
抽象構文木用に次のような型を定義します。
type PosAST0 = int*int //ソース内の位置
type OperAST0 =
    |PlusOPAST0  //+
    |MulOPAST0   //*
                
type ExpAST0 = 
     |VarExpAST0 of string * PosAST0      //変数を表す。
     |IntExpAST0 of string * PosAST0      //3などのint型の即値を表す。
     |FloatExpAST0 of string * PosAST0    //1.0などのfloat型の即値を表す。
     |OpExpAST0 of ExpAST0 * ExpAST0 * OperAST0  //left right op (2項演算を表す。)
and DecAST0 =
     |SimpleDecAST0 of string * PosAST0 * string * PosAST0 //int xなどの宣言を表す
                       //typeName typPos varName varPos 
     |InitDecAST0 of string * PosAST0 * string * PosAST0 * ExpAST0  //int x = 3などの宣言を表す。
                      //typeName typPos varName varPos initExp   
                      
では、具象構文木を受け取り、抽象構文木に変換する関数は次の通りです。
let rec embodyStToAST0 (in_eb:embodyST) =
    match in_eb with
    //1:Program = DeclStmts 
    |Node(1,_,dssNd::_)
        -> embodyStToAST0 dssNd
    //11:DeclStmts = DeclStmt SEMI DeclStmts2
    |Node(11,_,dsNd::_::dsNd2::_)
        -> (embodyStToAST0 dsNd) @ ( embodyStToAST0 dsNd2)
    //31:DeclStmts2  = EPSILON
    |Node(31,_,_)
        -> []
    //41:DeclStmts2  = DeclStmts
    |Node(41,_,dssNd::_)
        ->embodyStToAST0 dssNd
    //51:DeclStmt = ID ID InitDefs
    |Node(51,_,Leaf(tyTkn)::Leaf(varTkn)::idNd::_)
        -> match idNd with
           //61:InitDefs =  EPSILON
           |Node(61,_,_)
                ->[SimpleDecAST0(tyTkn.Img,(tyTkn.Row,tyTkn.Col), varTkn.Img,(varTkn.Row,varTkn.Col))]
           //71:InitDefs = EQ Exp
           |Node(71,_,_::expNd::_)
                ->[InitDecAST0(tyTkn.Img,(tyTkn.Row,tyTkn.Col),varTkn.Img,(varTkn.Row,varTkn.Col),embodyStToExpAST0 expNd)]
           | _ -> failwith("unoccurable error in embodyStToAST0 ")
    |_ ->failwith("unoccurable error in embodyStToAST0 ")
and embodyStToExpAST0 (in_eb:embodyST) = //expノード部分の変換を担当
    match in_eb with
    //72:Exp = Term
    |Node(72,_,termNd::_)
        -> embodyStToExpAST0 termNd
    //73:Exp = Term ADD Term
    |Node(73,_,termNd1::_::termNd2::_)
        ->OpExpAST0(embodyStToExpAST0 termNd1,embodyStToExpAST0 termNd2,PlusOPAST0)
    //74:Term = Fact
    |Node(74,_,factNd::_)
        -> embodyStToExpAST0 factNd
    //75:Term = Fact MUL Fact
    |Node(75,_,factNd1::_::factNd2::_)
        ->OpExpAST0(embodyStToExpAST0 factNd1,embodyStToExpAST0 factNd2,MulOPAST0)
    //81:Fact = ID
    |Node(81,_,Leaf(idTkn)::_)
        ->VarExpAST0(idTkn.Img,(idTkn.Row,idTkn.Col))
    //91:Fact = NUM
    |Node(91,_,Leaf(numTkn)::_)
        ->IntExpAST0(numTkn.Img,(numTkn.Row,numTkn.Col))
    //92:Fact = FNUM
    |Node(92,_,Leaf(fNumTkn)::_)
        ->FloatExpAST0(fNumTkn.Img,(fNumTkn.Row,fNumTkn.Col))
    //93:Fact = RPAR Exp LPAR
    |Node(93,_,_::expNd::_)
        ->embodyStToExpAST0 expNd
    |_->failwith("unoccurable error in embodyStToExpAST0 ")
上の具象構文木を変換した結果は次のようになります。
[InitDecAST0 ("int",(1, 1),"x",(1, 5),IntExpAST0 ("2",(1, 9)));
 SimpleDecAST0 ("float",(1, 11),"j",(1, 17));
 InitDecAST0
   ("int",(1, 19),"k",(1, 23),
    OpExpAST0 (VarExpAST0 ("x",(1, 27)),IntExpAST0 ("3",(1, 31)),PlusOPAST0))]
次回は、広域変数のみをもつ場合の記号表を作っていきたいと思います。
今回のコードは以下の通りです。
 open System
open System.Text.RegularExpressions   
//文法定義のエラー
exception MyGramExcp of string
let STR_EPS ="EPSILON"
//引数分の空白文字を作る補助関数
let spaceStr(i) = 
    let sb = new System.Text.StringBuilder()
    let rec addSpace count =
        if count = i then sb.ToString()
        else
            sb.Append(" ") |> ignore
            addSpace (count + 1)
    addSpace 0 
//////////////////////////////////////////////////////////////////////////////////////////////////////////////////
type Token(kind:string,img:string,row:int,col:int) =
    member this.Kind = kind
    member this.Img = img
    member this.Row = row
    member this.Col = col
    override this.ToString() =
        sprintf "[%s %s (%d,%d)] " kind img row col
//一行をトークン化したときの結果用の型
type TokenizeOneLineResult =
    |TOLSuccess of list<Token>
    |TOLFail of int*int //トークン化失敗したときの行と列
    member this.IsSuccess () =
        match this with
        |TOLSuccess(_) -> true
        | _ -> false
type LR0ItemType = int * int * string * string * string * string list
//                (1,3, "Program", "RPAR", "NULL", ["LPAR"; "Seq"; "RPAR"; "@"])
//タプルの第二成分は同一構文規則内の通し番号、一つ大きいのがマーカーを一つ後ろにずらしたもの
type LR1ItemType = LR0ItemType*Set<string> //Set<string>は先読み記号
//例 ((3, 1, "Exp", "NULL", "Exp", ["@"; "Exp"; "ADD"; "Term"]),["EOF"])
//StateとしてはLR0と同じものを使用
type LR0State =
    SHIFT of int  //構文番号(オートマトンの番号)
    |REDUCE of int*int*string //構文番号(オートマトンの番号ではない)* 還元項の右辺の要素数(@は含まない)* 構文の左辺の非終端名
    |ACCEPT
              //文法番号スタック*入力トークン種別の残り
type anaState = list<int>*list<string>
//具象構文木
type embodyST =
    |EPS_Leaf of Token //tokenは存在しないので、εの直後のtokenを与える
    |Leaf of Token 
    |Node of (int* string * list<embodyST>) //intは構文規則番号,stringは "(1, "Program", ["DeclStmts"; "PrintStmts"])"等
    //表示用
    member this.dispStr (inc :int)  = //inc = インシデント
            match this with
            |EPS_Leaf (token)
                -> spaceStr(inc) +  "ε" + (sprintf "(%d,%d)の前" token.Row token.Col ) + "\r\n"
            |Leaf(token)
                -> spaceStr(inc) +  token.ToString() + "\r\n" 
            |Node(index,str,lst) 
                -> spaceStr(inc) + (sprintf "(%d)" index) + str + "\r\n" 
                   + List.fold (fun state (ele:embodyST) -> state + (ele.dispStr (inc + 4)) ) "" lst 
/////////////////////////////////
type LR1TokenizeAndParse (inDefLst:list<string*string>, inStrLst:list<string>) =
    let initStrLst = "0:Z = Program EOF" :: inStrLst
    let initDefLst =  ("EOF","EOF"):: inDefLst
    let makeTokenizeRules (inDefLst:list<string*string>) =
        inDefLst
            |> List.map(fun (name,rgText) ->(name,(new Regex ( @"^(?<sPart>\s*)(?<parts>" + rgText + @")"))))
    let tokenizeTopPart (textPart:string) (trl:list<string*Regex>) (row:int) (col:int) =
        trl
          |>List.fold (fun (curToken:Token,curLongestLength:int) (name,rg) ->
                            let wholeMatch = rg.Match(textPart)
                            let partMatch = wholeMatch.Groups.["parts"]  //必要な部分
                            let sPartMatch = wholeMatch.Groups.["sPart"] //先頭の空白部分
                            if wholeMatch.Value.Length > curLongestLength then //最長マッチ
                                (new Token(name,partMatch.Value,row, col + sPartMatch.Value.Length),wholeMatch.Value.Length )
                            else
                                (curToken,curLongestLength)
                      )
                      (new Token("","",0,0),0)
    let tokenizeOneLine (inDefLst:list<string*string>) (inRow:int) (inOneLineStr:string) =
        let trs = makeTokenizeRules inDefLst
        let rec tokenizeOneLineSub (curCol:int) (remainStr:string) res =
            if remainStr.Trim().Length = 0 then
                TOLSuccess(List.rev res)
            else
               let (slicedToken,length) = tokenizeTopPart remainStr trs inRow curCol
               if length = 0 then
                    let topBlankNum = remainStr.Length - remainStr.TrimStart().Length
                    TOLFail(inRow,curCol+topBlankNum)
               else
                  tokenizeOneLineSub (curCol + length) (remainStr.Substring(length)) (slicedToken::res)       
        tokenizeOneLineSub 1 inOneLineStr []
    let tokenizer  (source:list<string>) =
        let oneLineTokenizer = tokenizeOneLine initDefLst
        let isTOLSuccess (x:TokenizeOneLineResult) =
            match x with
            |TOLSuccess(_) -> true
            |_             -> false
        let sucLst,failLst =
            source
            |>List.map (fun str -> str.TrimEnd())
            |>List.mapi (fun i str -> oneLineTokenizer (i+1) str )
            |>List.partition (fun tr -> tr.IsSuccess () )
        if failLst.Length > 0 then 
            failwith (sprintf "%A" failLst)
        else 
            sucLst
              |>List.map (fun tolr -> match tolr with
                                         |TOLSuccess(tol) -> tol
                                         | _ -> failwith "error" //これは起こらない
                         )
              |>List.fold (fun s lst -> s @ lst) []
        
    let splitOneLineGram (inStr:string)=
        let (lhdIndex,rhd) = 
            match inStr.Split([|':'|]) with
            [|mlhd;mrhd|]  ->  (mlhd.Trim(),mrhd)
            | _             ->  raise <| MyGramExcp(inStr) 
        let (lhd,rhd2) =
            match rhd.Split([|'='|]) with
            |[|mlhd;mrhd|]  ->  (mlhd.Trim(),mrhd)
            | _             ->  raise <| MyGramExcp(inStr) 
        let rhdElems = 
            rhd2.Split([|' '|])
                |> List.ofArray
                |> List.map (fun s -> s.Trim())
                |> List.filter (fun s -> s <> "")
        (System.Int32.Parse(lhdIndex),lhd,rhdElems)
    let getNTN_TN__Sets (inStrLst:list<string>) =
        let (sumUpLhdSet,sumUpRhdSet) =
            inStrLst
                |> List.map splitOneLineGram
                |> List.fold (fun (acclh,accrh)  (_,lhd,rhdLst) -> (lhd :: acclh,rhdLst @ accrh)) ([],[])
                |> (fun (hdLst,rhLst) -> (Set.ofList hdLst, Set.ofList rhLst))
        (sumUpLhdSet,sumUpRhdSet - sumUpLhdSet - (Set.ofList [STR_EPS]))
    let (ntnSet,tnSet) =  getNTN_TN__Sets initStrLst  
    let isNullableToken ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)(inTokenName:string) =
        if inTokenName = STR_EPS then 
             true
        elif Set.contains inTokenName in_tn then
             false
        else
            in_ntnNullableMap.[inTokenName]
    let isNullableTokenLst ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)(inTokenNameLst:list<string>) =
          List.forall (isNullableToken (in_ntn,in_tn) in_ntnNullableMap )inTokenNameLst //リスト中のすべてのtokenがnullableか
          
    let isNullableTokenLstLst ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)(inTokenNameLstLst:list<list<string>>) =
          List.exists (isNullableTokenLst (in_ntn,in_tn) in_ntnNullableMap ) inTokenNameLstLst//リスト中のどれかのtokenリストがnullableか
    let grams = initStrLst
                    |> List.map splitOneLineGram
                    |> List.map (fun (_,lh,rhEles) -> (lh,rhEles)) //[("Program",["DeclStmts";"PrintStmts"]);("DeclStmts",["VAR";"SEMI"])]
 
    let getNTN_NullableMap (inStrLst:list<string>) =
    
   
        let rec getNTN_NullableMapSub (inOldNullableMap:Map<string,bool>) (count:int) = 
            let nextNullableMap =
                ntnSet
                    |> Set.fold (fun stateMap ele ->
                                    let targetGramsLstLst =
                                        grams
                                            |>List.filter (fun (ntnName,_) -> ntnName = ele)
                                            |>List.map (fun (_,lst) -> lst)
                                    let thisEleNullable =
                                        isNullableTokenLstLst(ntnSet,tnSet) inOldNullableMap targetGramsLstLst
                                    Map.add ele thisEleNullable stateMap
                                 )
                                 Map.empty
            if count > 10000 then
                failwith "count error"
            elif nextNullableMap = inOldNullableMap then
                nextNullableMap
            else
                getNTN_NullableMapSub nextNullableMap (count + 1)
    
        let initNullableMap =
                    ntnSet
                        |> Set.map (fun ele -> (ele,false))
                        |> Map.ofSeq
    
        getNTN_NullableMapSub initNullableMap 0
    let ntnNullableMap = getNTN_NullableMap initStrLst
    let getFirstSetOfToken ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnFirstSetMap:Map<string,Set<string>>)(inTokenName:string) =
        if inTokenName = STR_EPS then 
             Set.empty
        elif Set.contains inTokenName in_tn then
             Set.ofList ([inTokenName])
        else
            in_ntnFirstSetMap.[inTokenName]
    let getFirstSetOfTokenLst ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)
                               (in_firstSetMap:Map<string,Set<string>>) (inTokenNameLst:list<string>) =
          let isNullableTokenPartApply = isNullableToken (in_ntn,in_tn) in_ntnNullableMap   
      
          let rec getFirstSetOfTokenLstSub (tokenLst:list<string>)  =
            match tokenLst with
            |[] -> Set.empty
            |hd::tl when isNullableTokenPartApply hd -> (getFirstSetOfToken (in_ntn,in_tn) in_firstSetMap hd) + (getFirstSetOfTokenLstSub tl)
            |hd::tl                                  -> (getFirstSetOfToken (in_ntn,in_tn) in_firstSetMap hd)
          getFirstSetOfTokenLstSub inTokenNameLst
    let getFirstSetOfTokenLstLst ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)
                              (in_firstSetMap:Map<string,Set<string>>) (inTokenNameLstLst:list<list<string>>) =  
        let getFirstSetOfTokenLstPartApply = getFirstSetOfTokenLst (in_ntn,in_tn) in_ntnNullableMap in_firstSetMap
    
        List.fold (fun acc ele -> acc + (getFirstSetOfTokenLstPartApply ele)) Set.empty inTokenNameLstLst
    let getNTN_FirstMap  (inStrLst:list<string>) =
    
        let FisrtSetOfTokenLstLstPA = getFirstSetOfTokenLstLst (ntnSet,tnSet) ntnNullableMap
    
        let rec getNTN_FirstMapSub (inOldFirstMap:Map<string,Set<string>>) (count:int) = 
            let nextFirstMap =
                ntnSet
                    |> Set.fold (fun stateMap ele ->
                                    let targetGramsLstLst =
                                        grams
                                            |>List.filter (fun (ntnName,_) -> ntnName = ele)
                                            |>List.map (fun (_,lst) -> lst)
                                    let thisEleFisrtSet =
                                         FisrtSetOfTokenLstLstPA inOldFirstMap targetGramsLstLst
                                    Map.add ele thisEleFisrtSet stateMap
                                 )
                                 Map.empty
            if count > 10000 then
                failwith "count error"
            elif nextFirstMap = inOldFirstMap then
                nextFirstMap
            else
                getNTN_FirstMapSub nextFirstMap (count + 1)
    
        let initFirstMap =
                    ntnSet
                        |> Set.map (fun ele -> (ele,Set.empty))
                        |> Map.ofSeq
    
        getNTN_FirstMapSub initFirstMap 0
    let ntnFirstMap = getNTN_FirstMap initStrLst
    
    let getAfterTokens (inStr:string) ((lhdStr,rhStrLst):string*list<string>) =
        let rec getAfterTokensSub strLst res =
            match strLst with
            |hd::tl when hd = inStr -> getAfterTokensSub tl ((tl,lhdStr)::res)
            |hd::tl                 -> getAfterTokensSub tl res
            | [] -> res
        getAfterTokensSub rhStrLst []
    
    let getNTN_FollowMap  (inStrLst:list<string>) =
        let isNullableTokensLstPA (tokenLst:list<string>) = isNullableTokenLst (ntnSet,tnSet) ntnNullableMap tokenLst
        let getFirstSetOfTokenLstPA (tokenLst:list<string>) = getFirstSetOfTokenLst (ntnSet,tnSet) ntnNullableMap  ntnFirstMap tokenLst
 
        let rec getNTN_FollowMapSub (inOldFollowMap:Map<string,Set<string>>) (count:int) = 
           let getFollowSet (afterTokens:list<string>,ntnName:string) =
                    if isNullableTokensLstPA afterTokens then
                        (getFirstSetOfTokenLstPA afterTokens) + (inOldFollowMap.[ntnName])
                    else
                        (getFirstSetOfTokenLstPA afterTokens)                
           let nextFollowMap =
                ntnSet
                    |> Set.fold (fun stateMap ele ->
                                    let includeEleGrams =
                                        grams
                                          |> List.fold (fun state2 (ntnName2,tokenLst)
                                                            -> state2 @ (getAfterTokens ele (ntnName2,tokenLst)))
                                                        []
                                                    
                                    let followSet =
                                        includeEleGrams
                                          |> List.fold (fun (state3:Set<string>) (afterTokens,ntnName) ->
                                                        state3 + (getFollowSet (afterTokens,ntnName)))
                                                        Set.empty
                                    Map.add ele followSet stateMap
                                 )
                                 Map.empty
           if count > 10000 then
                failwith "count error"
           elif nextFollowMap = inOldFollowMap then
                nextFollowMap
           else
                getNTN_FollowMapSub nextFollowMap (count + 1)
        let initFollowMap =
                    ntnSet
                        |> Set.map (fun ele -> (ele,Set.empty))
                        |> Map.ofSeq
    
        getNTN_FollowMapSub initFollowMap 0
    
    let ntnFollowMap = getNTN_FollowMap initStrLst
    ///////////////////////////////////////////LR1部分////////////////////////////////////////////////////////////////////////
    //マーカーを付けて、マーカーの前後の記号とそれのタプルを返す
    let addMarkers (idNum:int, lhName:string, inLst:list<string>) =
        if inLst = [STR_EPS] then
            [(idNum,1,lhName,"NULL","NULL",["@"])]
        else
            let withSenti ="NULL"::inLst @ ["NULL"]
            let rec addMarkerSub (lst:list<string>) (acchd:list<string>) accLst (counter) =
                match lst with
                |hd::tl when tl <> [] 
                    -> addMarkerSub tl (acchd @ [hd]) ((idNum,counter,lhName,hd, List.head tl,((acchd @ [hd] @ ["@"] @ tl)))::accLst) (counter+1)
                |_ ->  accLst |> List.map (fun (id,cnt,lh,bef,aft,resLst) -> (id,cnt,lh,bef,aft,resLst |> List.rev |> List.tail |> List.rev |> List.tail))
    
            List.rev (addMarkerSub withSenti [] [] 1)
    let getGramWithMarker (inStr:string) =
        splitOneLineGram inStr  
          |> addMarkers
    let getLR1Terms (inStrLst:list<string>) =
       let (ntnSet,ntSet) = getNTN_TN__Sets  inStrLst
       let lr0TermsSet =
            inStrLst
                |> List.map getGramWithMarker
                |> List.concat
                |> Set.ofList
       let shiftItemsSet = //markerの直後が終端記号
            Set.filter (fun (_,_,_,_,aft,_) -> Set.contains aft ntSet) lr0TermsSet
       let reduceItemsSet = //markerが末尾
            Set.filter (fun (_,_,_,_,aft,_) -> aft = "NULL") lr0TermsSet
       let topMarker_ItemsSet = //markerが先頭
           Set.filter (fun (_,_,_,bfr,_,_) -> bfr = "NULL") lr0TermsSet
   
       let ntnAfterMarkerItemsSet = //markerの直後が非終端記号
          Set.filter (fun (_,_,_,_,aft,_) -> Set.contains aft ntnSet) lr0TermsSet
  
   
       let lr0TItemsMap =
         lr0TermsSet 
            |> Set.map (fun (id,subId,lhName,bfr,aft,lst) -> ((id,subId),(id,subId,lhName,bfr,aft,lst)))
            |> Map.ofSeq  
   
       //markerの直後が非終端記号のものについては、その要素とmarkerの直後の非終端記号の後のリストを組にする
       //補助関数
       let rec ntnAMSub lst  =
            match lst with
            |hd::tl when hd = "@" -> List.tail tl
            |hd::tl -> ntnAMSub tl 
            | [] -> failwith "neverOccurableError"
   
       let rec makeMap inLst accMap =
            match inLst with
            |[] -> accMap
            |(id,subId,_,_,_,lst)::tl ->makeMap tl (Map.add (id,subId) (ntnAMSub lst) accMap)
       let idSubId2AfterAfterMarkerMap = makeMap (List.ofSeq ntnAfterMarkerItemsSet) Map.empty
      
       (lr0TermsSet,shiftItemsSet,reduceItemsSet,topMarker_ItemsSet,ntnAfterMarkerItemsSet,lr0TItemsMap,idSubId2AfterAfterMarkerMap)
    let getClosure  ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)
                    (in_firstSetMap:Map<string,Set<string>>) 
                    (inIdSubId2AfterAfterMarkerMap:Map<(int * int),string list>) (inNtnAfterMarkerItemsSet:Set<LR0ItemType>) 
                    (inTopMarker_ItemSet:Set<LR0ItemType>) (initI :Set<LR1ItemType>) =
        let rec getClosureSub oldClosureSet =
                                      //oldClosureSetの中で非終端記号の前にマーカーがついている形のもの
            let shouldAddedLR1Items  = Set.filter (fun (ele,_) -> Set.contains ele inNtnAfterMarkerItemsSet) oldClosureSet
            let newClosureSet =
                Set.fold  (fun oldClosureSet ((id,subId,_,_,aft0,_),lookAheads) -> //aftはマーカーの直後の非終端記号
                                let addLRItemBases:Set<LR0ItemType> = Set.filter (fun (_,_,lh,_,_,_ ) -> lh = aft0) inTopMarker_ItemSet
                                let addLR1Items =
                                    addLRItemBases
                                      |> Set.map (fun lr0Item ->
                                                    let afterAfterMarkerLst = inIdSubId2AfterAfterMarkerMap.[(id,subId)] 
                                                    let afterAfterMarkerNullable =
                                                        isNullableTokenLst (in_ntn,in_tn) in_ntnNullableMap afterAfterMarkerLst
                                                    let afterAfterMarkerFirst =
                                                         getFirstSetOfTokenLst (in_ntn,in_tn) in_ntnNullableMap in_firstSetMap afterAfterMarkerLst
                                                    let addLR1ItemLookAheads =
                                                          if afterAfterMarkerNullable = true then 
                                                                afterAfterMarkerFirst + lookAheads
                                                          else
                                                                afterAfterMarkerFirst
                                                    (lr0Item,addLR1ItemLookAheads)
                                                  )
                                oldClosureSet + addLR1Items
                            )
                           oldClosureSet
                           shouldAddedLR1Items
            if newClosureSet = oldClosureSet then
                 newClosureSet
            else 
                getClosureSub newClosureSet
        let res0Lst = List.sort (List.ofSeq (getClosureSub initI)) 
         //ここまででは(5, 1, "Term", "NULL", "ID", ["@"; "ID"]), set ["ADD"]);((5, 1, "Term", "NULL", "ID", ["@"; "ID"]), set ["EQ2"]
        //とまとめるべきものがバラバラになっているのでこれをまとめる。
        let dummyEle = ((-1,-1,"","","",[]),Set.empty)
   
        let (res,_) =  //最後のdummyEleが_にくる
              (res0Lst @ [dummyEle]) |>  
              List.fold (fun (acc:Set<LR1ItemType>,(oldlr0Part:LR0ItemType,oldLookAheadsPart:Set<string>)) (lr0Part:LR0ItemType,lookAhedsPart:Set<string>)
                                    ->if oldlr0Part = lr0Part then
                                            (acc, (oldlr0Part,oldLookAheadsPart + lookAhedsPart))
                                      else      
                                            ((Set.add (oldlr0Part,oldLookAheadsPart) acc),(lr0Part,lookAhedsPart))
                            )
                 (Set.empty,dummyEle)
     
        Set.filter (fun ((a,_,_,_,_,_),_) -> a <> -1) res //最初のdummyEleを除く(これがgetClosureの返り値)
    let getGoto  ((in_ntn,in_tn):Set<string>*Set<string>) (in_ntnNullableMap:Map<string,bool>)
                    (in_firstSetMap:Map<string,Set<string>>) 
                    (inIdSubId2AfterAfterMarkerMap:Map<(int * int),string list>) (inNtnAfterMarkerItemsSet:Set<LR0ItemType>) 
                    (inTopMarker_ItemSet:Set<LR0ItemType>)  (inIRItemMap:Map<(int*int),LR0ItemType>)
                    (inLR1ItemSet:Set<LR1ItemType>) (inStr:string) =
        let getClosurePA = getClosure (in_ntn,in_tn) in_ntnNullableMap in_firstSetMap inIdSubId2AfterAfterMarkerMap
                                        inNtnAfterMarkerItemsSet inTopMarker_ItemSet
        let shouldAddGredienceLR1Items = Set.filter (fun ((_,_,_,_,aft,_),_) -> aft = inStr) inLR1ItemSet 
        let tempSet = //マーカーをずらしたものの集合
                shouldAddGredienceLR1Items
                    |> Set.fold (fun accSet ((i,j,_,_,_,_),lookAheads) ->  
                                    let addItemLR0Part = inIRItemMap.[(i,j+1)] //(マーカーを一つ進めたもの(マーカーの次はinStr)) 
                                    let addLR1Item = (addItemLR0Part,lookAheads)
                                    Set.add addLR1Item accSet  
                                )
                       Set.empty 
    
        getClosurePA tempSet
    let makeLR1Map (inGrams:list<string>) =
    
        let (ntnSet,tnSet) = getNTN_TN__Sets  inGrams
        let wholeNtnAndTnLst = List.ofSeq(ntnSet + tnSet)
        let (whole,shift,reduce,topM,ntnAftM,lr0TItemsMap,idSubId2AfterAfterMarkerMap) = getLR1Terms inGrams
    
        let (ntn,tn) = getNTN_TN__Sets inGrams
        let ntnNullableMap = getNTN_NullableMap inGrams
        let firstSetMap = getNTN_FirstMap inGrams
        //受理状態のみを含むClosureか 
        let isFinalLR1Item (cls:Set<LR1ItemType>)  = 
               (Set.exists (fun ((_,_,lh,bfr,aft,_),_) ->lh = "Z" && bfr = "Program" && aft = "EOF") cls)  && (Set.count cls = 1)
        //引数のmapに受理状態のみを含むClosureについてEOFの欄だけの項を付け加えて返す。(「noは受理状態のみを含むClosure」の番号を渡す)
        let addFinalRow2map (idNo:int) (seedMap:Map<int*string,LR0State>) =
               List.fold  (fun stateMap ele ->
                                if ele <> "EOF" then stateMap  //なにもマップに付け加えない。
                                else Map.add (idNo,"EOF") ACCEPT stateMap
                          )
                          seedMap
                          wholeNtnAndTnLst
        let getGotoPA = getGoto (ntn,tn) ntnNullableMap firstSetMap idSubId2AfterAfterMarkerMap ntnAftM topM lr0TItemsMap
        let rec makeMapSub (ntn_tnLst:List<string>) (curProcessingClsNo:int) (curExistClsNum:int) 
                           (accCls2IdMap:Map<Set<LR1ItemType>,int>) (accId2ClsMap:Map<int,Set<LR1ItemType>>) 
                           (accMap:Map<int*string,LR0State>) =
            //表の右下まで到達
            if ntn_tnLst = [] && curProcessingClsNo = curExistClsNum then 
                    (accId2ClsMap,accMap)
            //表の右端まで到達
            elif ntn_tnLst = [] && curProcessingClsNo < curExistClsNum then
                    makeMapSub wholeNtnAndTnLst (curProcessingClsNo + 1)  curExistClsNum  accCls2IdMap accId2ClsMap accMap
            //受理状態のみを含むClosureの左端の場合
            elif  isFinalLR1Item  accId2ClsMap.[curProcessingClsNo] = true then 
                    let addedMap = addFinalRow2map curProcessingClsNo accMap
                    makeMapSub wholeNtnAndTnLst (curProcessingClsNo + 1) curExistClsNum  accCls2IdMap accId2ClsMap addedMap
            //一般状態
            else    
               match ntn_tnLst with
                |[] -> //右端に来る場合は最初の2つの場合でチェック済み
                    failwith "neverOccurable Error"
                |hd::tl ->
                    //還元の可能性を調べる(ここの扱いがSLRと異なる)
                    let reduceItems =
                       accId2ClsMap.[curProcessingClsNo]
                        |> Set.filter (fun ((_,_,_,_,aft,_),lookAheads) -> aft = "NULL" && Set.contains hd lookAheads )
                    if  Set.count reduceItems > 1 then
                        failwith (sprintf "還元/還元衝突 %s  %A " hd reduceItems )
                
                    elif Set.count reduceItems = 1 then //還元項がある場合
                        //シフトの可能性を調べる
                        let shiftableItems = 
                            accId2ClsMap.[curProcessingClsNo] 
                                |>Set.filter (fun ((_,_,_,_,aft,_),_) -> aft = hd)  
                    
                        if Set.count shiftableItems >= 1 then
                            failwith (sprintf "シフト/還元衝突 %s  reduceItems = %A \n shiftItem = %A" hd reduceItems shiftableItems )
                        else //還元としてMapに追加
                            match List.head (List.ofSeq reduceItems) with //要素は一個だけ
                            |((gramNo,_,lhName,_,_,lstWithMarker),_) -> 
                                    makeMapSub tl curProcessingClsNo curExistClsNum accCls2IdMap accId2ClsMap 
                                            (Map.add (curProcessingClsNo,hd) (REDUCE(gramNo,((List.length lstWithMarker) - 1),lhName))  accMap) 
                
                    else //還元しない場合(シフトもしくは対象なしの場合)
                        let newGoto = getGotoPA accId2ClsMap.[curProcessingClsNo] hd //処理中のclosureとtermからGoto集合を求める
                        if newGoto = Set.empty then //行先なし(表として空欄になる)場合(なにも付け加えない)
                               makeMapSub tl curProcessingClsNo curExistClsNum accCls2IdMap accId2ClsMap accMap
                        else
                            match (Map.tryFind newGoto accCls2IdMap) with
                            //newGotoがすでに、Closureとして存在する場合
                            |Some(i) -> makeMapSub tl curProcessingClsNo curExistClsNum 
                                                   accCls2IdMap accId2ClsMap (Map.add (curProcessingClsNo,hd)  (SHIFT(i)) accMap)
                            //newGotoがまだ、Closureとして存在しない場合
                            |None    ->let newAccCls2IdMap = Map.add newGoto (curExistClsNum + 1) accCls2IdMap
                                       let newAccId2ClsdMap = Map.add (curExistClsNum + 1) newGoto accId2ClsMap
                                       makeMapSub tl curProcessingClsNo (curExistClsNum + 1) 
                                                   newAccCls2IdMap newAccId2ClsdMap (Map.add (curProcessingClsNo,hd)  (SHIFT(curExistClsNum + 1)) accMap) 
        let initI = ((0,1, "Z", "NULL", "Program", ["@"; "Program"; "EOF"]),Set.ofList ["EOF"])
        let cls1 = getClosure  (ntn,tn) ntnNullableMap firstSetMap idSubId2AfterAfterMarkerMap ntnAftM topM (Set.ofList [initI])
        let initAccCls2IdMap = Map.ofList [(cls1,1)]
        let initId2accCls = Map.ofList [(1,cls1)]
        makeMapSub wholeNtnAndTnLst 1 1  initAccCls2IdMap initId2accCls Map.empty
    //リストからn個の要素をpopして残りを返す補助関数
    let popN in_lst in_n =
        let rec popNSub lst count =
            if count = in_n then
                lst
            else
                popNSub (List.tail lst) (count + 1)
        popNSub in_lst 0
    //リストからn個の要素をpopしてpopしたものと残りを返す補助関数
    let getPopN in_lst in_n =
        let rec popNSub lst acc count =
            if count = in_n then
                (List.rev acc,lst)
            else
                popNSub (List.tail lst) ((List.head lst)::acc) (count + 1)
        popNSub in_lst [] 0
    /////////////////id2gramRuleMapは構文番号->構文内容へのMap
    let getTree (id2gramRuleMap:Map<int,string>) (in_idTerm2VLR1Map:Map<int*string,LR0State>) (inTokenLst:list<Token>) =
        
        let rec getTreeSub  ((stk,rem):anaState) (stkOfTree:list<embodyST>,remOfTree:list<embodyST>)=
            let curAtmtnst = List.head stk
            let topRemain = List.head rem
            let nextMove = Map.tryFind   (curAtmtnst,topRemain) in_idTerm2VLR1Map
            let topRemainNode = List.head remOfTree
            match nextMove with
            |Some(SHIFT(nextAtmtnNo)) ->
                        getTreeSub (nextAtmtnNo::stk,List.tail rem) (topRemainNode::stkOfTree,List.tail remOfTree)
            
            |Some(REDUCE(ruleNo,graEleNum,lhName)) ->
                        let (popNodes,remT) = getPopN stkOfTree graEleNum
                        getTreeSub (popN stk graEleNum ,lhName::rem) (remT,(Node(ruleNo,id2gramRuleMap.[ruleNo],(List.rev popNodes)))::remOfTree)
            |Some(ACCEPT)->      //終了の場合は状態を変えない
                    List.head stkOfTree
            |None   ->
                    failwith "ソースが文法にのっとっていません"
        
        let initTokenKindLst = inTokenLst |> List.map (fun tkn -> tkn.Kind)
        let initNodeLst = inTokenLst |> List.map (fun tkn -> Leaf(tkn))
        getTreeSub ([1],initTokenKindLst) ([],initNodeLst)
 
    let id2gramRuleMap = //[(5,"5:Program = DeclStmts PrintStmts");.....という形
          initStrLst
            |> List.map (fun s -> 
                            let (no,lhName,_) = splitOneLineGram s
                            (no,s)
                        )
            |> Map.ofList
    //このMapを使ってトークン列を解析する
    let (_,lr1Map) = makeLR1Map initStrLst
    let getTreePA = getTree id2gramRuleMap lr1Map
    member this.GetTokens (sourceLst:list<string>) =  
        tokenizer sourceLst  
    member this.GetEBASTtree (sourceLst:list<string>) =  
        let forTokenizedLst =  sourceLst @ ["EOF"]
        let tokens = tokenizer forTokenizedLst
        getTreePA tokens
///////////////type LR1TokenizeAndParse end///////////////////////////////////////////////////////////////////////////
 
let tnR1 =  
    [
    "RPAR","\(";
    "LPAR","\)";
    "SEMI","\;";
    "EQ","=";
    "ADD","\+";
    "MUL","\*";
    "ID","[a-z][a-z0-9]*";
    "NUM","0|[1-9][0-9]*";
    "FNUM","(0|[1-9][0-9]*)\.([0-9]+)"
    ]
let grammersStrLst1 =
   ["1:Program = DeclStmts ";
    
    "11:DeclStmts = DeclStmt SEMI DeclStmts2";
   
    "31:DeclStmts2  = EPSILON";
    "41:DeclStmts2  = DeclStmts";
    "51:DeclStmt = ID ID InitDefs";
    "61:InitDefs =  EPSILON";
    "71:InitDefs = EQ Exp";
    "72:Exp = Term"
    "73:Exp = Term ADD Term"
    "74:Term = Fact"
    "75:Term = Fact MUL Fact"
    
    "81:Fact = ID";
    "91:Fact = NUM";
    "92:Fact = FNUM";
    "93:Fact = RPAR Exp LPAR"
  
    ]
//抽象木
type PosAST0 = int*int //ソース内の位置
type OperAST0 =
    |PlusOPAST0 
    |MulOPAST0 
                
type ExpAST0 = 
     |VarExpAST0 of string * PosAST0   
     |IntExpAST0 of string * PosAST0
     |FloatExpAST0 of string * PosAST0
     |OpExpAST0 of ExpAST0 * ExpAST0 * OperAST0  //left right op 
and DecAST0 =
     |SimpleDecAST0 of string * PosAST0 * string * PosAST0//typeName typPos varName varPos 
     |InitDecAST0 of string * PosAST0 * string * PosAST0 * ExpAST0  //typeName typPos varName varPos initExp   
let rec embodyStToAST0 (in_eb:embodyST) =
    match in_eb with
    //1:Program = DeclStmts 
    |Node(1,_,dssNd::_)
        -> embodyStToAST0 dssNd
    //11:DeclStmts = DeclStmt SEMI DeclStmts2
    |Node(11,_,dsNd::_::dsNd2::_)
        -> (embodyStToAST0 dsNd) @ ( embodyStToAST0 dsNd2)
    //31:DeclStmts2  = EPSILON
    |Node(31,_,_)
        -> []
    //41:DeclStmts2  = DeclStmts
    |Node(41,_,dssNd::_)
        ->embodyStToAST0 dssNd
    //51:DeclStmt = ID ID InitDefs
    |Node(51,_,Leaf(tyTkn)::Leaf(varTkn)::idNd::_)
        -> match idNd with
           //61:InitDefs =  EPSILON
           |Node(61,_,_)
                ->[SimpleDecAST0(tyTkn.Img,(tyTkn.Row,tyTkn.Col), varTkn.Img,(varTkn.Row,varTkn.Col))]
           //71:InitDefs = EQ Exp
           |Node(71,_,_::expNd::_)
                ->[InitDecAST0(tyTkn.Img,(tyTkn.Row,tyTkn.Col),varTkn.Img,(varTkn.Row,varTkn.Col),embodyStToExpAST0 expNd)]
           | _ -> failwith("unoccurable error in embodyStToAST0 ")
    |_ ->failwith("unoccurable error in embodyStToAST0 ")
and embodyStToExpAST0 (in_eb:embodyST) = //expノード部分の変換を担当
    match in_eb with
    //72:Exp = Term
    |Node(72,_,termNd::_)
        -> embodyStToExpAST0 termNd
    //73:Exp = Term ADD Term
    |Node(73,_,termNd1::_::termNd2::_)
        ->OpExpAST0(embodyStToExpAST0 termNd1,embodyStToExpAST0 termNd2,PlusOPAST0)
    //74:Term = Fact
    |Node(74,_,factNd::_)
        -> embodyStToExpAST0 factNd
    //75:Term = Fact MUL Fact
    |Node(75,_,factNd1::_::factNd2::_)
        ->OpExpAST0(embodyStToExpAST0 factNd1,embodyStToExpAST0 factNd2,MulOPAST0)
    //81:Fact = ID
    |Node(81,_,Leaf(idTkn)::_)
        ->VarExpAST0(idTkn.Img,(idTkn.Row,idTkn.Col))
    //91:Fact = NUM
    |Node(91,_,Leaf(numTkn)::_)
        ->IntExpAST0(numTkn.Img,(numTkn.Row,numTkn.Col))
    //92:Fact = FNUM
    |Node(92,_,Leaf(fNumTkn)::_)
        ->FloatExpAST0(fNumTkn.Img,(fNumTkn.Row,fNumTkn.Col))
    //93:Fact = RPAR Exp LPAR
    |Node(93,_,_::expNd::_)
        ->embodyStToExpAST0 expNd
    |_->failwith("unoccurable error in embodyStToExpAST0 ")
let tp1 = new LR1TokenizeAndParse (tnR1,grammersStrLst1)
let src0 = ["int x = 2;float j;int k = x + 3; "]
let t = tp1.GetEBASTtree(src0)
printfn "%A" (t.dispStr 4)
printfn "%A" (embodyStToAST0 t)
スポンサーサイト

テーマ : プログラミング
ジャンル : コンピュータ

コメントの投稿

非公開コメント

プロフィール

T GYOUTEN

Author:T GYOUTEN
F#と英単語とフリーソフトと読書に興味があります。
ホームページでフリーソフトも公開しています。どぞ御贔屓に。

最新記事
最新コメント
最新トラックバック
月別アーカイブ
カテゴリ
フリーエリア
フリーエリア
blogram投票ボタン
検索フォーム
RSSリンクの表示
リンク
ブロとも申請フォーム

この人とブロともになる

QRコード
QRコード
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。