000001| (** A translation from unlabeled AST to labeled AST. *)
000002|
000003| (* Requirements:
000004|
000005| Lexing.position/ASTnode --> line_label (for pprinting analysis result)
000006|
000007| fun_label --> Fun literal (for CFA)
000008| table_label --> Table literal (for heap analysis)
000009|
000010| + enclosing function label (option)
000011| *)
000012|
000013| module A = Ast
000014| module L = Last
000015|
000016| let reset,make_label,make_res_label =
000017| (*[1]*)let count = ref 1 in
000018| (*[1]*)let res_count = ref 0 in
000019| (*[1]*)(fun () -> (*[0]*)count := 1),
000020| (fun () -> (*[0]*)let label = !count in
000021| (*[0]*)begin
000022| (*[0]*)incr count;
000023| (*[0]*)label
000024| end),
000025| (fun () -> (*[8]*)let label = !res_count in
000026| (*[8]*)begin
000027| (*[8]*)decr res_count;
000028| (*[8]*)label
000029| end)
000030|
000031| type info =
000032| { mutable enclosing_fun : L.label option;
000033| mutable inside_loop : bool;
000034| mutable pos_map : (L.label * L.stmt) list; (* stmt or stmt list? *)
000035| mutable fun_map : (L.label * L.lit) list;
000036| mutable table_map : (L.label * L.lit) list; }
000037|
000038| let rec label_lit info l = match l with
000039| | A.Nil -> (*[0]*)L.Nil
000040| | A.Bool b -> (*[0]*)L.Bool b
000041| | A.Number n -> (*[0]*)L.Number n
000042| | A.String s -> (*[0]*)L.String s
000043| | A.Table (unnamed,named) ->
000044| (*[0]*)let lab = make_label () in
000045| (*[0]*)let unnamed' = List.map (fun e -> (*[0]*)label_exp info e) unnamed in
000046| (*[0]*)let named' = List.map (fun (s,e) -> ((*[0]*)s,label_exp info e)) named in
000047| (*[0]*)let tab = L.Table (lab,unnamed',named') in
000048| (*[0]*)info.table_map <- (lab,tab)::info.table_map; (*add table*)
000049| (*[0]*)tab
000050|
000051| | A.Fun (xs,bl) ->
000052| (*[0]*)let old_lab = info.enclosing_fun in
000053| (*[0]*)let old_flag = info.inside_loop in
000054| (*[0]*)let lab = make_label () in
000055| (*[0]*)let () = info.enclosing_fun <- Some lab in (*new enclosing*)
000056| (*[0]*)let () = info.inside_loop <- false in (*inside function, not loop*)
000057| (*[0]*)let bl' = label_block info bl in
000058| (*[0]*)let () = info.enclosing_fun <- old_lab in (*reset label*)
000059| (*[0]*)let () = info.inside_loop <- old_flag in (*reset flag*)
000060| (*[0]*)let endlab = make_label () in
000061| (*[0]*)let f = L.Fun (lab,xs,bl',endlab) in
000062| (*[0]*)info.fun_map <- (lab,f)::info.fun_map; (*add function*)
000063| (*[0]*)f
000064|
000065| and label_lvalue info lv = match lv with
000066| | A.Name n -> (*[0]*)L.Name n
000067| | A.Index (e,f) ->
000068| (*[0]*)let clab = make_label () in
000069| (*[0]*)let e' = label_exp info e in
000070| (*[0]*)let e'' = label_exp info (A.Lit (A.String (A.Normal f))) in
000071| (*[0]*)L.DynIndex(clab,e',e'')
000072| | A.DynIndex (e0,e1) ->
000073| (*[0]*)let clab = make_label () in
000074| (*[0]*)let e0' = label_exp info e0 in
000075| (*[0]*)let e1' = label_exp info e1 in
000076| (*[0]*)L.DynIndex (clab,e0',e1')
000077|
000078| and label_exp info e = match e with
000079| | A.Lit l -> (*[0]*)L.Lit (label_lit info l)
000080| | A.Lvalue lv -> (*[0]*)L.Lvalue (label_lvalue info lv)
000081| | A.Unop (uo,e) ->
000082| (*[0]*)let e' = label_exp info e in
000083| (*[0]*)L.Unop (uo,e')
000084| | A.Binop (e0,bo,e1) ->
000085| (*[0]*)let clab = make_label () in
000086| (*[0]*)let e0' = label_exp info e0 in
000087| (*[0]*)let e1' = label_exp info e1 in
000088| (*[0]*)L.Binop (clab,e0',bo,e1')
000089| | A.And (e0,e1) ->
000090| (*[0]*)let e0' = label_exp info e0 in
000091| (*[0]*)let e1' = label_exp info e1 in
000092| (*[0]*)L.And (e0',e1')
000093| | A.Or (e0,e1) ->
000094| (*[0]*)let e0' = label_exp info e0 in
000095| (*[0]*)let e1' = label_exp info e1 in
000096| (*[0]*)L.Or (e0',e1')
000097| | A.Call (e,es) ->
000098| (*[0]*)let clab = make_label () in
000099| (*[0]*)let e' = label_exp info e in
000100| (*[0]*)let es' = List.map (label_exp info) es in
000101| (*[0]*)L.Call (clab,e',es')
000102| | A.Methcall (e,mname,es) ->
000103| (*[0]*)let clab = make_label () in
000104| (*[0]*)let ilab = make_label () in
000105| (*[0]*)let e' = label_exp info e in
000106| (*[0]*)let es' = List.map (label_exp info) es in
000107| (*[0]*)L.Methcall (clab,ilab,e',mname,es')
000108| | A.Paren e0 ->
000109| (*[0]*)let e0' = label_exp info e0 in
000110| (*[0]*)L.Paren e0'
000111|
000112| and label_stmt info s =
000113| (*[0]*)let line_lab = make_label () in
000114| (*[0]*)let pos = { L.lex_pos = s.A.stmt_pos;
000115| L.func = info.enclosing_fun;
000116| L.line_label = line_lab; } in
000117| (*[0]*)let mkstmt s =
000118| (*[0]*)let stm = { L.stmt_pos = pos; L.stmt = s } in
000119| (*[0]*)info.pos_map <- (line_lab,stm)::info.pos_map; (* add stm *)
000120| (*[0]*)stm in
000121| match s.A.stmt with
000122| | A.Break ->
000123| (*[0]*)if info.inside_loop
000124| then (*[0]*)mkstmt L.Break
000125| else (*[0]*)Error.error "Structural error" "break not inside loop" s.A.stmt_pos
000126| | A.If (e,bl1,bl2) ->
000127| (*[0]*)let e' = label_exp info e in
000128| (*[0]*)let bl1' = label_block info bl1 in
000129| (*[0]*)let bl2' = label_block info bl2 in
000130| (*[0]*)mkstmt (L.If (e',bl1',bl2'))
000131| | A.WhileDo (e,bl) ->
000132| (*[0]*)let elab = make_label () in
000133| (*[0]*)let flag = info.inside_loop in
000134| (*[0]*)let e' = label_exp info e in
000135| (*[0]*)info.inside_loop <- true; (* entering loop *)
000136| (*[0]*)let bl' = label_block info bl in
000137| (*[0]*)let () = info.inside_loop <- flag in (*;*) (* reset loop flag *)
000138| (*[0]*)let stm = mkstmt (L.WhileDo (e',bl',elab)) in
000139| (*[0]*)let () = info.pos_map <- (elab,stm)::info.pos_map in(*;*) (* add end-label to while-stm binding *)
000140| (*[0]*)stm
000141| (* | A.For (x,e0,e1,bl) ->
000142| let e0' = label_exp info e0 in
000143| let e1' = label_exp info e1 in
000144| let bl' = label_block info bl in
000145| mkstmt (L.For (x,e0',e1',bl')) *)
000146| | A.Doend bl ->
000147| (*[0]*)let bl' = label_block info bl in
000148| (*[0]*)mkstmt (L.Doend bl')
000149| | A.Assign (lvs,es) ->
000150| (*[0]*)let lvs' = List.map (label_lvalue info) lvs in
000151| (*[0]*)let es' = List.map (label_exp info) es in
000152| (*[0]*)mkstmt (L.Assign (lvs',es'))
000153| | A.Local (xs,es) ->
000154| (*[0]*)let es' = List.map (label_exp info) es in
000155| (*[0]*)mkstmt (L.Local (xs,es'))
000156| | A.Callstmt (e,es) ->
000157| (*[0]*)let e' = label_exp info e in
000158| (*[0]*)let es' = List.map (label_exp info) es in
000159| (*[0]*)mkstmt (L.Callstmt (e',es'))
000160| | A.Methcallstmt (e,mname,es) ->
000161| (*[0]*)let ilab = make_label () in
000162| (*[0]*)let e' = label_exp info e in
000163| (*[0]*)let es' = List.map (label_exp info) es in
000164| (*[0]*)mkstmt (L.Methcallstmt (ilab,e',mname,es'))
000165| | A.Return es ->
000166| (*[0]*)let es' = List.map (label_exp info) es in
000167| (*[0]*)mkstmt (L.Return es')
000168|
000169| and label_block info bl =
000170| (*[0]*)let stmts = List.map (label_stmt info) bl in
000171| match stmts with
000172| | [] -> (*[0]*)None
000173| | s::_ ->
000174| (*[0]*)let lab = s.L.stmt_pos.L.line_label in
000175| (*[0]*)Some { L.label = lab;
000176| L.stmts = stmts; }
000177|
000178| (* label_prog : string option -> Ast.block -> Last.last *)
000179| let label_prog fname_opt p =
000180| let info = { enclosing_fun = None;
000181| inside_loop = false;
000182| pos_map = [];
000183| fun_map = [];
000184| table_map = []; } in
000185| let p' = label_block info p in
000186| let retlab = make_label () in
000187| let pos_map (*l*) = (*List.assoc l*) info.pos_map in
000188| let fun_map l = List.assoc l info.fun_map in
000189| let table_map l = List.assoc l info.table_map in
000190| { L.name = fname_opt;
000191| L.last = p';
000192| L.ret_label = retlab;
000193| L.pos_map = pos_map;
000194| L.fun_map = fun_map;
000195| L.table_map = table_map }