Change: change 'define-class' from expr to stmt.

- Because 'define-class' changes environment, it is not expr,but stmt.

diff --git a/example/class.scm b/example/class.scm
index 3747d59..4735593 100644 (file)
--- a/example/class.scm
+++ b/example/class.scm
@@ -1,2 +1,2 @@
 (define-class Foo Object
-  ((init) 42))
\ No newline at end of file
+  ((init) "hello"))
\ No newline at end of file

diff --git a/src/ast.ml b/src/ast.ml
index 4594c44..956e880 100644 (file)
--- a/src/ast.ml
+++ b/src/ast.ml
@@ -13,12 +13,12 @@ type expr =
   | Let    of (string*expr) list * expr
   | LetRec of (string*expr) list * expr
   | Block  of expr list
-  | Class of string * string * (string * string list * expr) list
 
 (** statement has side-effect *)
 type stmt = 
   | Define of string * expr
   | Expr of expr
+  | Class of string * string * (string * string list * expr) list
 
 type program = stmt list
 
@@ -28,6 +28,11 @@ let lift_stmt f =
        Define (name,f expr)
     | Expr expr ->
        Expr (f expr)
+    | Class (name,sname,body) ->
+       let body' =
+         List.map (Core.Tuple.T3.map3 ~f:f) body in
+         Class (name,sname,body')
+
 
 let lift_program f = List.map (lift_stmt f)
 
@@ -57,8 +62,6 @@ let rec map f expr =
            f @@ LetRec (decl',body')
       | Block exprs' ->
          f @@ Block (List.map g exprs')
-      | Class (name,super,xs) ->
-         f @@ Class (name,super,List.map (Core.Tuple.T3.map3 ~f:g) xs)
   
 let rec to_string =
   function
@@ -93,10 +96,3 @@ let rec to_string =
          Printf.sprintf "LetRec (%s,%s)" decl' body'
     | Block exprs ->
        Printf.sprintf "Block [%s]" @@ String.concat "; " @@ List.map to_string exprs
-    | Class (name,super,xs) ->
-       let methods =
-         String.concat "; " @@ 
-           List.map (fun (name,args,body)->
-                       Printf.sprintf "(%s,[%s],%s)" name (String.concat "; " args) @@ to_string body)
-           xs in
-         Printf.sprintf "Class (%s,%s,%s)" name super methods

diff --git a/src/ast.mli b/src/ast.mli
index da5b9b2..ce8cf73 100644 (file)
--- a/src/ast.mli
+++ b/src/ast.mli
@@ -13,12 +13,12 @@ type expr =
   | Let    of (string*expr) list * expr
   | LetRec of (string*expr) list * expr
   | Block  of expr list
-  | Class of string * string * (string * string list * expr) list
 
 (** A type of statement. Statement has side-effect *)
 type stmt = 
   | Define of string * expr
   | Expr of expr
+  | Class of string * string * (string * string list * expr) list
 
 (** A tyye of program. *)
 type program = stmt list

diff --git a/src/codegen.ml b/src/codegen.ml
index 4e33595..9608a71 100644 (file)
--- a/src/codegen.ml
+++ b/src/codegen.ml
@@ -89,26 +89,6 @@ let rec generate_expr expr env =
        let m =
          Asm.make_meth ~args:args' "" @@ generate_expr body env' in
          [NewFunction m]
-    | Class (name,sname,xs) ->
-       let name',sname' =
-         make_qname name,make_qname sname in
-       let methods =
-         List.map (fun (name,args,body)-> 
-                     match gen @@ Lambda (args,body) with
-                         [NewFunction m] -> (name,m)
-                       | _ -> failwith "must not happen") xs in
-       let init = 
-         List.assoc "init" methods in
-       let klass = {
-         Asm.cname = name';
-         sname     = sname';
-         flags_k   = [Sealed];
-         cinit     = make_meth "cinit" [PushInt 42];
-         iinit     = init;
-         interface = [];
-         methods   = List.map snd @@ List.remove_assoc "init" methods;
-       } in
-         [GetLex sname';PushScope;GetLex sname';NewClass klass]
     | Var name ->
        let qname = 
          make_qname name in
@@ -233,6 +213,27 @@ let generate_stmt env stmt =
                        Swap;
                        SetProperty (make_qname name)]] in
          env',body'
+    | Class (name,sname,xs) ->
+       let name',sname' =
+         make_qname name,make_qname sname in
+       let methods =
+         List.map (fun (name,args,body)-> 
+                     match generate_expr (Lambda (args,body)) env with
+                         [NewFunction m] -> (name,m)
+                       | _ -> failwith "must not happen") xs in
+       let init = 
+         List.assoc "init" methods in
+       let klass = {
+         Asm.cname = name';
+         sname     = sname';
+         flags_k   = [Sealed];
+         cinit     = make_meth "cinit" [PushInt 42];
+         iinit     = init;
+         interface = [];
+         methods   = List.map snd @@ List.remove_assoc "init" methods;
+       } in
+         env,[GetLex sname';PushScope;GetLex sname';NewClass klass]
+
 
 let generate_program xs env =
   List.concat @@ snd @@ map_accum_left generate_stmt env xs

diff --git a/src/lisp.ml b/src/lisp.ml
index 245ede2..77d9ac1 100644 (file)
--- a/src/lisp.ml
+++ b/src/lisp.ml
@@ -35,21 +35,6 @@ let rec make_expr =
              let body' =
                List.map make_expr body in
              Ast.Lambda (List.map ensure_symbol args,Ast.Block body')
-         | Symbol "define-class"::Symbol name::Symbol sname::body ->
-             (* "(define-class Foo Object ((init x) x))" *)
-             let body' =
-               List.map (function List ((List x)::xs) -> 
-                           begin match List.map ensure_symbol x with
-                               name::args ->
-                                 let xs' = 
-                                   List.map make_expr xs in
-                                   (name,args,Ast.Block xs')
-                             | _ ->
-                                 failwith "syntax error"
-
-                           end
-                           | _ -> failwith "syntax error") body in
-               Ast.Class (name,sname,body')      
          | _ ->
              Ast.Call (List.map make_expr xs)
        end
@@ -71,6 +56,20 @@ let make_stmt =
        let f = 
          Ast.Lambda (args',body') in
        Ast.Define (name,f)
+    | List (Symbol "define-class"::Symbol name::Symbol sname::body) ->
+       (* "(define-class Foo Object ((init x) x))" *)
+       let body' =
+         List.map (function List ((List x)::xs) -> 
+                     begin match List.map ensure_symbol x with
+                         name::args ->
+                           let xs' = 
+                             List.map make_expr xs in
+                             (name,args,Ast.Block xs')
+                       | _ ->
+                           failwith "syntax error"
+                     end
+                     | _ -> failwith "syntax error") body in
+         Ast.Class (name,sname,body')    
     | expr ->
        Ast.Expr (make_expr expr)