unit UTslCodeFormat;
interface
uses utslvclauxiliary;
//TSL代码格式化 code 为代码,tabwidth 为缩进空格数 LineWordCount 为单行最大的词数目 linelength 字符最多个数
//20210311 美化了函数定义换行的问题
//20210406 LineWordCount  linelength 两个参数已经不起作用
//20210308 添加 ABComment 参数,控制块注释的行首缩进
//20220914 移动tire树到 utslvclauxiliary 
function FormatTsl(Code,tabwidth,LineWordCount,linelength,arraytype,ABComment);
type TTslFParser = class(TFormatParser)
    function Create();
    begin
        inherited;
    end 
end 
implementation
function  FormatTsl(Code,tabwidth,LineWordCount,linelength,arraytype,AlignBlockComment);
begin
    pser := static new TFormatParser();
    pser.Script := code;
    pser.ArrayType := ArrayType;
    if tabwidth>1 then pser.HierarchyWidth := tabwidth;
    pser.AlignBlockComment := AlignBlockComment;
    //if LineWordCount>0 or LineWordCount<0 then pser.MaxLineCount := LineWordCount;
    //if linelength>0 or linelength<0 then pser.MaxLineLength := linelength;
    return pser.FormatCode();
end 
type TFormatParser = class
    TK_STR;    //字符串 
    TK_W;    //变量
    TK_C;    //各种注释
    TK_C_S;  //单行注释
    TK_C_D1;  //多行 {
    TK_C_D2;  //多行 (*
    TK_SYN ;//符号
    TK_SYN_S;//分离符号
    TK_TSLX ;// 注释 
    TK_KEY;
    TK_TYPE;
    TK_CLASS;
    TK_FUNCTION;
    TK_SELECT;
    TK_UNIT;
    TK_IF;
    TK_THEN;
    TK_ELSE;
    TK_BEGIN;
    TK_END;
    TK_TRY;
    TK_EXCEPT;
    TK_FINALLY;
    TK_CASE;
    TK_OF;
    
    TK_EXTERNAL ; 
    TK_CDECL ;
    TK_STDCALL ;
    TK_NAME ;
    TK_keepresident ;
    TK_OPERATOR;
    TK_PRIVATE;
    TK_ARRAY;
    TK_NEW;
    TK_DO;
    BT_DEF;
    BT_UNIT;
    BT_TYPE;
    
    BT_BEGIN;
    BT_CASE;
    BT_SELECT;
    BT_TRY;
    BT_ARRAY;
    BT_CALC;
    FSynParser;
    FSynParser2;
    FHtmlParser;
    function Create();
    begin 
        TK_STR := 1;    //字符串 
        TK_W := 2;    //变量
        TK_C := 4;    //各种注释
        TK_C_S := 8;  //单行注释
        TK_C_D1 := 16;  //多行 {
        TK_C_D2 := 32 ;  //多行 (*
        TK_SYN := 64;//符号
        TK_SYN_S := 128;//分离符号
        TK_TSLX := 256;// 注释
        TK_KEY := 512;
        //子类型
        TK_TYPE := 1;
        TK_CLASS := 2;
        TK_FUNCTION := 4;
        TK_SELECT := 8;
        TK_UNIT:=16;
        TK_IF := 32;
        TK_THEN := 64;
        TK_ELSE := 128;
        TK_BEGIN := 256 ;
        TK_END := 512;
        TK_TRY := 1024;
        TK_EXCEPT := 2048;
        TK_FINALLY := 4096;
        TK_CASE := 8192;
        TK_OF := 16384;
        n := 15;
        TK_EXTERNAL := 2^(n++); 
        TK_CDECL := 2^(n++);
        TK_STDCALL := 2^(n++);
        TK_NAME := 2^(n++);
        TK_keepresident :=2^(n++);
        TK_PRIVATE := 2^(n++);
        TK_ARRAY := 2^(n++);
        TK_NEW := 2^(n++);
        TK_DO := 2^(n++);
        //..............................
        BT_DEF := 1;
        BT_UNIT := 1+2;
        BT_TYPE := 1+4;
        BT_BEGIN := 8;
        BT_CASE := 8+16;
        BT_SELECT := 8+32;
        BT_TRY    := 8+64;
        BT_ARRAY := 8+128;
        BT_CALC := 8+256;
        //.................................
        FHierarchyWidth := 4;
        TslSyn := array(":=","<>",">=","<=",".>",".<",".>=",".<=",".=","++","--","?:",".!!",".&&",".||",".&",".|",".^",
        ":*",":/",":\\",":^",":|","::","::=","->",
        "+=","-=","*=","/=","\\=","^=","~=","%=",".|=",".&=",".||=",".&&=",".^=","|=",":|=","&=",":*=",":/=",":\\=",":^=",
        //"div=","union2=","intersect=","outersect=","minus=","end.",
        "##","l'",'l"',"*",
        "%%","(*","//","#!",
        "<?tslx>",
        "?>",
        "...",
        ":>",":<",":<>", ":==",":>=",":<=",
        "::>","::<","::<>", "::==","::>=","::<=",
        //"0x","0O","0b",
        );
        TslSyn2 := array("div=","union2=","intersect=","outersect=","minus=","end.",);
        // "union2=","intersect=","outersect=","minus=","end.",
        FMaxLineCount := 20;
        FMaxLineLength := -1;
        FSynParser := new TTire();
        FSynParser2 := new TTire();
        for i,v in TslSyn do 
        begin
            FSynParser.add(v);
        end 
        for i,v in TslSyn2 do 
        begin
            FSynParser2.add(v);
        end 
        FHtmlParser := NEW TTire();
        FHtmlParser.Add("<?tsl");
        FArrayType := 1;
    end 
    FTkIndex; //当前位置
    FCWordCount; //当前行单词数目
    FLWordLength; //当前行字符串长度
    FTokenslength; //token的总长度;
    FHier;
    FFormatStr;
    Fstates;
    FMaxLineCount;
    FMaxLineLength;
    function DelTokens();
    begin 
        FTkIndex := 0;
        FCWordCount := 0;
        FLWordLength := 0; 
        FTokenslength := length(FTokens);
        FHier := new THStack(FHierarchyWidth);
        Fstates := new TStateStack();
        Fstates.Push(BT_DEF);
        FFormatStr := "";    
    end 
    function GetNextNComTk(cidx);
    begin
        Cidx := FTkIndex;
        while (cidx+1)<FTokenslength do 
        begin
            cidx++;
            tk := FTokens[Cidx];
            if ifnil(tk) then return 0;
            if tk.FType .& TK_C then continue;
            return tk;
        end        
    end 
    function NextNComTk();
    begin
        r := GetNextNComTk(cidx);
        FTkIndex := cidx;
        return r;
    end 
    function NextTK();
    begin
        if FTkIndex<FTokenslength then 
        begin 
            FTkIndex++;
            return FTokens[FTkIndex];
        end         
    end 
    function GetNextTK();
    begin
        return FTokens[FTkIndex+1];
    end 
    function CurrentTK();
    begin
        return  FTokens[FTkIndex];    
    end 
    function GetPrevTK(cid);
    begin
        cidx := FTkIndex;
        if cidx>=1 then return FTokens[cidx-1];
    end 
    function PrevTK();
    begin
        if FTkIndex>0 then 
        begin
            FTkIndex--;
            return FTokens[FTkIndex];
        end    
    end 
    function PrevNComTK();
    begin
        while FTkIndex>0 do 
        begin
            FTkIndex--;
            tk := FTokens[FTkIndex]; 
            if tk.FType .& TK_C then  continue;   
            return tk;
        end 
    end 
    function GetPrevNComTK(cidx);
    begin
        cidx := FTkIndex;
        while cidx>0 do 
        begin
            cidx--;
            tk := FTokens[cidx];
            if tk.FType .& TK_C then 
            begin
                continue;
            end 
            return tk;
        end 
    end 
    function ChangeLine();
    begin
        if FCWordCount then 
        begin
            FFormatStr+="\r\n";
            FCWordCount := 0;
            FLWordLength := 0;
        end
    end 
    function AddTokenToStr(idx);
    begin
        tk := FTokens[idx];
        if not tk then return ;
        bidx  := FTkIndex;
        FTkIndex := idx;
        {if idx>1 and  (tk.FType .& TK_KEY) and (tk.FTypeSub .& TK_ELSE) and (ptk := GetPrevTK(ttidx)) and (ptk.FTypeSub .& TK_END) then //else处理
        begin
            fl := length(FFormatStr);
            if FFormatStr[fl]="\n" then 
            begin
                FFormatStr[fl-5] := ptk.FStr+" "+tk.FStr+"\r\n";    
            end else 
            begin
                FCWordCount++; 
                FLWordLength+=tk.FStrL;   
            end 
            
        end else }
        fl := length(FFormatStr);
        if idx>1 and  (tk.FType .& TK_KEY) and (tk.FTypeSub .& TK_ELSE) and (ptk := GetPrevTK(ttidx)) and (ptk.FTypeSub .& TK_END) and (FFormatStr[fl]="\n") then //else处理
        begin
            FFormatStr[fl-1:] := " "+tk.FStr+"\r\n";    
            FCWordCount := 0;
            FLWordLength := 0;
        end else
        if (tk.FType .& TK_C_S) and tk.FFirst=0 then 
        begin
            fl := length(FFormatStr);
            if fl>2 and (FFormatStr[fl-1:fl]="\r\n") then 
            begin 
                FFormatStr[fl-1:fl]:=" "+tk.FStr+"\r\n";
            end 
            else FFormatStr+= " "+tk.FStr+ "\r\n";
            FCWordCount :=0;  
            FLWordLength :=0;      
        end else 
        if (tk.FType .& TK_SYN_S){ and (tk.FStr="*")} then  //修正(**) 问题 20231127修正
        begin
            FFormatStr+= " "+tk.FStr+" ";    
        end else
        if (tk.FType .& TK_SYN) and (tk.FStr=";") then 
        begin
            fl := length(FFormatStr);
            if fl>2 and (FFormatStr[fl-1:fl]="\r\n") then 
            begin 
                FFormatStr[fl-1:fl]:=";\r\n";
            end 
            else FFormatStr+=";\r\n";
            FCWordCount :=0;  
            FLWordLength :=0;                   
        end else 
        if (tk.FType .& TK_KEY) and ((tk.FTypeSub .& TK_PRIVATE)) then 
        begin
            ChangeLine();
            FFormatStr+= FHier.HierStr()+ tk.FStr+"\r\n";
        end else
        if tk.FType .& TK_C then
        begin
            //单行
            if tk.FType .& TK_C_S then 
            begin
                
                if FCWordCount then 
                begin
                    FFormatStr +=" "+tk.FStr;        
                end else 
                begin
                    FFormatStr+= FHier.HierStr()+ tk.FStr;
                end 
                FFormatStr+="\r\n";
                FCWordCount := 0;  
                FLWordLength := 0; 
                //ChangeLine();
            end else 
            begin 
                //多行
                mcs := tk.FStr;
                if FAlignBlockComment then 
                begin
                    mcss := str2array(mcs,"\n");
                    lenmcss := length(mcss);
                    if lenmcss>1 then 
                    begin
                        mcs := mcss[0]+"\n";
                        for i,v in mcss do 
                        begin
                            if i=0 then continue;
                            cz := false;
                            for j:= 1 to length(v) do 
                            begin
                                if v[j] in array(" ","\t","\r") then continue;
                                cz := true;
                                break;
                            end 
                            if cz then 
                            begin
                                vs := v;
                                vs[1:j-1]:=FHier.HierStr();
                                mcs +=vs;
                            end else 
                            begin
                                mcs+=v;
                            end 
                            if lenmcss>i+1 then 
                            begin
                                mcs+="\n";
                            end     
                        end 
     
                    end 
                    //mcs := replacetext(mcs,"\r\n","\r\n"+FHier.HierStr())  ;  
                end 
                if tk.FFirst then 
                begin
                    ChangeLine();
                end 
                if FCWordCount then FFormatStr+= " "+ mcs;
                else 
                    FFormatStr+= FHier.HierStr()+ mcs;
                ttk := GetNextTK();
                if ttk and ttk.FFirst then 
                begin
                    FFormatStr+="\r\n";
                    FCWordCount := 0;  
                    FLWordLength := 0; 
                end 
                else FCWordCount++;
            end 
         
        end else 
        begin
            state := Fstates.GetState();
            
            if ((state = BT_ARRAY and FArrayType=0) or (state = BT_SELECT))  and tk.FFirst then 
            begin
                if FCWordCount then 
                begin 
                    FCWordCount := 0;  
                    FLWordLength := 0;
                    FFormatStr+="\r\n";  
                end 
            end 
            if FCWordCount then 
            begin
                ttk := GetPrevTK(); 
                if ttk and ( (tk.FTypeSub .& TK_DO) or (tk.FTypeSub .& TK_END) or (((ttk.FType .& TK_W) or (ttk.FType .& TK_KEY) or (ttk.FType .& TK_STR) ) and ((tk.FType .& TK_W) or (tk.FType .& TK_KEY) or (tk.FType .& TK_STR))) ) then 
               // if ttk and ((ttk.FType .& TK_W) or (ttk.FType .& TK_KEY)) or ((tk.FType .& TK_W) or (tk.FType .& TK_KEY)) then  
                begin
                    FFormatStr+=" "+tk.FStr; 
                end 
                else FFormatStr+=tk.FStr  
            end else
            begin 
                FFormatStr+=FHier.HierStr()+tk.FStr;
            end  
            FCWordCount++;  
            FLWordLength+=tk.FStrL;
            if false and ((FMaxLineCount>0 and  FCWordCount>=FMaxLineCount) or (FMaxLineLength>5 and FMaxLineLength <FLWordLength  )) then  
            begin
                ChangeLine();
            end
            
        end  
        FTkIndex := bidx;
        
    end 
    function Formataline(b,e);
    begin
        bct := FCWordCount;
        s := FTokens[b].FStr; 
        fbktkindex :=  FTkIndex;
        FCWordCount++ ; FLWordLength +=FTokens[b].FStrL;
        for i:= b+1 to e do 
        begin
            
            //FTkIndex := i;
            ttk := FTokens[i-1];
            tk := FTokens[i];
            FCWordCount++ ; FLWordLength +=tk.FStrL;
            //if ((ttk.FType .& TK_W) or (ttk.FType .& TK_KEY)) and ((PTK.FType .& TK_W) or (PTK.FType .& TK_KEY)) then s+=" ";
            if ttk and ( (tk.FTypeSub .& TK_DO) or (tk.FTypeSub .& TK_END) or (((ttk.FType .& TK_W) or (ttk.FType .& TK_KEY) or (ttk.FType .& TK_STR) ) and ((tk.FType .& TK_W) or (tk.FType .& TK_KEY) or (tk.FType .& TK_STR))) ) then 
            begin
                s+=" ";
            end  
            if (tk.FType .& TK_C_S) and tk.FFirst then 
            begin
                s+="\r\n";
                if i<e then s+=FHier.HierStr();
                FCWordCount := 0;
                FLWordLength :=0;    
            end 
            s += tk.FStr;
            if tk.FType .& TK_C_S then 
            begin
                s+="\r\n";
                FCWordCount := 0;
                FLWordLength :=0;
            end 
                
        end 
        FFormatStr += ((bct=0)? FHier.HierStr():" ")+s;
        //FTkIndex := fbktkindex;
        return s;
    end 
    function Findftokens();
    begin
        ntk := NextNComTk();
        if not(ntk) or ntk.FStr=";" then 
        begin
            return 0;
        end
        //ntk := NextNComTk();
        //state "hsm","cs" "tp","ext" "plus"
        {
            hsm ( cs 
            hsm 其他 hsm
            hsm ; ext 
            hsm : tp
            cs  ) tp
            tp  ; plus
            plus ; plus 
            plus virtual plus
            plus override plus 
            plus overload plus 
            plus  stdcall -- 下一个 external 
            plus 其他 结束
            plus external -- 获得小一个    
        }
        hsidx := 0;
        nhsmame := false;
        hssmok := false;
        st := "hsm";
        while ntk do 
        begin 
            hsidx++;           
            s := ntk.FStr;
            ft := ntk.FType;
            fts := ntk.FTypeSub;
            ls := lowercase(s);
            case st of
                "hsm":
                begin 
                    case s of
                        "(": 
                        begin
                            if hsidx = 1 then 
                            begin
                                nhsmame := true;
                            end 
                            st := "cs";
                        end
                        ";": st := "plus";
                        ":": st := "tp";
                    end ; 
                    if (fts .& TK_BEGIN) then 
                    begin
                        goto jump1;
                    end    
                end 
                "cs":
                begin
                    if s=")" then st := "tp";  
                end 
                "tp":
                begin
                    if s =";" then st := "plus";
                    else if s=":" then 
                    begin
                        ntk := NextNComTk();
                    end else
                    if s = "array" then 
                    begin
                    
                    end else 
                    if s="of" then 
                    begin
                        ntk := NextNComTk();
                    end 
                    else 
                    if (fts .& TK_BEGIN) then 
                    begin
                        goto jump1;
                    end else 
                    begin
                        goto jump1;    
                    end 
                end 
                "plus":
                begin 
                    if ls in array("virtual","override","overload","stdcall","cdecl") then 
                    begin
                    end else
                    if ls=";" then 
                    begin
                        hssmok := true;        
                    end 
                    else 
                    if ls in array( "external") then 
                    begin
                        st := "ext";
                    end else
                    if (fts .& TK_BEGIN) then 
                    begin
                        goto jump1;
                    end  else 
                    begin
                        goto jump1;
                    end         
                end 
                "ext":
                begin
                    if ls in array("name","keepresident") then 
                    begin
                    
                    end else 
                    if (ft .& TK_STR) then 
                    begin
                    
                    end else
                    if (s =";") then 
                    begin
                        goto jump2;
                    end  
                end 
            
            end ;
            ntk := NextNComTk();
        end 
        //if st<>"hsm" then return 1 ;
        if hssmok then 
        begin
            goto jump1;
        end 
        return 0;
        label jump1;
        PrevNComTK();
        //PrevTK();
        if nhsmame then return 3;
        return 1;
        label jump2; 
        if nhsmame then return 3;       
        return 2;        
    end 
    function FormatCode();
    begin
        ParserTslToken();
        //FOR I,V IN FTokens do ECHO v.FStr,"\r\n";
        //return ;
        DelTokens();
        ctk := CurrentTK();
        state := Fstates.GetState();
        while ctk do 
        begin     
            bkindex := FTkIndex;
            if (state .& BT_DEF) and (ctk.FType .& TK_KEY ) and (ctk.FTypeSub .& TK_TYPE) then  //type class 
            begin
                bctk := ctk;
                ctk := NextNComTk(); //name 
                if not ctk then 
                begin
                    AddTokenToStr(bkindex);  
                    FTkIndex :=  bkindex;
                    ctk := NextTK(); 
                    continue;  
                end 
                ctk := NextNComTk();//=
                if not(ctk) then 
                begin
                    AddTokenToStr(bkindex);  
                    FTkIndex :=  bkindex;
                    ctk := NextTK();
                    continue;   
                end 
                ctk := NextNComTk();//class
                if not ctk then 
                begin
                    AddTokenToStr(bkindex);  
                    FTkIndex :=  bkindex;
                    ctk := NextTK();
                    continue;   
                end 
                if {lowercase(ctk.FStr)<>"class"} not( ctk.FTypeSub .& TK_CLASS) then 
                begin
                    AddTokenToStr(bkindex);  
                    FTkIndex :=  bkindex;
                    ctk := NextTK();
                    continue;   
                end 
                ctk := NextNComTk(); //(
                if ctk and ctk.FStr="(" then 
                begin
                    while true do 
                    begin
                        ctk := NextNComTk();
                        if not(ctk) or ctk.FStr=")" then 
                        begin
                            break;
                        end  
                    end 
                end else 
                begin
                    PrevNComTK();
                end  
                ChangeLine();
                Formataline(bkindex,FTkIndex);
                ChangeLine();
                FHier.Push();
                FStates.Push(BT_TYPE);
                state := BT_TYPE;     
            end  else 
            if (state .& BT_DEF) and (ctk.FType .& TK_KEY ) and (ctk.FTypeSub .& TK_UNIT) then  //unit 
            begin
                ctk := NextNComTk(); //name
                if not(ctk) then 
                begin
                    AddTokenToStr(bkindex);  
                    FTkIndex :=  bkindex;
                    ctk := NextTK();
                    continue;   
                end 
                ctk := NextNComTk();// ;
                if not(ctk) or(ctk.FStr<>";") then 
                begin
                    AddTokenToStr(bkindex);  
                    FTkIndex :=  bkindex;
                    ctk := NextTK();
                    continue;   
                end 
                ChangeLine();
                Formataline(bkindex,FTkIndex);
                ChangeLine();
//                FHier.Push();  //20220606 unit     去掉缩进
                FStates.Push(BT_UNIT);
                state := BT_UNIT;
                //return "";         
            end else 
            if {(state .& BT_BEGIN) and} (ctk.FType .& TK_KEY ) and (ctk.FTypeSub .& TK_CASE) then //case of 
            begin
                while true do 
                begin
                    ctk := NextNComTk();
                    if (ctk.FType .& TK_KEY) and (ctk.FTypeSub .& TK_OF) then 
                    begin
                        break;
                    end 
                end 
                ChangeLine();
                Formataline(bkindex,FTkIndex);
                ChangeLine();
                FHier.Push();
                state := BT_TYPE;
                Fstates.Push(BT_BEGIN);
            end else 
            if(ctk.FType .& TK_KEY) and ((ctk.FTypeSub .& TK_TRY) ) then  //TRY 
            begin
                ChangeLine();
                AddTokenToStr(FTkIndex);
                ChangeLine();
                FHier.Push();
                state := BT_TRY;
                Fstates.Push(BT_TRY);        
            end else 
            if(ctk.FType .& TK_KEY) and ((ctk.FTypeSub .& TK_BEGIN) ) then  //begin 
            begin
                ChangeLine();
                AddTokenToStr(FTkIndex);
                ChangeLine();
                FHier.Push();
                state := BT_BEGIN;
                Fstates.Push(BT_BEGIN);
            end else 
            if (ctk.FType .& TK_KEY) and ((ctk.FTypeSub .& TK_END) ) then //end 
            begin
                //select end 不换行
                if state<>BT_SELECT then 
                begin
                    ChangeLine();
                end
                FHier.Pop();
                AddTokenToStr(FTkIndex);
                //select end 结尾也不换行
                if state<>BT_SELECT then 
                begin
                    ChangeLine();
                end
                Fstates.Pop();
                state := Fstates.GetState();
                ChangeLine();
            end else 
            if (ctk.FType .& TK_KEY) and (ctk.FTypeSub .& TK_SELECT) then //select
            begin
                AddTokenToStr(FTkIndex);
                //ChangeLine();
                FHier.push();
                state := BT_SELECT;
                Fstates.Push(BT_SELECT); 
            end else 
            {if (ctk.FType .& TK_KEY) and (ctk.FTypeSub .& TK_TRY) then//try 
            begin
                ChangeLine();
                AddTokenToStr(FTkIndex);
                ChangeLine();
                state := BT_TRY;
                FHier.push();
                Fstates.Push(BT_TRY); 
            end else    }        
            if (state .& BT_TRY) and (ctk.FType .& TK_KEY) and (ctk.FTypeSub .& TK_EXCEPT) then 
            begin
                ChangeLine();
                FFormatStr+=FHier.HierStr(-1)+ ctk.FStr+"\r\n";
            end else 
            if (ctk.FType .& TK_KEY) and ((ctk.FTypeSub .& TK_CLASS)) and (state .& BT_TYPE) then 
            begin
                
                ntk := NextNComTk();
                if ntk and (ntk.FTypeSub .& TK_FUNCTION ) then 
                begin
                    ChangeLine();
                    r := Findftokens();
                    if r=0 then 
                    begin
                        FTkIndex := bkindex;
                        AddTokenToStr(bkindex);  
                    end else 
                    begin
                        ChangeLine();
                        Formataline(bkindex,FTkIndex);
                        ChangeLine();
                    end 
                end else 
                begin 
                    FTkIndex := bkindex;
                    AddTokenToStr(bkindex);   
                end   
            end  else
            if (ctk.FType .& TK_KEY) and ((ctk.FTypeSub .& TK_FUNCTION)) then //function 
            begin
                r := Findftokens();
                if r=0 then 
                begin
                    FTkIndex := bkindex;
                    AddTokenToStr(FTkIndex);    
                end else 
                begin
                    if r<>3 then
                        ChangeLine();
                    Formataline(bkindex,FTkIndex);
                    ChangeLine();
                end 
            end else 
            if (ctk.FTypeSub .& TK_ARRAY) then 
            begin
                AddTokenToStr(FTkIndex); 
                state := BT_ARRAY; 
            end else 
            if (ctk.FStr ="(") then 
            begin
                AddTokenToStr(FTkIndex);
                FHier.push();
                if state = BT_ARRAY then 
                begin
                    //移动到下方
                    ptk := GetPrevTK();
                    if ptk.FTypeSub .& TK_ARRAY then 
                    begin 
                        Fstates.Push(BT_ARRAY);
                    end else 
                    if (ptk.FStr="+") or (ptk.FType .& TK_W) then //运算
                    begin
                        Fstates.Push(BT_CALC);
                        state := BT_CALC;
                    end else 
                    begin
                        Fstates.Push(BT_ARRAY);
                    end
                    //移动到的新位置
                    if (state = BT_ARRAY)and (FArrayType .& 2) and (ptk := GetNextTK()) and  ( ptk.FStr<>")") then 
                    begin
                        ChangeLine();
                    end  
                end else 
                begin
                    Fstates.Push(BT_CALC);    
                end 
            end else 
            if ( ctk.FStr =")") then 
            begin
                lstate := state;
                ischangelined := false;
                if ctk.FFirst and  (state=BT_ARRAY) and (FArrayType=0) then 
                begin
                    ChangeLine();
                    ischangelined := true;
                end 
                FHier.Pop();
                Fstates.Pop();
                if not(FArrayType .&2) then 
                begin
                    AddTokenToStr(FTkIndex);
                end 
                state := Fstates.GetState();
                if (ischangelined =false) and FArrayType and (lstate = BT_ARRAY) and (state=BT_ARRAY) then 
                begin  
                    tt := GetPrevNComTK(ttid);
                    ttstr := tt.FStr;
                    if ttstr<>"(" then 
                    begin 
                        ChangeLine(); 
                    end 
                end 
                if (FArrayType .&2) then 
                begin 
                    AddTokenToStr(FTkIndex);
                end 
            end else 
            if (FArrayType .& 2 ) and (state = BT_ARRAY) and (ctk.FStr =",")  then 
            begin
                AddTokenToStr(FTkIndex); 
                ChangeLine();    
            end else 
            if FArrayType and (ctk.FTypeSub .& TK_ARRAY) then 
            begin
                AddTokenToStr(FTkIndex); 
                state := BT_ARRAY; 
            end 
            else //普通情况
            begin
                AddTokenToStr(FTkIndex);
            end    
            ctk := NextTK();
        end
       return FFormatStr;     
    end   
    function AddToken(sp,ep,t);
    begin
        if not(ep>=sp) then return;
        ls := FScriptL[sp:ep];
        tklen := length(FTokens);
               
        if ls=";" then 
        begin
            ltk := FTokens[tklen-1];
            if ltk and not(ltk.FType .& TK_STR) and (ltk.FStr=";") then return ;
        end
        t1 := t;
        stype := 0;
        if t = TK_W then 
        begin
            nchange := false;
            case ls of
                "*":
                begin
                    stype := TK_DO;
                end 
                "array": stype := TK_ARRAY;
                "if": 
                begin
                    stype := TK_IF;
                end
                "new":
                begin
                    stype := TK_NEW;
                end
                "then" : 
                begin
                    stype := TK_THEN;
                end 
                "rdo2","rdo","do":
                begin
                    stype := TK_DO;
                end 
                "else" : stype := TK_ELSE;
                "begin" : stype := TK_BEGIN;
                "end": 
                begin
                    stype := TK_END;
                end
                "end.":
                begin
                    stype := TK_END;
                end
                "class":
                begin
                    stype := TK_CLASS;
                end 
                "unit": 
                begin
                    stype := TK_UNIT;
                end 
                {$ifdef weakref}
                "private","public","published","interface","implementation","initialization","weakref","autoref" : stype := TK_PRIVATE;
                {$else}
                "private","public","published","interface","implementation","initialization": stype := TK_PRIVATE;
                {$endif}
                "function","procedure": stype := TK_FUNCTION;
                "type": stype := TK_TYPE;
                "try": stype := TK_TRY;
                "except","finally": stype := TK_EXCEPT;
                "case" : stype := TK_CASE;
                "of" : stype := TK_OF;
                "select","mselect","vselect","sselect","update": 
                begin
                    stype := TK_SELECT;
                end
                "external": stype := TK_EXTERNAL;
                "cdecl": stype := TK_CDECL;
                "name": stype := TK_NAME;
                "stdcall":stype := TK_STDCALL;
                else 
                begin
                    nchange := true;
                end 
            end ;
            if not nchange then t1 := TK_KEY;
        end 
        TK := new TTK(FScript[sp:ep],t1,stype);
        TK.FFirst := FAtRowFirst;
        tk.FStrL := ep-sp+1;
        //tk.FLstr := ls;
        FTokens[tklen] := tk;//array("type":t,"str":FScript[sp:ep],"subtype":stype);
        FAtRowFirst := 0;
    end 
    function iswordchar(s,idx);
    begin
        if idx<1 then return 0;//第一个
        cchar := s[idx];
        occhar := ord(cchar);
        if 0= bytetype(s,idx) then //ascii
        begin 
            return (occhar>=46 and occhar<=57 ) or //数字
                    (occhar>=65 and occhar<=90) or //大字母
                    (occhar>=97 and occhar<=122)   //小字母
        end 
        //汉字
        return 1;

    end 
    function ParserTslToken();
    begin
        FTokens := array();
        FAtRowFirst := true;
        if not ifstring(FScript) then return ;
        strl := length(FScriptL);
        cwrd := "";
        cwrdstart:=1;
        idx := 1;
        while idx<=strl do 
        begin 
            if FSynParser.Find(FScriptL,strl,idx,outidx,outstr) then 
            begin               
                inidx := idx;
                idx := outidx;
                AddToken(cwrdstart,inidx-1,TK_W);
                cwrdstart := outidx;
                case outstr of   
                    "0x":    //16进制
                    begin
                        idx2 := idx;
                        while idx2<=strl do 
                        begin
                            cchar := FScriptL[idx2];
                            if cchar in array("0","1","2","3","4","5","6","7","8","9","a","b","c","d","e","f") then 
                            begin
                                
                            end else 
                            if cchar="l" then 
                            begin
                                idx := idx2+1;
                                break;
                            end else 
                            begin
                                idx := idx2;
                                break;    
                            end 
                            idx2++;
                        end
                        if idx2>strl then 
                        begin
                            idx := idx2;
                            return AddToken(inidx,idx-1,TK_W);    
                        end else 
                        begin
                            AddToken(inidx,idx-1,TK_W);
                        end 
                    end 
                    "0o": //8进制
                    begin
                        idx2 := idx;
                        while idx2<=strl do 
                        begin
                            cchar := FScriptL[idx2];
                            if cchar in array("0","1","2","3","4","5","6","7") then 
                            begin
                                
                            end else 
                            if cchar="l" then 
                            begin
                                idx := idx2+1;
                                break;
                            end else 
                            begin
                                idx := idx2;
                                break;    
                            end 
                            idx2++;
                        end
                        if idx2>strl then 
                        begin
                            idx := idx2;
                            return AddToken(inidx,idx-1,TK_W);    
                        end else 
                        begin
                            AddToken(inidx,idx-1,TK_W);
                        end 
                    end 
                    "0b": //2进制
                    begin
                        idx2 := idx;
                        while idx2<=strl do 
                        begin
                            cchar := FScriptL[idx2];
                            if cchar in array("0","1") then 
                            begin
                                
                            end else 
                            if cchar="l" then 
                            begin
                                idx := idx2+1;
                                break;
                            end else 
                            begin
                                idx := idx2;
                                break;    
                            end 
                            idx2++;
                        end
                        if idx2>strl then 
                        begin
                            idx := idx2;
                            return AddToken(inidx,idx-1,TK_W);    
                        end else 
                        begin
                            AddToken(inidx,idx-1,TK_W);
                        end 
                    end                  
                    "%%":
                    begin
                        idx2 := idx;
                        while idx2<=strl do 
                        begin
                            cchar := FScriptL[idx2];
                            if pos(cchar," \r\n\t") then 
                            begin
                                if FindStrInStr(FScriptL,strl,FScriptL[inidx:idx2-1],idx2,outidx,outstr) then 
                                begin
                                    idx := outidx;  
                                    AddToken(inidx,idx-1,TK_STR);
                                end else 
                                begin
                                    return AddToken(inidx,strl,TK_STR);
                                end 
                                break;
                            end 
                            idx2++;
                        end 
                    end 
                    "l'":
                    begin
                        idx2 := idx;
                        while idx2<=strl do
                        begin
                            tcchar := FScriptL[idx2];
                            if tcchar="\\" then idx2++;
                            else 
                            if tcchar="'" then 
                            begin
                                AddToken(inidx,idx2,TK_STR);
                                idx := idx2+1;
                                cwrdstart := idx+1; 
                                break;
                            end 
                            idx2++;
                        end 
                        IF idx2>strl then 
                        begin
                            return AddToken(inidx,strl,TK_STR);;
                        end 
                    end
                    'l"':
                    begin
                        idx2 := idx;
                        while idx2<=strl do
                        begin
                            tcchar := FScriptL[idx2];
                            if tcchar="\\" then idx2++;
                            else 
                            if tcchar='"' then 
                            begin
                                AddToken(inidx,idx2,TK_STR);
                                idx := idx2+1;
                                cwrdstart := idx+1; 
                                break;
                            end 
                            idx2++;
                        end 
                        IF idx2>strl then 
                        begin
                            return AddToken(inidx,strl,TK_STR);;
                        end 
                    end
                    "//","#!":
                    begin
                        idx2 := idx ;
                        while idx2<=strl do 
                        begin
                            cchar := FScriptL[idx2];
                            if cchar="\r" or cchar = "\n" then 
                            begin
                                idx := idx2+1;
                                AddToken(inidx,idx2-1,TK_C .| TK_C_S);
                                
                                FAtRowFirst := true;
                                break;
                            end 
                            idx2++;
                        end 
                        if idx2>strl then 
                        begin
                            return AddToken(inidx,strl,TK_C .| TK_C_S);
                        end 
                    end 
                    "(*":
                    begin
                        idx2 := idx;
                        if FindStrInStr(FScriptL,strl,"*)",idx2,outidx,outstr) then 
                        begin
                            idx := outidx;
                            AddToken(inidx,idx-1,TK_C .| TK_C_D2);
                        end else 
                        begin
                            return AddToken(inidx,strl,TK_C .| TK_C_D2);
                        end 
                    end 
                    "<?tslx>","?>":
                    begin
                        idx2 := idx;
                        if FindStrInStr(FScriptL,strl,"<?tsl",idx2,outidx,outstr) then 
                        begin
                            idx := outidx;
                            //AddToken(inidx,idx-1,TK_TSLX); 
                            AddToken(inidx,idx-1,TK_W);  //暂时修改
                        end else 
                        begin
                            return AddToken(inidx,strl,TK_TSLX);
                        end 
                    end 
                    "++","--":
                    begin
                        AddToken(inidx,outidx-1,TK_SYN);
                    end 
                    "*","//":
                    begin
                        AddToken(inidx,outidx-1,TK_SYN .| TK_SYN_S);
                    end else 
                    begin    
                        AddToken(inidx,outidx-1,{TK_SYN .| TK_SYN_S}TK_W);
                        
                    end 
                end ;
                cwrdstart := idx;
                continue;
            end             
            if (not iswordchar(FScriptL,idx-1)) and  FSynParser2.Find(FScriptL,strl,idx,outidx,outstr) then //处理前面是正常字母的运算符
            begin
                inidx := idx;
                idx := outidx;
                AddToken(cwrdstart,inidx-1,TK_W);
                cwrdstart := outidx;
                AddToken(inidx,outidx-1,TK_SYN .| TK_SYN_S);
                cwrdstart := idx;
                continue;
            end 
            cchar := FScriptL[idx];
            {if cchar in array("0","1","2","3","4","5","6","7","8","9") then
            begin
                st := 0; //0 数字 1 小数部分 2 科学计数法 3 科学计数法小数部分
                idx2 := idx+1;
                while idx2 <=strl do 
                begin
                    tcchar := FScriptL[idx2];
                    if tcchar in array("0","1","2","3","4","5","6","7","8","9") then 
                    begin
                    
                    end else 
                    if tcchar="l" and st=0 then  //数字结束
                    begin
                        idx := idx2+1;
                        break;
                    end else 
                    if st<2 and tcchar="e" then 
                    begin
                        st :=3;
                        if idx2<strl and (FScriptL[idx2+1] in array("-","+")) then 
                        begin
                            idx2++;    
                        end 
                    end else
                    if st=0 and tcchar="." then 
                    begin
                        st:=1;
                    end  else 
                    if st=3 and tcchar="." then 
                    begin
                        st :=4    
                    end else 
                    begin
                        idx := idx2;
                        break;
                    end 
                    idx2++;
                end 
            
                if idx2>strl then 
                begin
                    idx := idx2;
                    return AddToken(inidx,idx-1,TK_W);    
                end else 
                begin
                    echo 
                    AddToken(inidx,idx-1,TK_W);
                end 
                
            end else  }
            if cchar="{" then 
            begin
                AddToken(cwrdstart,idx-1,TK_W);
                cwrdstart:= idx;
                idx2 := idx+1;
                while idx2<=strl do
                begin
                    tcchar := FScriptL[idx2];
                    if tcchar="}" then 
                    begin
                        AddToken(idx,idx2,TK_C .| TK_C_D1);
                        idx := idx2; 
                        cwrdstart := idx2+1;
                        break;
                    end 
                    idx2++;
                end 
                if idx2>strl then 
                begin
                    return AddToken(inidx,strl,TK_C .| TK_C_D1);
                end 
            end else 
            if cchar="'" then 
            begin
                AddToken(cwrdstart,idx-1,TK_W);
                idx2 := idx+1;
                while idx2<=strl do
                begin
                    tcchar := FScriptL[idx2];
                    if tcchar="\\" then idx2++;
                    else 
                    if tcchar="'" then 
                    begin
                        AddToken(idx,idx2,TK_STR);
                        idx := idx2;
                        cwrdstart := idx+1; 
                        break;
                    end 
                    idx2++;
                end 
                IF idx2>strl then 
                begin
                    return AddToken(idx,strl,TK_STR);;
                end 
            end else 
            if cchar='"' then 
            begin
                AddToken(cwrdstart,idx-1,TK_W);
                cwrdstart := idx+1;
                idx2 := idx+1;
                while idx2<=strl do
                begin
                    tcchar := FScriptL[idx2];
                    if tcchar="\\" then idx2++;
                    else 
                    if tcchar='"' then 
                    begin    
                        AddToken(idx,idx2,TK_STR);
                        idx := idx2;
                        cwrdstart := idx+1;
                        break;
                    end 
                    idx2++;
                end 
                IF idx2>strl then 
                begin
                    return AddToken(idx,strl,TK_STR);;
                end 
            end else 
            if cchar="\n" then 
            begin
                AddToken(cwrdstart,idx-1,TK_W);
                cwrdstart := idx+1;
                FAtRowFirst := true;
            end else 
            if pos(cchar," \r\t") then //间隔符号
            begin
                AddToken(cwrdstart,idx-1,TK_W);
                cwrdstart := idx+1;
            end else 
            if pos(cchar,"()[]") then 
            begin
                AddToken(cwrdstart,idx-1,TK_W);
                AddToken(idx,idx,TK_SYN);
                cwrdstart := idx+1;
            end else 
            if cchar=";" then 
            begin
                AddToken(cwrdstart,idx-1,TK_W);
                AddToken(idx,idx,TK_SYN);
                cwrdstart := idx+1;
                //分割符    
            end else 
            if cchar="," then 
            begin
                AddToken(cwrdstart,idx-1,TK_W);
                cwrdstart := idx+1; 
                AddToken(idx,idx,TK_SYN);                
            end else
            if pos(cchar,"*=+-*/\\`~!@#$%^&*?><.:") then 
            begin
                AddToken(cwrdstart,idx-1,TK_W);
                cwrdstart := idx+1; 
                AddToken(idx,idx,TK_SYN);      
            end     
            idx++;   
        end
        AddToken(cwrdstart,strl,TK_W);      
    end 
    published
    property AlignBlockComment read FAlignBlockComment write FAlignBlockComment;
    Property Tokens read FTokens;
    property Script read FScript write SetScript;
    property HierarchyWidth read FHierarchyWidth write FHierarchyWidth;
    property MaxLineCount Read FMaxLineCount write FMaxLineCount;
    property MaxLineLength read FMaxLineLength write FMaxLineLength;
    property ArrayType read FArrayType write SetArrayType;
    private 
    function FindStrInStr(s,slen,fs,idx,outidx,outstr);
    begin
        tfinder := new TTire();   
        tfinder.Add(fs);
        tidx := idx;
        while tidx<=slen do 
        begin
            if tfinder.Find(s,slen,tidx,outidx,outstr) then 
            begin
                return true;
            end   
            tidx++; 
        end 
        return false; 
    end 
    function SetScript(s);
    begin
        if s<>FScript then 
        begin
            FScriptL := "";
            FScript := "";
            FTokens := array();
            if ifstring(s) then 
            begin 
                FScript := s; 
                FScriptL := lowercase(s);
            end   
        end 
    end 
    function Setarraytype(t);
    begin
        if FArrayType=t then return ;
        if t in array(0,1,2,3) then 
        begin
            FArrayType := t;    
        end    
    end 
    private 
    FAlignBlockComment;
    FAtRowFirst;
    FArrayType;
    FTokens;
    FHierarchyWidth;
    FSym;
    FScript;
    FScriptL;
end 
Type TTK = class
    FType;
    FTypeSub;
    FStr;
    FLstr;
    FStrL;
    FFirst;
    function Create(s,t,st);
    begin
        FStr := s;
        FType := t;
        FTypeSub := st ;
    end 
end 

Type TStateStack = class
    function Create();
    begin
        FStates := array();
        FIndex := -1;
    end 
    function GetState();
    begin
        if FIndex>=0 then 
        begin
            return FStates[FIndex];
        end 
        return 1;
    end 
    function Push(s);
    begin
        if s>0 then 
        begin 
            FIndex++;
            FStates[FIndex] := s;
        end 
    end 
    function Pop();
    begin
        if FIndex>=0 then 
        begin
            r  := FStates[FIndex];
            FIndex--;
            return r;
        end 
        return 0;
    end 
    private
    FStates;
    FIndex;
end 
TYPE THStack = class
    function Create(w);
    begin
        FLength := 0;
        FHierarchyWidth := w;
        FCache := array();
    end 
    function Push();
    begin
        FLength++;    
    end 
    function Pop();
    begin
        r := FLength;
        if FLength>0 then FLength--;    
        return r;    
    end 
    function HierStr(es);
    begin
        if not(es>0 or es<0) then es := 0;
        cct := (FLength+es)*FHierarchyWidth;
        r := FCache[cct];
        if r then return r;
        r := "";
        for i:=1 to cct do 
        begin
            r+=" ";
        end 
        FCache[cct] := r;
        return r;
    end 
    property Hier read FLength;
    FHierarchyWidth;
    FLength;
    FVS;
    FCache;

end 

end.
{else 
            if FArrayType and (ctk.FStr ="(") then 
            begin
                AddTokenToStr(FTkIndex);
                FHier.push();
                if state = BT_ARRAY then 
                begin
                    //移动到下方
                    ptk := GetPrevTK();
                    if ptk.FTypeSub .& TK_ARRAY then 
                    begin 
                        Fstates.Push(BT_ARRAY);
                    end else 
                    if (ptk.FStr="+") or (ptk.FType .& TK_W) then //运算
                    begin
                        Fstates.Push(BT_CALC);
                        state := BT_CALC;
                    end else 
                    begin
                        Fstates.Push(BT_ARRAY);
                    end
                    //移动到的新位置
                    if (state = BT_ARRAY)and (FArrayType .& 2) and (ptk := GetNextTK()) and  ( ptk.FStr<>")") then 
                    begin
                        ChangeLine();
                    end  
                end else 
                begin
                    Fstates.Push(BT_CALC);    
                end 
            end else 
            if FArrayType and ( ctk.FStr =")") then 
            begin
                lstate := state;
                FHier.Pop();
                Fstates.Pop();
                AddTokenToStr(FTkIndex);
                state := Fstates.GetState();
                if (lstate = BT_ARRAY) and (state=BT_ARRAY) then 
                begin  
                    tt := GetPrevNComTK(ttid);
                    ttstr := tt.FStr;
                    if ttstr<>"(" then 
                    begin 
                        ChangeLine(); 
                    end 
                end 
            end }