From 9e369e06cf8fb554418870e2c6ae0333ecd51f90 Mon Sep 17 00:00:00 2001 From: mzp Date: Mon, 24 Nov 2008 15:25:52 +0900 Subject: [PATCH] [UPDATE] I change Ast's type from variant to polymorphic variant. This change make ease to add new ast-element. --- src/ast.ml | 127 ++++++++++++++++++++++---------------------- src/ast.mli | 36 ++++++------- src/closTrans.ml | 30 +++++------ src/closTrans.mli | 6 +-- src/closureTrans.ml | 41 +++++++------- src/codegen.ml | 56 ++++++++++---------- src/lisp.ml | 47 ++++++++--------- test/astUtil.ml | 53 ++++++++++--------- test/test_ast.ml | 13 ++--- test/test_clostrans.ml | 48 ++++++++--------- test/test_closuretrans.ml | 21 ++++---- test/test_codegen.ml | 39 +++++++------- test/test_lisp.ml | 132 ++++++++++++++++++++++++---------------------- 13 files changed, 329 insertions(+), 320 deletions(-) diff --git a/src/ast.ml b/src/ast.ml index 953b515..22eb7d6 100644 --- a/src/ast.ml +++ b/src/ast.ml @@ -6,42 +6,43 @@ type ident = string Node.t (* expression has no side-effect. *) type expr = - Int of int Node.t - | String of string Node.t - | Bool of bool Node.t - | Float of float Node.t - | Var of ident - | Lambda of ident list * expr - | Call of expr list - | If of expr * expr * expr - | Let of (ident*expr) list * expr - | LetRec of (ident*expr) list * expr - | Block of expr list - | New of name * expr list - | Invoke of expr * ident * expr list (* (invoke ...)*) - | SlotRef of expr * ident - | SlotSet of expr * ident * expr + [ `Int of int Node.t + | `String of string Node.t + | `Bool of bool Node.t + | `Float of float Node.t + | `Var of ident + | `Lambda of ident list * expr + | `Call of expr list + | `If of expr * expr * expr + | `Let of (ident*expr) list * expr + | `LetRec of (ident*expr) list * expr + | `Block of expr list + | `New of name * expr list + | `Invoke of expr * ident * expr list + | `SlotRef of expr * ident + | `SlotSet of expr * ident * expr ] (* statement has side-effect *) type attr = ident type method_ = ident * ident list * expr + type stmt = - | Define of ident * expr - | Expr of expr - | Class of ident * name * attr list * method_ list + [ `Define of ident * expr + | `Expr of expr + | `Class of ident * name * attr list * method_ list ] type program = stmt list let lift_stmt f = function - Define (name,expr) -> - Define (name,f expr) - | Expr expr -> - Expr (f expr) - | Class (name,sname,attrs,body) -> + `Define (name,expr) -> + `Define (name,f expr) + | `Expr expr -> + `Expr (f expr) + | `Class (name,sname,attrs,body) -> let body' = List.map (Tuple.T3.map3 f) body in - Class (name,sname,attrs,body') + `Class (name,sname,attrs,body') let lift_program f = List.map (lift_stmt f) @@ -49,62 +50,62 @@ let rec map f expr = let g = map f in match expr with - Int _ | String _ | Bool _ | Float _ | Var _ -> + `Int _ | `String _ | `Bool _ | `Float _ | `Var _ -> f expr - | Lambda (name,expr') -> - f @@ Lambda (name,(g expr')) - | Call exprs -> - f @@ Call (List.map g exprs) - | If (a,b,c) -> - f @@ If ((g a),(g b),(g c)) - | Let (decl,body) -> + | `Lambda (name,expr') -> + f @@ `Lambda (name,(g expr')) + | `Call exprs -> + f @@ `Call (List.map g exprs) + | `If (a,b,c) -> + f @@ `If ((g a),(g b),(g c)) + | `Let (decl,body) -> let decl' = List.map (fun (a,b)->(a,g b)) decl in let body' = g body in - f @@ Let (decl',body') - | LetRec (decl,body) -> + f @@ `Let (decl',body') + | `LetRec (decl,body) -> let decl' = List.map (fun (a,b)->(a,g b)) decl in let body' = g body in - f @@ LetRec (decl',body') - | Block exprs' -> - f @@ Block (List.map g exprs') - | New (name,args) -> - f @@ New (name,List.map g args) - | Invoke (obj,name,args) -> - f @@ Invoke (g obj,name,List.map g args) - | SlotRef (obj,name) -> - f @@ SlotRef (g obj,name) - | SlotSet (obj,name,value) -> - f @@ SlotSet (g obj,name,g value) + f @@ `LetRec (decl',body') + | `Block exprs' -> + f @@ `Block (List.map g exprs') + | `New (name,args) -> + f @@ `New (name,List.map g args) + | `Invoke (obj,name,args) -> + f @@ `Invoke (g obj,name,List.map g args) + | `SlotRef (obj,name) -> + f @@ `SlotRef (g obj,name) + | `SlotSet (obj,name,value) -> + f @@ `SlotSet (g obj,name,g value) let rec to_string = function - Int n -> + `Int n -> Node.to_string (Printf.sprintf "Int %d") n - | String s -> + | `String s -> Node.to_string (Printf.sprintf "String %s") s - | Bool b -> + | `Bool b -> Node.to_string (fun b -> if true then "Bool true" else "Bool false") b - | Float d -> + | `Float d -> Node.to_string (Printf.sprintf "Float %f") d - | Var n -> + | `Var n -> Node.to_string (Printf.sprintf "Var %s") n - | Lambda (args,expr') -> + | `Lambda (args,expr') -> Printf.sprintf "Lambda (%s,%s)" (string_of_list @@ List.map (Node.to_string id) args) (to_string expr') - | Call exprs -> + | `Call exprs -> Printf.sprintf "Call %s" @@ string_of_list @@ List.map to_string exprs - | If (a,b,c) -> + | `If (a,b,c) -> Printf.sprintf "If (%s,%s,%s)" (to_string a) (to_string b) (to_string c) - | Let (decl,body) -> + | `Let (decl,body) -> let decl' = string_of_list @@ List.map (fun (a,b)-> @@ -114,7 +115,7 @@ let rec to_string = let body' = to_string body in Printf.sprintf "Let (%s,%s)" decl' body' - | LetRec (decl,body) -> + | `LetRec (decl,body) -> let decl' = string_of_list @@ List.map (fun (a,b)-> @@ -124,22 +125,22 @@ let rec to_string = let body' = to_string body in Printf.sprintf "LetRec (%s,%s)" decl' body' - | Block exprs -> + | `Block exprs -> Printf.sprintf "Block %s" @@ string_of_list @@ List.map to_string exprs - | New (name,args) -> + | `New (name,args) -> Printf.sprintf "New (%s,%s)" (Node.to_string (fun (a,b) -> a ^ ":" ^ b) name) @@ string_of_list @@ List.map to_string args - | Invoke (obj,name,args) -> + | `Invoke (obj,name,args) -> Printf.sprintf "Invoke (%s,%s,%s)" (to_string obj) (Node.to_string id name) @@ string_of_list @@ List.map to_string args - | SlotRef (obj,name) -> + | `SlotRef (obj,name) -> Printf.sprintf "SlotRef (%s,%s)" (to_string obj) @@ Node.to_string id name - | SlotSet (obj,name,value) -> + | `SlotSet (obj,name,value) -> Printf.sprintf "SlotSet (%s,%s,%s)" (to_string obj) (Node.to_string id name) @@ -147,13 +148,13 @@ let rec to_string = let to_string_stmt = function - Define (x,y) -> + `Define (x,y) -> Printf.sprintf "Define (%s,%s)" (Node.to_string id x) @@ to_string y - | Expr x -> + | `Expr x -> Printf.sprintf "Expr (%s)" (to_string x) - | Class (name,sname,attrs,body) -> + | `Class (name,sname,attrs,body) -> Printf.sprintf "Class (%s,%s,%s,%s)" (Node.to_string id name) (Node.to_string (fun (a,b) -> a ^ ":" ^ b) sname) diff --git a/src/ast.mli b/src/ast.mli index 6186b1c..89211c4 100644 --- a/src/ast.mli +++ b/src/ast.mli @@ -7,30 +7,30 @@ type ident = string Node.t (** expression has no side-effect. *) type expr = - Int of int Node.t - | String of string Node.t - | Bool of bool Node.t - | Float of float Node.t - | Var of ident - | Lambda of ident list * expr - | Call of expr list - | If of expr * expr * expr - | Let of (ident*expr) list * expr - | LetRec of (ident*expr) list * expr - | Block of expr list - | New of name * expr list - | Invoke of expr * ident * expr list (* (invoke ...)*) - | SlotRef of expr * ident - | SlotSet of expr * ident * expr + [ `Int of int Node.t + | `String of string Node.t + | `Bool of bool Node.t + | `Float of float Node.t + | `Var of ident + | `Lambda of ident list * expr + | `Call of expr list + | `If of expr * expr * expr + | `Let of (ident*expr) list * expr + | `LetRec of (ident*expr) list * expr + | `Block of expr list + | `New of name * expr list + | `Invoke of expr * ident * expr list (** (invoke ...)*) + | `SlotRef of expr * ident + | `SlotSet of expr * ident * expr ] type attr = ident type method_ = ident * ident list * expr (** statement has side-effect *) type stmt = - | Define of ident * expr - | Expr of expr - | Class of ident * name * attr list * method_ list + [ `Define of ident * expr + | `Expr of expr + | `Class of ident * name * attr list * method_ list ] type program = stmt list diff --git a/src/closTrans.ml b/src/closTrans.ml index 4f4db2e..57bfca5 100644 --- a/src/closTrans.ml +++ b/src/closTrans.ml @@ -1,9 +1,9 @@ open Base type stmt = - Plain of Ast.stmt - | DefineClass of ident * Ast.name * ident list - | DefineMethod of ident * (ident * ident) * ident list * Ast.expr + [ Ast.stmt + | `DefineClass of ident * Ast.name * ident list + | `DefineMethod of ident * (ident * ident) * ident list * Ast.expr] and attr = string Node.t and ident = string Node.t @@ -22,7 +22,7 @@ let methods_table program = Hashtbl.create 16 in program +> List.iter (function - DefineMethod (name,(self,{Node.value = klass}),args,body) -> + `DefineMethod (name,(self,{Node.value = klass}),args,body) -> Hashtbl.add tbl klass (name,self::args,body) | _ -> ()); @@ -31,25 +31,25 @@ let methods_table program = let methods_name_set program = set_of_list @@ HList.concat_map (function - DefineMethod ({Node.value = name},_,_,_) -> + `DefineMethod ({Node.value = name},_,_,_) -> [name] | _ -> []) program let expr_trans set = function - Ast.Call ((Ast.Var f)::obj::args) when PSet.mem f.Node.value set -> - Ast.Invoke (obj,f,args) + `Call ((`Var f)::obj::args) when PSet.mem f.Node.value set -> + `Invoke (obj,f,args) | e -> e let stmt_trans tbl set = function - Plain stmt -> + #Ast.stmt as stmt -> [Ast.lift_stmt (Ast.map @@ expr_trans set) stmt] - | DefineClass (klass,super,attrs) -> - [Ast.Class (klass,super,attrs,Hashtbl.find_all tbl klass.Node.value)] - | DefineMethod _ -> + | `DefineClass (klass,super,attrs) -> + [`Class (klass,super,attrs,Hashtbl.find_all tbl klass.Node.value)] + | `DefineMethod _ -> [] let trans program = @@ -61,16 +61,16 @@ let trans program = let to_string = function - Plain stmt -> + #Ast.stmt as stmt -> Ast.to_string_stmt stmt - | DefineClass (name,super,attrs) -> + | `DefineClass (name,super,attrs) -> Printf.sprintf "Class (%s,%s,%s)" (Node.to_string id name) (Node.to_string (fun (a,b) -> a^":"^b) super) @@ string_of_list @@ List.map (Node.to_string id) attrs - | DefineMethod (f,(self,klass),args,body) -> + | `DefineMethod (f,(self,klass),args,body) -> let show = Node.to_string id in - Printf.sprintf "Metod (%s,((%s %s) %s),%s)" + Printf.sprintf "Metod (%s,((%s %s) %s),%s)" (show f) (show self) (show klass) (string_of_list (List.map show args)) (Ast.to_string body) diff --git a/src/closTrans.mli b/src/closTrans.mli index 7bffb56..3d722d7 100644 --- a/src/closTrans.mli +++ b/src/closTrans.mli @@ -1,7 +1,7 @@ type stmt = - Plain of Ast.stmt - | DefineClass of ident * Ast.name * ident list - | DefineMethod of ident * (ident * ident) * ident list * Ast.expr + [ Ast.stmt + | `DefineClass of ident * Ast.name * ident list + | `DefineMethod of ident * (ident * ident) * ident list * Ast.expr] and attr = string Node.t and ident = string Node.t diff --git a/src/closureTrans.ml b/src/closureTrans.ml index a12efbc..f6ece4f 100644 --- a/src/closureTrans.ml +++ b/src/closureTrans.ml @@ -10,9 +10,9 @@ let union xs = let rec free_variable = function - Lambda (args,expr) -> + `Lambda (args,expr) -> PSet.diff (free_variable expr) (set_of_list args) - | Let (decl,expr) -> + | `Let (decl,expr) -> let xs = union @@ List.map (free_variable$snd) decl in let vars = @@ -20,7 +20,7 @@ let rec free_variable = let ys = PSet.diff (free_variable expr) vars in PSet.union xs ys - | LetRec (decl,expr) -> + | `LetRec (decl,expr) -> let xs = union @@ List.map (free_variable$snd) decl in let vars = @@ -28,17 +28,17 @@ let rec free_variable = let ys = free_variable expr in PSet.diff (PSet.union xs ys) vars - | Var {Node.value = x} -> + | `Var {Node.value = x} -> PSet.singleton x - | Ast.Call args -> + | `Call args -> union @@ List.map free_variable args - | If (cond,seq,alt) -> + | `If (cond,seq,alt) -> union [ free_variable cond; free_variable seq; free_variable alt; ] - | Block xs -> + | `Block xs -> union @@ List.map free_variable xs | _ -> PSet.empty @@ -46,20 +46,20 @@ let rec free_variable = let rec closure_fv = function - Lambda (_,body) as exp -> + `Lambda (_,body) as exp -> free_variable exp - | Ast.Call args -> + | `Call args -> union @@ List.map closure_fv args - | If (a,b,c) -> + | `If (a,b,c) -> union [ closure_fv a; closure_fv b; closure_fv c] - | Let (decls,body) | LetRec (decls,body) -> + | `Let (decls,body) | `LetRec (decls,body) -> let vars = set_of_list @@ List.map fst decls in PSet.diff (closure_fv body) vars - | Block exprs -> + | `Block exprs -> union @@ List.map closure_fv exprs | _ -> PSet.empty @@ -78,25 +78,24 @@ let wrap args body = List.map (fun var -> let x = {node with Node.value = var} in - (x,Var x)) fv in - Let (decls,body) + (x,`Var x)) fv in + `Let (decls,body) let expr_trans = function - Lambda (args,body) -> - Lambda (args,wrap args body) + `Lambda (args,body) -> + `Lambda (args,wrap args body) | e -> e let stmt_trans = function - Class (name,super,attrs,methods) -> - Class (name,super,attrs, - List.map (fun (name,args,body) -> - (name,args,wrap args body)) methods) + `Class (name,super,attrs,methods) -> + `Class (name,super,attrs, + List.map (fun (name,args,body) -> + (name,args,wrap args body)) methods) | stmt -> lift_stmt (Ast.map expr_trans) stmt let trans = List.map stmt_trans - diff --git a/src/codegen.ml b/src/codegen.ml index 6b2663d..6efb191 100644 --- a/src/codegen.ml +++ b/src/codegen.ml @@ -173,31 +173,31 @@ let rec generate_expr expr env = let gen e = generate_expr e env in match expr with - | Bool {value = b} -> + | `Bool {value = b} -> if b then [PushTrue] else [PushFalse] - | Float {value = v} -> + | `Float {value = v} -> [PushDouble v] - | String {value = str} -> + | `String {value = str} -> [PushString str] - | Int {value = n} when 0 <= n && n <= 0xFF -> + | `Int {value = n} when 0 <= n && n <= 0xFF -> [PushByte n] - | Int {value = n} -> + | `Int {value = n} -> [PushInt n] - | Block [] -> + | `Block [] -> [PushUndefined] - | Block xs -> + | `Block xs -> List.concat @@ interperse [Pop] @@ (List.map gen xs) - | New ({value = (ns,name)},args) -> + | `New ({value = (ns,name)},args) -> let qname = make_qname ~ns:ns name in List.concat [ [FindPropStrict qname]; HList.concat_map gen args; [ConstructProp (qname,List.length args)]] - | Lambda (args,body) -> + | `Lambda (args,body) -> arguments args (fun e args' -> let body' = @@ -208,66 +208,66 @@ let rec generate_expr expr env = params = args'; instructions = body' @ [ReturnValue] } in [NewFunction m]) - | Var {value = name} -> + | `Var {value = name} -> var_ref name env - | Let (vars,body) -> + | `Let (vars,body) -> let vars' = List.map (Tuple.T2.map2 gen) vars in let_scope env vars' @@ generate_expr body - | LetRec (vars,body) -> + | `LetRec (vars,body) -> let vars' = List.map (Tuple.T2.map2 generate_expr) vars in let_rec_scope env vars' @@ generate_expr body - | Invoke (obj,{value = name},args)-> + | `Invoke (obj,{value = name},args)-> List.concat [ gen obj; HList.concat_map gen args; [CallProperty (make_qname name,List.length args)]] - | SlotRef (obj,{value = name}) -> + | `SlotRef (obj,{value = name}) -> List.concat [ gen obj; [GetProperty (Cpool.make_qname name)]] - | SlotSet (obj,{value = name},value) -> + | `SlotSet (obj,{value = name},value) -> List.concat [ gen value; gen obj; [Swap; SetProperty (Cpool.make_qname name); PushUndefined]] - | Ast.Call (Var {value = name}::args) when is_builtin name args -> + | `Call (`Var {value = name}::args) when is_builtin name args -> let inst,_ = List.assoc name builtin in List.concat [ HList.concat_map gen args; [inst]] - | Ast.Call (Var {value = name}::args) -> + | `Call (`Var {value = name}::args) -> let args' = List.map gen args in var_call name args' env - | Ast.Call (name::args) -> + | `Call (name::args) -> let nargs = List.length args in List.concat [gen name; [GetGlobalScope]; HList.concat_map gen args; [Asm.Call nargs]] - | Ast.Call [] -> + | `Call [] -> failwith "must not happen" - | If (cond,cons,alt) -> + | `If (cond,cons,alt) -> let l_alt = Label.make () in let l_if = Label.make () in let prefix = List.concat @@ match cond with - Ast.Call [Var {value = "="};a;b] -> + `Call [`Var {value = "="};a;b] -> [gen a;gen b;[IfNe l_alt]] - | Ast.Call [Var {value = ">"};a;b] -> + | `Call [`Var {value = ">"};a;b] -> [gen a;gen b;[IfNgt l_alt]] - | Ast.Call [Var {value = ">="};a;b] -> + | `Call [`Var {value = ">="};a;b] -> [gen a;gen b;[IfNge l_alt]] - | Ast.Call [Var {value = "<"};a;b] -> + | `Call [`Var {value = "<"};a;b] -> [gen a;gen b;[IfNlt l_alt]] - | Ast.Call [Var {value = "<="};a;b] -> + | `Call [`Var {value = "<="};a;b] -> [gen a;gen b;[IfNle l_alt]] | _ -> [gen cond;[IfFalse l_alt]] in @@ -288,11 +288,11 @@ let init_prefix = let generate_stmt env stmt = match stmt with - Expr expr -> + `Expr expr -> env,(generate_expr expr env)@[Pop] - | Define ({value = name},body) -> + | `Define ({value = name},body) -> define_scope name env @@ generate_expr body - | Ast.Class ({value = klass_name},{value = (ns,sname)},attributes,body) -> + | `Class ({value = klass_name},{value = (ns,sname)},attributes,body) -> let klass_name' = make_qname klass_name in let sname' = diff --git a/src/lisp.ml b/src/lisp.ml index 59f611c..0db62d4 100644 --- a/src/lisp.ml +++ b/src/lisp.ml @@ -1,7 +1,6 @@ open Base open Sexp open Parsec -open ClosTrans let qname ({Node.value = sym} as node) = try @@ -50,15 +49,15 @@ let one_list hd tl = let rec expr = parser [<' Int n >] -> - Ast.Int n + `Int n | [<' String s >] -> - Ast.String s + `String s | [<' Bool b >] -> - Ast.Bool b + `Bool b | [<' Float v >] -> - Ast.Float v + `Float v | [<' Symbol name >] -> - Ast.Var name + `Var name | [< e = list p_list >] -> e and vars = @@ -68,7 +67,7 @@ and vars = and block = parser [< e = Parsec.many expr >] -> - Ast.Block e + `Block e and cond_clause = parser [< _ = keyword "else"; body = block>] -> @@ -78,7 +77,7 @@ and cond_clause = and p_list = parser [< _ = keyword "if"; t = expr; c = expr; a = expr >] -> - Ast.If (t,c,a) + `If (t,c,a) | [< _ =keyword "cond"; body = Parsec.many @@ list cond_clause >] -> List.fold_right (fun clause sub -> @@ -86,41 +85,41 @@ and p_list = `Else body -> body | `Cond (cond,body) -> - Ast.If (cond,body,sub)) - body (Ast.Block []) + `If (cond,body,sub)) + body (`Block []) | [< _ = keyword "let"; vars = list @@ Parsec.many @@ list vars; body = Parsec.many expr>] -> - Ast.Let (vars,Ast.Block body) + `Let (vars,`Block body) | [< _ = keyword "letrec"; vars = list @@ Parsec.many @@ list vars; body = block>] -> - Ast.LetRec (vars,body) + `LetRec (vars,body) | [< _ = keyword "begin"; body = block >] -> body | [< _ = keyword "lambda"; args = list @@ Parsec.many symbol; body = block >] -> - Ast.Lambda (args,body) + `Lambda (args,body) | [< _ = keyword "new"; name = symbol; args = Parsec.many expr >] -> - Ast.New (qname name,args) + `New (qname name,args) | [< _ = keyword "."; obj = expr; (name,args) = list @@ one_list symbol expr >] -> - Ast.Invoke (obj,name,args) + `Invoke (obj,name,args) | [< _ = keyword "slot-ref"; obj = expr; name = symbol >] -> - Ast.SlotRef (obj,name) + `SlotRef (obj,name) | [< _ = keyword "slot-set!";obj = expr; name = symbol; value = expr>] -> - Ast.SlotSet (obj,name,value) + `SlotSet (obj,name,value) | [< xs = Parsec.many expr >] -> - Ast.Call xs + `Call xs let define_value = parser [< _ = keyword "define"; name = symbol; body = Parsec.many expr >] -> - ClosTrans.Plain (Ast.Define (name,Ast.Block body)) + `Define (name,`Block body) let define_func = parser [< _ = keyword "define"; (name,args) = list @@ one_list symbol symbol; body = block >] -> let f = - Ast.Lambda (args,body) in - ClosTrans.Plain (Ast.Define (name,f)) + `Lambda (args,body) in + `Define (name,f) let define = (try_ define_value) <|> define_func @@ -137,19 +136,19 @@ let p_stmt = name = symbol; (super,_)= list @@ one_list symbol symbol; attr = list @@ many symbol >] -> - ClosTrans.DefineClass (name,qname super,attr) + `DefineClass (name,qname super,attr) | [< _ = keyword "define-method"; f = symbol; ((self,klass),args) = list @@ one_list (list @@ pair symbol symbol) symbol; body = block >] -> - ClosTrans.DefineMethod (f,(self,klass),args, body) + `DefineMethod (f,(self,klass),args, body) let stmt = parser [< s = list p_stmt >] -> s | [< x = expr >] -> - ClosTrans.Plain (Ast.Expr x) + (`Expr x) let loc s = function diff --git a/test/astUtil.ml b/test/astUtil.ml index 7c8013b..aad9b1c 100644 --- a/test/astUtil.ml +++ b/test/astUtil.ml @@ -8,36 +8,39 @@ let eq_ident {value = x} {value = y} = let rec eq_expr a b = match a,b with - Int {value = x}, Int {value = y} -> + `Int {value = x}, `Int {value = y} -> x = y - | String {value = x}, String {value = y} -> + | `String {value = x}, `String {value = y} -> x = y - | Bool {value = x}, Bool {value = y} -> + | `Bool {value = x}, `Bool {value = y} -> x = y - | Float {value = x}, Float {value = y} -> + | `Float {value = x}, `Float {value = y} -> x = y - | Var {value = x}, Var {value = y} -> + | `Var {value = x}, `Var {value = y} -> x = y - | Lambda (args,expr), Lambda (args',expr') -> + | `Lambda (args,expr), `Lambda (args',expr') -> (List.for_all2 eq_ident args args') && eq_expr expr expr' - | Call args, Call args' -> + | `Call args, `Call args' -> List.for_all2 eq_expr args args' - | If (a,b,c), If (a',b',c') -> + | `If (a,b,c), `If (a',b',c') -> List.for_all2 eq_expr [a;b;c] [a';b';c'] - | Let (decls,body), Let (decls',body') | LetRec (decls,body), LetRec (decls',body') -> + | `Let (decls,body), `Let (decls',body') + | `LetRec (decls,body), `LetRec (decls',body') -> let b = - HList.conj @@ List.map2 (fun (v,e) (v',e') -> eq_ident v v' && eq_expr e e') + List.for_all2 + (fun (v,e) (v',e') -> eq_ident v v' && eq_expr e e') decls' decls' in b && eq_expr body body' - | Block xs, Block xs' -> + | `Block xs, `Block xs' -> List.for_all2 eq_expr xs xs' - | New ({value=name},args), New ({value=name'},args') -> + | `New ({value=name},args), `New ({value=name'},args') -> name = name' && HList.conj @@ List.map2 eq_expr args args' - | Invoke (obj,name,args), Invoke (obj',name',args') -> - eq_expr obj obj' && eq_ident name name' && HList.conj @@ List.map2 eq_expr args args' - | SlotRef (obj,name), SlotRef (obj',name') -> + | `Invoke (obj,name,args), `Invoke (obj',name',args') -> + eq_expr obj obj' && eq_ident name name' && + List.for_all2 eq_expr args args' + | `SlotRef (obj,name), `SlotRef (obj',name') -> eq_expr obj obj' && eq_ident name name' - | SlotSet (obj,name,value), SlotSet (obj',name',value') -> + | `SlotSet (obj,name,value), `SlotSet (obj',name',value') -> eq_expr obj obj' && eq_ident name name' && eq_expr value' value' | _ -> false @@ -49,11 +52,12 @@ let eq_method (name,args,body) (name',args',body') = let eq_stmt a b = match a,b with - Define (name,body), Define (name',body') -> + `Define (name,body), `Define (name',body') -> eq_ident name name' && eq_expr body body' - | Expr expr, Expr expr' -> + | `Expr expr, `Expr expr' -> eq_expr expr expr' - | Class (name,{value=super},attrs,methods), Class (name',{value=super'},attrs',methods') -> + | `Class (name,{value=super},attrs,methods), + `Class (name',{value=super'},attrs',methods') -> eq_ident name name' && super = super' && (List.for_all2 eq_ident attrs attrs') && @@ -63,17 +67,16 @@ let eq_stmt a b = let eq_clos a b = match a,b with - Plain a,Plain b -> - eq_stmt a b - | DefineClass (name,{value=super},attrs), DefineClass (name',{value=super'},attrs') -> + `DefineClass (name,{value=super},attrs), `DefineClass (name',{value=super'},attrs') -> eq_ident name name' && super = super' && List.for_all2 eq_ident attrs attrs' - | DefineMethod (name,(self,obj),args,body), DefineMethod (name',(self',obj'),args',body') -> + | `DefineMethod (name,(self,obj),args,body), `DefineMethod (name',(self',obj'),args',body') -> eq_ident name name' && eq_ident self self' && eq_ident obj obj' && (List.for_all2 eq_ident args args') && eq_expr body body' - | _ -> - false + | a,b -> + eq_stmt a b + diff --git a/test/test_ast.ml b/test/test_ast.ml index 3de9966..fe6f534 100644 --- a/test/test_ast.ml +++ b/test/test_ast.ml @@ -9,27 +9,28 @@ let ok_stmt x y = OUnit.assert_equal ~printer:Ast.to_string_stmt x y let expr e = - Expr e + `Expr e let block x = - Block x + `Block x let int x = - Int (Node.empty x) + `Int (Node.empty x) let _ = ("ast module test" >::: [ "map" >:: (fun () -> ok (block [int 42; int 42; block [int 42]]) @@ - Ast.map (function Int n -> Int {n with Node.value = 42} | e -> e) @@ + Ast.map (function `Int n -> `Int {n with Node.value = 42} + | e -> e) @@ block [int 0; int 1; block [int 3]]); "lift" >:: (fun () -> ok_stmt (expr (int 42)) @@ - lift_stmt (Ast.map (function Int _ -> - int 42 | e -> e)) @@ + lift_stmt (Ast.map (function `Int _ -> + int 42 | e -> e)) @@ (expr (int 10))); ]) +> run_test_tt diff --git a/test/test_clostrans.ml b/test/test_clostrans.ml index 5750ecd..fce8dd9 100644 --- a/test/test_clostrans.ml +++ b/test/test_clostrans.ml @@ -17,31 +17,31 @@ let pos x n a b = end_pos = b} let string x = - String (node x) + `String (node x) let int x = - Int (node x) + `Int (node x) let float x = - Float (node x) + `Float (node x) let bool x = - Bool (node x) + `Bool (node x) let var x = - Var (node x) + `Var (node x) let meth name args body = (node name,List.map node args,body) let klass name super attrs methods = - Class (node name,node super,List.map node attrs,methods) + `Class (node name,node super,List.map node attrs,methods) let define_class name super attrs = - DefineClass (node name,node super,List.map node attrs) + `DefineClass (node name,node super,List.map node attrs) let define_method name self obj args body = - DefineMethod (node name,(node self,node obj),List.map node args,body) + `DefineMethod (node name,(node self,node obj),List.map node args,body) let _ = ("clos module test" >::: [ @@ -61,10 +61,10 @@ let _ = pos "Foo" 1 6 8 in let args = [pos "x" 1 9 10] in - ok [Class (klass,super,attrs, - [f,self::args,Block []])] @@ - trans [DefineClass (klass,super,attrs); - DefineMethod(f,(self,obj),args,Block [])]); + ok [`Class (klass,super,attrs, + [f,self::args,`Block []])] @@ + trans [`DefineClass (klass,super,attrs); + `DefineMethod(f,(self,obj),args,`Block [])]); "basic" >:: (fun () -> ok [klass "Foo" ("bar","Baz") [] @@ -77,32 +77,32 @@ let _ = trans [define_class "Foo" ("bar","Baz") ["x";"y"]]); "plain is not change" >:: (fun () -> - ok [Expr (int 42)] @@ - trans [Plain (Expr (int 42))]); + ok [`Expr (int 42)] @@ + trans [`Expr (int 42)]); "define and plain is mixed" >:: (fun () -> ok [klass "Foo" ("bar","Baz") [] [meth "f" ["self";"x"] (int 42)]; - Expr (int 42)] @@ + `Expr (int 42)] @@ trans [define_class "Foo" ("bar","Baz") []; - Plain (Expr (int 42)); + `Expr (int 42); define_method "f" "self" "Foo" ["x"] (int 42)]); "invoke" >:: (fun () -> ok [klass "Foo" ("bar","Baz") [] [meth "f" ["self";"x"] (int 42)]; - Expr (Invoke (var "obj",node "f",[int 10]))] @@ + `Expr (`Invoke (var "obj",node "f",[int 10]))] @@ trans [define_class "Foo" ("bar","Baz") []; define_method "f" "self" "Foo" ["x"] (int 42); - Plain (Expr (Call [var "f";var "obj";int 10]))]); + `Expr (`Call [var "f";var "obj";int 10])]); "invoke deep" >:: (fun () -> - ok [Expr (If (Invoke (var "obj",node "f",[int 10]), - Block [], - Block []))] @@ + ok [`Expr (`If (`Invoke (var "obj",node "f",[int 10]), + `Block [], + `Block []))] @@ trans [define_method "f" "self" "Foo" ["x"] (int 42); - Plain (Expr (If (Call [var "f";var "obj";int 10], - Block [], - Block [])))]) + `Expr (`If (`Call [var "f";var "obj";int 10], + `Block [], + `Block []))]) ]) +> run_test_tt diff --git a/test/test_closuretrans.ml b/test/test_closuretrans.ml index 096ec3f..466d844 100644 --- a/test/test_closuretrans.ml +++ b/test/test_closuretrans.ml @@ -20,18 +20,19 @@ let _ = ("closure trans" >::: [ "arguments" >:: (fun () -> - ok [Define (ident "f", - Lambda ([ident "x"], - (Let ([ident "x",Var (ident "x")], - Block [Lambda ([], - Block [Var (ident "x")])]))))] @@ - trans @@ compile_string "(define (f x) (lambda () x))"); + let lambda = + `Lambda ([ident "x"], + `Let ([ident "x",`Var (ident "x")], + `Block [`Lambda ([], + `Block [`Var (ident "x")])])) in + ok [`Define (ident "f",lambda)] @@ + trans @@ compile_string "(define (f x) (lambda () x))"); "class" >:: (fun () -> ok [ - Class (ident "Foo",ident ("","Object"),[], - [ident "init",[ident "self"], - Let ([ident "self",Var (ident "self")], - Block [Lambda ([],Block [Var (ident "self")])])])] @@ + `Class (ident "Foo",ident ("","Object"),[], + [ident "init",[ident "self"], + `Let ([ident "self",`Var (ident "self")], + `Block [`Lambda ([],`Block [`Var (ident "self")])])])] @@ trans @@ compile_string "(define-class Foo (Object) ())(define-method init ((self Foo)) (lambda () self))") ]) +> run_test_tt diff --git a/test/test_codegen.ml b/test/test_codegen.ml index f51d72b..a174728 100644 --- a/test/test_codegen.ml +++ b/test/test_codegen.ml @@ -8,22 +8,21 @@ open OUnit let node x = {(Node.empty x) with Node.filename = ""; Node.lineno = 0} - let string x = - String (node x) + `String (node x) let int x = - Int (node x) + `Int (node x) let float x = - Float (node x) + `Float (node x) let bool x = - Bool (node x) + `Bool (node x) let var x = - Var (node x) + `Var (node x) (** util function *) @@ -78,7 +77,7 @@ let qname name = QName ((Namespace ""),name) let compile x = - (generate_script [Expr x]) + (generate_script [`Expr x]) let new_class klass = (toplevel [ @@ -119,7 +118,7 @@ let _ = ok (expr [FindPropStrict (qname "print"); PushString "Hello"; CallPropLex ((qname "print"),1)]) @@ - compile (Call [var "print";string "Hello"])); + compile (`Call [var "print";string "Hello"])); "literal" >::: [ "int" >:: (fun () -> @@ -140,11 +139,11 @@ let _ = "+" >:: (fun () -> ok (expr [PushByte 1;PushByte 2;Add_i]) @@ - compile (Call [var "+";int 1;int 2])); + compile (`Call [var "+";int 1;int 2])); "=" >:: (fun () -> ok (expr [PushByte 1;PushByte 2;Equals]) @@ - compile (Call [var "=";int 1;int 2])) + compile (`Call [var "=";int 1;int 2])) ]; "if" >:: (fun () -> @@ -156,11 +155,11 @@ let _ = (expr [PushByte 10; PushByte 20; IfNe a; PushByte 0; Jump b; Asm.Label a;PushByte 1; Asm.Label b]) - (compile (If ((Call [var "=";int 10;int 20]),int 0,int 1)))); + (compile (`If ((`Call [var "=";int 10;int 20]),int 0,int 1)))); "block" >:: (fun () -> ok (expr [PushByte 1;Pop;PushByte 2]) @@ - compile (Block [int 1;int 2])); + compile (`Block [int 1;int 2])); "let" >:: (fun () -> ok (expr [PushString "x"; PushByte 1; @@ -173,8 +172,8 @@ let _ = GetScopeObject 1; GetProperty (qname "y"); PopScope]) @@ - compile (Let ([node "x",int 1;node "y",int 2], - Block [var "x";var "y"]))); + compile (`Let ([node "x",int 1;node "y",int 2], + `Block [var "x";var "y"]))); "letrec" >:: (fun () -> ok (expr [NewObject 0; @@ -184,7 +183,7 @@ let _ = SetProperty (qname "x"); PushByte 10; PopScope]) @@ - compile (LetRec ([node "x",int 42],Block [int 10]))); + compile (`LetRec ([node "x",int 42],`Block [int 10]))); "letrec for recursion" >:: (fun () -> ok (expr [NewObject 0; @@ -198,7 +197,7 @@ let _ = PushByte 42; PopScope]) @@ - compile (LetRec ([node "x",var "x"],Block [int 42]))); + compile (`LetRec ([node "x",var "x"],`Block [int 42]))); "define" >:: (fun () -> ok (toplevel [NewFunction (inner [] [PushByte 42]); @@ -235,11 +234,11 @@ let _ = "normal" >:: (fun () -> ok (expr [NewFunction (inner [] [PushByte 42]) ]) @@ - compile (Lambda ([],Block [int 42]))); + compile (`Lambda ([],`Block [int 42]))); "arguments" >:: (fun () -> ok (expr [NewFunction (inner [0;0] [GetLocal 2])]) @@ - compile (Lambda ([node "x";node "y"],Block [var "y"]))); + compile (`Lambda ([node "x";node "y"],`Block [var "y"]))); "lambda" >:: (fun () -> ok (expr [PushString "z"; PushByte 42; @@ -247,8 +246,8 @@ let _ = PushWith; NewFunction (inner [] [GetLex (qname "z")]); PopScope]) @@ - compile (Let ([node "z",int 42], - Lambda ([],Block [var "z"])))) + compile (`Let ([node "z",int 42], + `Lambda ([],`Block [var "z"])))) ]; "class" >::: [ "new" >:: diff --git a/test/test_lisp.ml b/test/test_lisp.ml index 43d30eb..ee4d9ee 100644 --- a/test/test_lisp.ml +++ b/test/test_lisp.ml @@ -6,7 +6,7 @@ open Ast open ClosTrans let expr xs = - [ClosTrans.Plain (Ast.Expr xs)] + [`Expr xs] let node x = {(Node.empty x) with Node.filename = ""; Node.lineno = 0} @@ -30,19 +30,19 @@ let syntax_error f = assert_bool "raised" true let string x = - String (node x) + `String (node x) let int x = - Int (node x) + `Int (node x) let float x = - Float (node x) + `Float (node x) let bool x = - Bool (node x) + `Bool (node x) let var x = - Var (node x) + `Var (node x) let pos x n a b = {(Node.empty x) with @@ -52,51 +52,53 @@ let pos x n a b = end_pos = b} let define_class name super attrs = - DefineClass (node name,node super,List.map node attrs) + `DefineClass (node name,node super,List.map node attrs) let define_method name self obj args body = - DefineMethod (node name,(node self,node obj),List.map node args,body) + `DefineMethod (node name,(node self,node obj),List.map node args,body) let _ = ("lisp module test" >::: [ "pos" >:: (fun () -> - check (expr (Int (pos 42 0 0 2))) @@ + check (expr (`Int (pos 42 0 0 2))) @@ Lisp.compile_string "42"; - check (expr (String (pos "hoge" 0 0 6))) @@ + check (expr (`String (pos "hoge" 0 0 6))) @@ Lisp.compile_string "\"hoge\""; - check (expr (Bool (pos true 0 0 2))) @@ + check (expr (`Bool (pos true 0 0 2))) @@ Lisp.compile_string "#t"; - check (expr (Var (pos "foo" 0 0 3))) @@ + check (expr (`Var (pos "foo" 0 0 3))) @@ Lisp.compile_string "foo"; - check (expr (Lambda ([pos "abc" 0 9 12],Block []))) @@ + check (expr (`Lambda ([pos "abc" 0 9 12],`Block []))) @@ Lisp.compile_string "(lambda (abc))"; - check (expr (Let ([pos "foo" 0 7 10,Int (pos 42 0 11 13)],Block []))) @@ + check (expr (`Let ([pos "foo" 0 7 10,`Int (pos 42 0 11 13)], + `Block []))) @@ Lisp.compile_string "(let [(foo 42)] )"; - check (expr (LetRec ([pos "foo" 0 10 13,Int (pos 42 0 14 16)],Block []))) @@ + check (expr (`LetRec ([pos "foo" 0 10 13,`Int (pos 42 0 14 16)], + `Block []))) @@ Lisp.compile_string "(letrec [(foo 42)] )"; - check (expr (New (pos ("","Foo") 0 5 8 ,[]))) @@ + check (expr (`New (pos ("","Foo") 0 5 8 ,[]))) @@ Lisp.compile_string "(new Foo)"; - check (expr (Invoke (Var (pos "foo" 0 3 6), pos "baz" 0 8 11,[]))) @@ + check (expr (`Invoke (`Var (pos "foo" 0 3 6), pos "baz" 0 8 11,[]))) @@ Lisp.compile_string "(. foo (baz))"; - check (expr (SlotRef (Var (pos "obj" 0 10 13),pos "name" 0 14 18))) @@ + check (expr (`SlotRef (`Var (pos "obj" 0 10 13),pos "name" 0 14 18))) @@ Lisp.compile_string "(slot-ref obj name)"; - check (expr (SlotSet (Var (pos "obj" 0 11 14), + check (expr (`SlotSet (`Var (pos "obj" 0 11 14), pos "name" 0 15 19, - Int (pos 42 0 20 22)))) @@ + `Int (pos 42 0 20 22)))) @@ Lisp.compile_string "(slot-set! obj name 42)"; - check [Plain (Define (pos "x" 0 8 9,Block [Int (pos 42 0 10 12)]))] @@ + check [`Define (pos "x" 0 8 9,`Block [`Int (pos 42 0 10 12)])] @@ Lisp.compile_string "(define x 42)"; - check [Plain (Define (pos "f" 0 9 10,Lambda ([pos "x" 0 11 12],Block [])))] @@ + check [`Define (pos "f" 0 9 10,`Lambda ([pos "x" 0 11 12],`Block []))] @@ Lisp.compile_string "(define (f x))"; - check [DefineClass (pos "Foo" 0 14 17, + check [`DefineClass (pos "Foo" 0 14 17, pos ("","Object") 0 19 25, [pos "arg" 0 28 31])] @@ Lisp.compile_string "(define-class Foo (Object) (arg))"; - check [DefineMethod (pos "fun" 0 15 18, + check [`DefineMethod (pos "fun" 0 15 18, (pos "self" 0 21 25,pos "Object" 0 26 32), [pos "xyz" 0 34 37], - Block [])] @@ + `Block [])] @@ Lisp.compile_string "(define-method fun ((self Object) xyz))"); "empty" >:: (fun () -> @@ -127,96 +129,100 @@ let _ = Lisp.compile_string "#f"); "call" >:: (fun () -> - ok (expr (Call [var "print"])) @@ + ok (expr (`Call [var "print"])) @@ Lisp.compile_string "(print)"; - ok (expr (Call [var "print";string "hello"])) @@ + ok (expr (`Call [var "print";string "hello"])) @@ Lisp.compile_string "(print \"hello\")"; - ok (expr (Call [var "print";string "hello";string "world"])) @@ + ok (expr (`Call [var "print";string "hello";string "world"])) @@ Lisp.compile_string "(print \"hello\" \"world\")"); "+" >:: (fun () -> - ok (expr (Call [var "+";int 1;int 2])) @@ + ok (expr (`Call [var "+";int 1;int 2])) @@ Lisp.compile_string "(+ 1 2)"; - ok (expr (Call [var "-";int 1;int 2])) @@ + ok (expr (`Call [var "-";int 1;int 2])) @@ Lisp.compile_string "(- 1 2)"; - ok (expr (Call [var "*";int 1;int 2])) @@ + ok (expr (`Call [var "*";int 1;int 2])) @@ Lisp.compile_string "(* 1 2)"; - ok (expr (Call [var "/";int 1;int 2])) @@ + ok (expr (`Call [var "/";int 1;int 2])) @@ Lisp.compile_string "(/ 1 2)"); "<" >:: (fun () -> - ok (expr (Call [var "=";int 1;int 2])) @@ + ok (expr (`Call [var "=";int 1;int 2])) @@ Lisp.compile_string "(= 1 2)"; - ok (expr (Call [var "<";int 1;int 2])) @@ + ok (expr (`Call [var "<";int 1;int 2])) @@ Lisp.compile_string "(< 1 2)"; - ok (expr (Call [var "<=";int 1;int 2])) @@ + ok (expr (`Call [var "<=";int 1;int 2])) @@ Lisp.compile_string "(<= 1 2)"; - ok (expr (Call [var ">";int 1;int 2])) @@ + ok (expr (`Call [var ">";int 1;int 2])) @@ Lisp.compile_string "(> 1 2)"; - ok (expr (Call [var ">=";int 1;int 2])) @@ + ok (expr (`Call [var ">=";int 1;int 2])) @@ Lisp.compile_string "(>= 1 2)"); "if" >:: (fun () -> - ok (expr (If (int 1,int 2,int 3))) @@ + ok (expr (`If (int 1,int 2,int 3))) @@ Lisp.compile_string "(if 1 2 3)"); "cond" >:: (fun () -> - ok (expr (If (int 1, - Block [int 2], - If (int 3, - Block [int 4], - Block [int 5])))) @@ + ok (expr (`If (int 1, + `Block [int 2], + `If (int 3, + `Block [int 4], + `Block [int 5])))) @@ Lisp.compile_string "(cond (1 2) (3 4) (else 5))"); "cond without else" >:: (fun () -> - ok (expr (If (int 1, - Block [int 2], - If (int 3, - Block [int 4], - Block [])))) @@ + ok (expr (`If (int 1, + `Block [int 2], + `If (int 3, + `Block [int 4], + `Block [])))) @@ Lisp.compile_string "(cond (1 2) (3 4))"); "let" >:: (fun () -> - ok (expr (Let ([node "x",int 1;node "y",int 2],Block [var "x";var "y"]))) @@ + ok (expr (`Let ([node "x",int 1;node "y",int 2], + `Block [var "x";var "y"]))) @@ Lisp.compile_string "(let ((x 1) (y 2)) x y)"); "letrec" >:: (fun () -> - ok (expr (LetRec ([node "x",int 1;node "y",int 2],Block [var "x";var "y"]))) @@ + ok (expr (`LetRec ([node "x",int 1;node "y",int 2], + `Block [var "x";var "y"]))) @@ Lisp.compile_string "(letrec ((x 1) (y 2)) x y)"); "begin" >:: (fun () -> - ok (expr (Block [int 1;int 2])) @@ + ok (expr (`Block [int 1;int 2])) @@ Lisp.compile_string "(begin 1 2)"); "lambda" >:: (fun () -> - ok (expr (Lambda ([],Block [int 42]))) @@ + ok (expr (`Lambda ([],`Block [int 42]))) @@ Lisp.compile_string "(lambda () 42)"); "lambda args" >:: (fun () -> - ok (expr (Lambda ([node "a";node "b";node "c"],Block [int 42]))) @@ + ok (expr (`Lambda ([node "a";node "b";node "c"], + `Block [int 42]))) @@ Lisp.compile_string "(lambda (a b c) 42)"); "new" >:: (fun () -> - ok (expr (New (node ("","Foo"),[]))) @@ + ok (expr (`New (node ("","Foo"),[]))) @@ Lisp.compile_string "(new Foo)"); "new args" >:: (fun () -> - ok (expr (New (node ("","Foo"),[int 1;int 2]))) @@ + ok (expr (`New (node ("","Foo"),[int 1;int 2]))) @@ Lisp.compile_string "(new Foo 1 2)"); "invoke" >:: (fun () -> - ok (expr (Invoke (var "foo",node "baz",[int 1;int 2]))) @@ + ok (expr (`Invoke (var "foo",node "baz",[int 1;int 2]))) @@ Lisp.compile_string "(. foo (baz 1 2))"); "define" >:: (fun () -> - ok [Plain (Define (node "x",Block [int 42]))] @@ + ok [`Define (node "x",`Block [int 42])] @@ Lisp.compile_string "(define x 42)"; - ok [Plain (Define (node "f",Lambda ([node "x"],Block [int 42])))] @@ + ok [`Define (node "f",`Lambda ([node "x"], + `Block [int 42]))] @@ Lisp.compile_string "(define (f x) 42)"); "bug()" >:: (fun () -> - ok [Plain (Expr (int 10)); - Plain (Define (node "x",Block [int 42]))] @@ + ok [`Expr (int 10); + `Define (node "x",`Block [int 42])] @@ Lisp.compile_string "10 (define x 42)"); "class" >:: (fun () -> @@ -228,15 +234,15 @@ let _ = Lisp.compile_string "(define-class Foo (flash.text.Object) ())"); "method" >:: (fun () -> - ok [define_method "f" "self" "Object" ["x";"y"] (Block [int 42])] @@ + ok [define_method "f" "self" "Object" ["x";"y"] (`Block [int 42])] @@ Lisp.compile_string "(define-method f ((self Object) x y) 42)"); "slot-ref" >:: (fun () -> - ok (expr (SlotRef (var "obj",node "name"))) @@ + ok (expr (`SlotRef (var "obj",node "name"))) @@ Lisp.compile_string "(slot-ref obj name)"); "slot-set!" >:: (fun () -> - ok (expr (SlotSet (var "obj",node "name",int 42))) @@ + ok (expr (`SlotSet (var "obj",node "name",int 42))) @@ Lisp.compile_string "(slot-set! obj name 42)"); "syntax error" >:: (fun () -> -- 2.11.0