From 8a4d3d7deca62408539bc6f4c68d27178315b07d Mon Sep 17 00:00:00 2001 From: mzp Date: Wed, 10 Dec 2008 10:29:24 +0900 Subject: [PATCH] first implements for module trans --- src/ast.ml | 38 +++++++++++++++++++------------------- src/ast.mli | 18 +++++++++--------- src/bindCheck.ml | 4 +--- src/bindCheck.mli | 4 +--- src/moduleTrans.ml | 29 +++++++++++++++++++++++------ test/astUtil.ml | 23 +++++++++++------------ test/test_module.ml | 13 ++++++++----- 7 files changed, 72 insertions(+), 57 deletions(-) diff --git a/src/ast.ml b/src/ast.ml index 84260f3..f1022f3 100644 --- a/src/ast.ml +++ b/src/ast.ml @@ -2,7 +2,7 @@ open Base (* name := namespace * symbol *) type qname = (string * string) Node.t -type ident = string Node.t +type sname = string Node.t (* expression has no side-effect. *) type expr = @@ -11,20 +11,20 @@ type expr = | `Bool of bool Node.t | `Float of float Node.t | `Var of qname - | `Lambda of ident list * expr + | `Lambda of sname list * expr | `Call of expr list | `If of expr * expr * expr - | `Let of (ident*expr) list * expr - | `LetRec of (ident*expr) list * expr + | `Let of (sname*expr) list * expr + | `LetRec of (sname*expr) list * expr | `Block of expr list | `New of qname * expr list - | `Invoke of expr * ident * expr list - | `SlotRef of expr * ident - | `SlotSet of expr * ident * expr ] + | `Invoke of expr * sname * expr list + | `SlotRef of expr * sname + | `SlotSet of expr * sname * expr ] (* statement has side-effect *) -type attr = ident -type method_ = ident * ident list * expr +type attr = sname +type method_ = sname * sname list * expr type stmt = [ `Define of qname * expr @@ -84,7 +84,7 @@ let rec map f expr = let string_of_qname {Node.value=(ns,name)} = ns ^ "." ^ name -let string_of_ident {Node.value=name} = +let string_of_sname {Node.value=name} = name @@ -105,7 +105,7 @@ let rec to_string : expr -> string = string_of_qname n | `Lambda (args,expr') -> Printf.sprintf "Lambda (%s,%s)" - (string_of_list_by string_of_ident args) + (string_of_list_by string_of_sname args) (to_string expr') | `Call exprs -> Printf.sprintf "Call %s" @@ @@ -118,7 +118,7 @@ let rec to_string : expr -> string = string_of_list_by (fun (a,b)-> Printf.sprintf "(%s,%s)" - (string_of_ident a) + (string_of_sname a) (to_string b)) decl in let body' = to_string body in @@ -128,7 +128,7 @@ let rec to_string : expr -> string = string_of_list_by (fun (a,b)-> Printf.sprintf "(%s,%s)" - (string_of_ident a) + (string_of_sname a) (to_string b)) decl in let body' = to_string body in @@ -143,15 +143,15 @@ let rec to_string : expr -> string = | `Invoke (obj,name,args) -> Printf.sprintf "Invoke (%s,%s,%s)" (to_string obj) - (string_of_ident name) @@ + (string_of_sname name) @@ string_of_list_by to_string args | `SlotRef (obj,name) -> Printf.sprintf "SlotRef (%s,%s)" - (to_string obj) @@ string_of_ident name + (to_string obj) @@ string_of_sname name | `SlotSet (obj,name,value) -> Printf.sprintf "SlotSet (%s,%s,%s)" (to_string obj) - (string_of_ident name) + (string_of_sname name) (to_string value) let to_string_stmt = @@ -166,12 +166,12 @@ let to_string_stmt = Printf.sprintf "Class (%s,%s,%s,%s)" (string_of_qname klass) (string_of_qname super) - (string_of_list_by string_of_ident attrs) + (string_of_list_by string_of_sname attrs) @@ String.concat "\n" @@ List.map (fun (name,args,expr) -> Printf.sprintf "((%s %s) %s)" - (string_of_ident name) + (string_of_sname name) (String.concat " " @@ - List.map string_of_ident args) + List.map string_of_sname args) (to_string expr)) body diff --git a/src/ast.mli b/src/ast.mli index 5f0543c..440c636 100644 --- a/src/ast.mli +++ b/src/ast.mli @@ -2,7 +2,7 @@ (** name := namespace * symbol *) type qname = (string * string) Node.t -type ident = string Node.t +type sname = string Node.t (** expression has no side-effect. *) type expr = @@ -11,19 +11,19 @@ type expr = | `Bool of bool Node.t | `Float of float Node.t | `Var of qname - | `Lambda of ident list * expr + | `Lambda of sname list * expr | `Call of expr list | `If of expr * expr * expr - | `Let of (ident*expr) list * expr - | `LetRec of (ident*expr) list * expr + | `Let of (sname*expr) list * expr + | `LetRec of (sname*expr) list * expr | `Block of expr list | `New of qname * expr list - | `Invoke of expr * ident * expr list (** (invoke ...)*) - | `SlotRef of expr * ident - | `SlotSet of expr * ident * expr ] + | `Invoke of expr * sname * expr list (** (invoke ...)*) + | `SlotRef of expr * sname + | `SlotSet of expr * sname * expr ] -type attr = ident -type method_ = ident * ident list * expr +type attr = sname +type method_ = sname * sname list * expr (** statement has side-effect *) type stmt = diff --git a/src/bindCheck.ml b/src/bindCheck.ml index 5774841..6afb80a 100644 --- a/src/bindCheck.ml +++ b/src/bindCheck.ml @@ -5,10 +5,8 @@ exception Unbound_var of (string*string) Node.t exception Unbound_class of (string*string) Node.t exception Unbound_method of string Node.t -type method_ = Ast.ident - type stmt = - [ `ExternalClass of Ast.qname * method_ list + [ `ExternalClass of Ast.qname * Ast.sname list | `External of Ast.qname | Ast.stmt] type program = stmt list diff --git a/src/bindCheck.mli b/src/bindCheck.mli index beb164c..d6b222f 100644 --- a/src/bindCheck.mli +++ b/src/bindCheck.mli @@ -2,10 +2,8 @@ exception Unbound_var of (string*string) Node.t exception Unbound_class of (string*string) Node.t exception Unbound_method of string Node.t -type method_ = Ast.ident - type stmt = - [ `ExternalClass of Ast.qname * method_ list + [ `ExternalClass of Ast.qname * Ast.sname list | `External of Ast.qname | Ast.stmt] diff --git a/src/moduleTrans.ml b/src/moduleTrans.ml index ad0d771..8e4ee91 100644 --- a/src/moduleTrans.ml +++ b/src/moduleTrans.ml @@ -1,3 +1,4 @@ +open Base (* Example: (package A :export '(f g h)) @@ -26,10 +27,26 @@ Flow: *) type stmt = - [ `Class of Ast.ident * Ast.qname * Ast.attr list * Ast.method_ list - | `Define of Ast.ident * Ast.expr + [ `Class of Ast.sname * Ast.qname * Ast.attr list * Ast.method_ list + | `Define of Ast.sname * Ast.expr | `Expr of Ast.expr - | `Module of Ast.ident * Ast.ident list * stmt ] - - -let trans x = x + | `Module of Ast.sname * (Ast.sname list) * stmt list ] + +let to_qname ({Node.value = ns} as loc) ({Node.value=name;end_pos=pos}) = + {loc with + Node.value = (ns,name); + end_pos = pos} + +let rec trans_stmt ns : stmt -> Ast.stmt list = + function + `Class (klass,super,attrs,methods) -> + [`Class (to_qname ns klass,super,attrs,methods)] + | `Define (name,body) -> + [`Define (to_qname ns name,body)] + | `Expr _ as expr -> + [expr] + | `Module (ns,_,stmts) -> + HList.concat_map (trans_stmt ns) stmts + +let trans = + HList.concat_map (trans_stmt (Node.empty "")) diff --git a/test/astUtil.ml b/test/astUtil.ml index ff6379c..5cdc18a 100644 --- a/test/astUtil.ml +++ b/test/astUtil.ml @@ -89,23 +89,22 @@ let eq_clos a b = | a,b -> eq_bind a b -(* random node *) -let count = - ref 0 - let node x = - let pos ()= - incr count; - !count in - {(Node.empty x) with - Node.filename = ""; - Node.lineno = 0; - start_pos = pos (); - end_pos = pos ()} + {(Node.empty x) with + Node.filename = ""; + Node.lineno = 0; + start_pos = 0; + end_pos = 0} let qname x = node ("",x) +let full_qname ns name = + node (ns,name) + +let sname = + node + let string x = `String (node x) diff --git a/test/test_module.ml b/test/test_module.ml index d61b3dc..b94a3a0 100644 --- a/test/test_module.ml +++ b/test/test_module.ml @@ -7,6 +7,9 @@ let ok x y = OUnit.assert_equal x @@ trans y +let sname = + node + let define x y = `Define (x,y) @@ -15,15 +18,15 @@ let _ = "define trans" >:: (fun () -> ok - [define (node ("foo","bar")) @@ `Block []] - [`Module (node "foo",[ - define (node ("","bar")) @@ `Block []])]); + [define (node ("foo","bar")) (`Block [])] + [`Module (sname "foo",[],[ + define (sname "bar") (`Block []) ] ) ]); "class trans" >:: (fun () -> ok [`Class (node ("foo","bar"),qname "Object",[],[])] - [`Module (node "foo",[ - `Class (node ("","bar"),qname "Object",[],[])])]) + [`Module (sname "foo",[],[ + `Class (sname "bar",qname "Object",[],[])])]) ]) +> run_test_tt -- 2.11.0