From c2453aa8ca29b8de6f220d8ec8347f611544cb43 Mon Sep 17 00:00:00 2001 From: mzp Date: Sun, 2 Nov 2008 16:08:12 +0900 Subject: [PATCH] refactoring enviroment function --- example/test.sh | 2 +- src/codegen.ml | 284 +++++++++++++++++++++++++++------------------------ src/codegen.mli | 2 +- test/test_codegen.ml | 70 ++++++++----- 4 files changed, 198 insertions(+), 160 deletions(-) diff --git a/example/test.sh b/example/test.sh index 691c306..282b420 100755 --- a/example/test.sh +++ b/example/test.sh @@ -1,6 +1,6 @@ #!/bin/sh for file in $@; do - echo -n "${file}..." + /bin/echo -n "${file}..." # generate expected output sed -n 's/;;; *//p' $file > $file.expect diff --git a/src/codegen.ml b/src/codegen.ml index d1a735c..a96be3f 100644 --- a/src/codegen.ml +++ b/src/codegen.ml @@ -7,28 +7,6 @@ open Cpool type bind = Scope of int | Register of int | Global type env = {depth:int; binding: (string * bind) list } -let empty_env = - {depth=0; binding=[("this",Register 0)]} - -let add_scope names {depth=n;binding=xs} = - let names' = - List.map (fun name-> name,Scope n) names in - {depth=n+1; binding=names' @ xs} - -let add_global name env = - {env with binding=(name,Global)::env.binding} - -let add_current_scope name {depth=n;binding=xs} = - {depth=n; binding=(name,Scope (n-1))::xs} - -let add_register names env = - let names' = - ExtList.List.mapi (fun i name-> name,Register (i+1)) names in - {env with binding = names'@env.binding} - -let add_this env = - {env with binding = ("this",Register 0)::env.binding} - let get_bind name {binding=xs} = List.assoc name xs @@ -41,14 +19,126 @@ let get_bind_sure name state = let is_bind name {binding=xs} = List.mem_assoc name xs -let ensure_scope name env = - match get_bind name env with - Scope x -> - x - | _ -> - failwith ("scope not found:"^name) +let empty_env = + {depth=0; binding=[("this",Register 0)]} + +let script_bootstrap _ = + [ GetLocal_0; PushScope ],{depth=1; binding=[]} + +let arguments env args f = + let b = + ExtList.List.mapi (fun i arg-> (arg,Register (i+1))) args in + let code = + f ({empty_env with binding = b }) in + code + +let let_scope {depth=n; binding=binding} vars f = + let env' = + {depth = n+1; + binding= List.map (fun (var,_) -> (var,Scope n)) vars @ binding} in + List.concat [HList.concat_map + (fun (var,init)-> + List.concat [[PushString var]; init]) vars; + [NewObject (List.length vars); + PushWith]; + f env'; + [PopScope]] + +let let_rec_scope {depth=n; binding=binding} vars f = + let env' = + {depth = n+1; + binding= List.map (fun (var,_) -> (var,Scope n)) vars @ binding } in + let init = + HList.concat_map + (fun (var,g)-> + List.concat [[GetScopeObject n]; + g env'; + [SetProperty (make_qname var)]]) vars in + List.concat [[NewObject 0;PushWith]; + init; + f env'; + [PopScope]] + +let define_scope name ({depth=n;binding=xs} as env) f = + let env' = + {depth=n; binding=(name,Scope (n-1))::xs} in + let body' = + if is_bind name env then + List.concat [ + [NewObject 0;PushWith]; + f env'; + [GetScopeObject n; + Swap; + SetProperty (make_qname name)]] + else + List.concat [ + f env'; + [GetScopeObject (n-1); + Swap; + SetProperty (make_qname name)]] in + env',body' + +let define_class name ({sname=super; cname=cname} as klass) env = + let env' = + {env with binding=(name,Global)::env.binding} in + env',[ + (* init class *) + GetLex super; + PushScope; + GetLex super; + NewClass klass; + PopScope; + + (* add to scope *) + GetGlobalScope; + Swap; + InitProperty cname] +let var_ref var env = + let qname = + make_qname var in + match get_bind_sure var env with + Some (Scope scope) -> + [GetScopeObject scope; + GetProperty qname] + | Some (Register n) -> + [GetLocal n] + | Some Global -> + [GetGlobalScope; + GetProperty qname] + | None -> + [GetLex qname] + +let var_call var args env = + let qname = + make_qname var in + let nargs = + List.length args in + match get_bind_sure var env with + Some (Scope scope) -> + List.concat [[GetScopeObject scope]; + List.concat args; + [CallPropLex (qname,nargs)]] + | Some (Register n) -> + List.concat [[GetLocal n; + GetGlobalScope]; + List.concat args; + [Asm.Call nargs]] + | Some Global -> + List.concat [[GetGlobalScope]; + List.concat args; + [CallPropLex (qname,nargs)]] + | None -> + List.concat [[FindPropStrict qname]; + List.concat args; + [CallPropLex (qname,nargs)]] + +let add_register names env = + let names' = + ExtList.List.mapi (fun i name-> name,Register (i+1)) names in + {env with binding = names'@env.binding} + (** {6 Builtin operator } *) let builtin = ["+",(Add_i,2); "-",(Subtract_i,2); @@ -102,50 +192,25 @@ and generate_expr expr env = HList.concat_map gen args; [ConstructProp (qname,List.length args)]] | Lambda (args,body) -> - let args',body' = - generate_lambda args body empty_env in - let m = - Asm.make_meth ~args:args' "" body' in - [NewFunction m] + arguments env args + (fun e -> + let args' = + List.map (const 0) args in + let body' = + generate_expr body e in + let m = + Asm.make_meth ~args:args' "" body' in + [NewFunction m]) | Var name -> - let qname = - make_qname name in - begin match get_bind_sure name env with - Some (Scope scope) -> - [GetScopeObject scope; - GetProperty qname] - | Some (Register n) -> - [GetLocal n] - | Some Global -> - [GetGlobalScope; - GetProperty qname] - | _ -> - [GetLex qname] - end + var_ref name env | Let (vars,body) -> - let env' = - add_scope (List.map fst vars) env in - let inits = - HList.concat_map (fun (name,init)-> - List.concat [[PushString name];gen init]) vars in - List.concat [inits; - [NewObject (List.length vars); - PushWith]; - generate_expr body env'; - [PopScope]] + let vars' = + List.map (Core.Tuple.T2.map2 ~f:gen) vars in + let_scope env vars' @@ generate_expr body | LetRec (vars,body) -> - let env' = - add_scope (List.map fst vars) env in - let init = - HList.concat_map (fun (name,init)-> - List.concat [[GetScopeObject (ensure_scope name env')]; - gen init; - [SetProperty (make_qname name)]]) - vars in - List.concat [[NewObject 0;PushWith]; - init; - generate_expr body env'; - [PopScope]] + let vars' = + List.map (Core.Tuple.T2.map2 ~f:generate_expr) vars in + let_rec_scope env vars' @@ generate_expr body | Invoke (obj,name,args)-> List.concat [ gen obj; @@ -158,27 +223,9 @@ and generate_expr expr env = HList.concat_map gen args; [inst]] | Ast.Call (Var name::args) -> - let qname = - make_qname name in - let nargs = - List.length args in let args' = - HList.concat_map gen args; in - begin match get_bind_sure name env with - Some (Scope scope) -> - List.concat [[GetScopeObject scope]; - args'; - [CallPropLex (make_qname name,nargs)]] - | Some (Register n) -> - List.concat [[GetLocal n; - GetGlobalScope]; - args'; - [Asm.Call nargs]] - | _ -> - List.concat [[FindPropStrict qname]; - args'; - [CallPropLex (qname,nargs)]] - end + List.map gen args in + var_call name args' env | Ast.Call (name::args) -> let nargs = List.length args in @@ -217,32 +264,9 @@ let generate_stmt env stmt = match stmt with Expr expr -> env,(generate_expr expr env)@[Pop] - | Define (name,body) when not @@ is_bind name env -> - let env' = - add_current_scope name env in - let scope = - ensure_scope name env' in - let body' = - List.concat [generate_expr body env'; - [GetScopeObject scope; - Swap; - SetProperty (make_qname name)]] in - env',body' | Define (name,body) -> - let env' = - add_scope [name] env in - let scope = - ensure_scope name env' in - let body' = - List.concat [[NewObject 0;PushWith]; - generate_expr body env'; - [GetScopeObject scope; - Swap; - SetProperty (make_qname name)]] in - env',body' + define_scope name env @@ generate_expr body | Class (name,(ns,sname),body) -> - let env' = - add_global name env in let name' = make_qname name in let sname' = @@ -254,7 +278,7 @@ let generate_stmt env stmt = List.fold_left (fun (init',cinit',methods') (name,args,body) -> let args',body' = - generate_lambda (List.tl args) body (add_global name empty_env) in + generate_lambda (List.tl args) body empty_env in match name with "init" -> (Asm.make_proc ~args:args' name (prefix@body'), @@ -277,41 +301,31 @@ let generate_stmt env stmt = interface = []; methods = methods } in - env',[ - (* init class *) - GetLex sname'; - PushScope; - GetLex sname'; - NewClass klass; - PopScope; - - (* add to scope *) - GetGlobalScope; - Swap; - InitProperty name'] + define_class name klass env let generate_program xs env = List.concat @@ snd @@ map_accum_left generate_stmt env xs -let generate_method xs = - let init_env = - add_scope ["this"] empty_env in +let generate_script xs = + let bootstrap,env = + script_bootstrap () in let program = - generate_program xs init_env in - Asm.make_proc "" ([GetLocal_0;PushScope] @ program) + generate_program xs env in + Asm.make_proc "" (bootstrap @ program) let generate program = - let m = - generate_method program in + let script = + generate_script program in let {Asm.abc_cpool=cpool; method_info=info; method_body=body; class_info =class_info; instance_info=instance_info} = - assemble m in + assemble script in let traits_class = ExtList.List.mapi - (fun i {Abc.name_i=name} -> {Abc.t_name=name; data=Abc.ClassTrait (i,i)}) + (fun i {Abc.name_i=name} -> + {Abc.t_name=name; data=Abc.ClassTrait (i,i)}) instance_info in { Abc.cpool=cpool; method_info=info; diff --git a/src/codegen.mli b/src/codegen.mli index f79d352..af1db66 100644 --- a/src/codegen.mli +++ b/src/codegen.mli @@ -1,2 +1,2 @@ -val generate_method : Ast.stmt list -> Asm.meth +val generate_script : Ast.program -> Asm.meth val generate : Ast.program -> Abc.abc diff --git a/test/test_codegen.ml b/test/test_codegen.ml index 40d44ae..2fb3ba2 100644 --- a/test/test_codegen.ml +++ b/test/test_codegen.ml @@ -49,7 +49,7 @@ let qname name = QName ((Namespace ""),name) let compile x = - (generate_method [Expr x]) + (generate_script [Expr x]) (** test *) test lib_call = @@ -109,15 +109,15 @@ test if_ = test let_ = assert_equal (expr [PushString "x"; PushByte 1; - PushString "y"; PushByte 2; - NewObject 2; - PushWith; - GetScopeObject 1; - GetProperty (qname "x"); - Pop; - GetScopeObject 1; - GetProperty (qname "y"); - PopScope]) + PushString "y"; PushByte 2; + NewObject 2; + PushWith; + GetScopeObject 1; + GetProperty (qname "x"); + Pop; + GetScopeObject 1; + GetProperty (qname "y"); + PopScope]) (compile (Let (["x",Int 1;"y",Int 2], Block [Var "x";Var "y"]))) @@ -131,26 +131,39 @@ test letrec = PopScope]) (compile (LetRec (["x",Int 42],Block []))) +test letrec = + assert_equal + (expr [NewObject 0; + PushWith; + GetScopeObject 1; + + GetScopeObject 1; + GetProperty (qname "x"); + + SetProperty (qname "x"); + PopScope]) + (compile (LetRec (["x",Var "x"],Block []))) + test define = assert_equal (toplevel [NewFunction (inner [] [PushByte 42]); GetScopeObject 0; Swap; SetProperty (qname "f")]) - (generate_method @@ compile_string "(define (f) 42)") + (generate_script @@ compile_string "(define (f) 42)") test define_not_hidden = assert_equal (toplevel [NewFunction (inner [] [PushByte 42]);GetScopeObject 0;Swap;SetProperty (qname "f"); NewFunction (inner [] [PushByte 30]);GetScopeObject 0;Swap;SetProperty (qname "g")]) - (generate_method @@ compile_string "(define (f) 42) (define (g) 30)") + (generate_script @@ compile_string "(define (f) 42) (define (g) 30)") test define_hidden = assert_equal (toplevel [NewFunction (inner [] [PushByte 42]);GetScopeObject 0;Swap;SetProperty (qname "f"); NewObject 0;PushWith; NewFunction (inner [] [PushByte 30]);GetScopeObject 1;Swap;SetProperty (qname "f")]) - (generate_method @@ compile_string "(define (f) 42) (define (f) 30)") + (generate_script @@ compile_string "(define (f) 42) (define (f) 30)") test closure = assert_equal @@ -158,7 +171,7 @@ test closure = GetScopeObject 0; Swap; SetProperty (qname "f")]) - (generate_method @@ compile_string "(define (f) (lambda () x))") + (generate_script @@ compile_string "(define (f) (lambda () x))") (* function call *) test call = @@ -171,20 +184,31 @@ test call_with_args = (expr [NewFunction (inner [0;0] [GetLocal 2])]) (compile (Lambda (["x";"y"],Block [Var "y"]))) +test closure_lambda = + assert_equal + (expr [PushString "z"; PushByte 42; + NewObject 1; + PushWith; + NewFunction (inner [] [GetLex (qname "z")]); + PopScope]) + (compile (Let (["z",Int 42], + Lambda ([],Block [Var "z"])))) + + test new_ = assert_equal (expr [FindPropStrict (make_qname "Foo");ConstructProp (make_qname "Foo",0)]) - (generate_method @@ compile_string "(new Foo)") + (generate_script @@ compile_string "(new Foo)") test new_ = assert_equal (expr [FindPropStrict (make_qname "Foo");PushByte 42;ConstructProp (make_qname "Foo",1)]) - (generate_method @@ compile_string "(new Foo 42)") + (generate_script @@ compile_string "(new Foo 42)") test invoke = assert_equal (expr [GetLex (make_qname "x");PushByte 10;CallProperty (make_qname "foo",1)]) - (generate_method @@ compile_string "(. x (foo 10))") + (generate_script @@ compile_string "(. x (foo 10))") let new_class klass = @@ -211,7 +235,7 @@ test klass = iinit = Asm.make_proc "init" @@ prefix@[PushByte 10]; interface = []; methods = []}) - (generate_method @@ compile_string + (generate_script @@ compile_string "(define-class Foo (Object) ()) (define-method init ((self Foo)) 10)") @@ -225,7 +249,7 @@ test klass_empty = iinit = Asm.make_proc "init" prefix; interface = []; methods = []}) - (generate_method @@ compile_string "(define-class Foo (Object) ())") + (generate_script @@ compile_string "(define-class Foo (Object) ())") test klass_f = assert_equal @@ -237,7 +261,7 @@ test klass_f = iinit = Asm.make_proc "init" prefix; interface = []; methods = [Asm.make_meth "f" [PushByte 42]]}) - (generate_method @@ compile_string + (generate_script @@ compile_string "(define-class Foo (Object) ()) (define-method f ((self Foo)) 42)") @@ -252,7 +276,7 @@ test klass_with_ns = iinit = Asm.make_proc "init" @@ prefix@[PushByte 10]; interface = []; methods = []}) - (generate_method @@ compile_string + (generate_script @@ compile_string "(define-class Foo (flash.text.Object) ()) (define-method init ((self Foo)) 10)") @@ -266,7 +290,7 @@ test klass_args = iinit = Asm.make_proc "init" ~args:[0] @@ prefix@[GetLocal 1]; interface = []; methods = []}) - (generate_method @@ compile_string + (generate_script @@ compile_string "(define-class Foo (Object) ()) (define-method init ((self Foo) x) x)") @@ -281,5 +305,5 @@ test klass_f_args = iinit = Asm.make_proc "init" prefix; interface = []; methods = [Asm.make_meth "f" ~args:[0] [GetLocal 1]]}) - (generate_method @@ compile_string "(define-class Foo (Object) ()) + (generate_script @@ compile_string "(define-class Foo (Object) ()) (define-method f ((self Foo) x) x)") -- 2.11.0