Commits

shawnh  committed 21ab0dd

Made a little hack to allow annotating the type of variables.

  • Participants
  • Parent commits cb2b519

Comments (0)

Files changed (8)

 LINKFLAGS=-linkpkg
 OCAMLOPTFLAGS=
 
-SRC_FILES := blub_types.mli blub_error.ml blub_misc.ml blub_common.ml blub_ast.ml blub_environment.ml blub_typecheck.ml blub_closure.ml blub_llvm.ml blub_vm.ml blub_list.ml blub_parse.mly blub_vector.ml blub_num.ml blub_string.ml blub_lexer.mll blub_primitives.ml blub_interp.ml
+SRC_FILES := blub_types.mli blub_error.ml blub_misc.ml blub_common.ml blub_typecheck.ml blub_ast.ml blub_environment.ml blub_closure.ml blub_llvm.ml blub_vm.ml blub_list.ml blub_parse.mly blub_vector.ml blub_num.ml blub_string.ml blub_lexer.mll blub_primitives.ml blub_interp.ml
 ML_FILES  := $(filter %.ml,$(patsubst %.mll,%.ml,$(SRC_FILES:%.mly=%.ml)))
 MLI_FILES := $(filter %.mli,$(SRC_FILES:%.mly=%.mli))
 CMX_FILES := $(ML_FILES:%.ml=%.cmx) 
     | Callcc of ast
     | Set of var * ast
 
-  and var = string * int
+  and var = string * type_
 
   type environment = variable StringMap.t
 
 	  Lit l -> A_lit l
 	| Ref (r, type_) -> begin
 	    try
-	      A_ref (StringMap.find r env)
+	      let var = StringMap.find r env in
+	      Blub_typecheck.unify var.var_type type_;
+	      A_ref var
 	    with Not_found ->
-	      A_ref (mkglobal r)
+	      A_ref (mkglobal type_ r)
 	  end
 	| Cnd (e1, e2, e3) -> A_cnd (convert env e1,
 				     convert env e2,
 	| Seq exprs -> A_seq (Array.map (convert env) exprs)
 
 	| Abs (params, varargs, body) -> 
-	    let params = Array.map (fun (name, type_) -> mklocal name) params in
+	    let params = Array.map 
+	      (fun (name, type_) -> mklocal type_ name) params in
 	    let env = Array.fold_right 
 	      (fun var env -> StringMap.add var.var_name var env)
 	      params env
 	    let env, bindings = Array.fold_left
 	      (fun (env, bindings) ((name, type_), expr) ->
 		 let expr = convert env expr in
-		 let var = mklocal name in
+		 let var = mklocal type_ name in
 		 let env = StringMap.add var.var_name var env in
 		 let binding = (var, expr) in
 		 (env, binding :: bindings)) (env, []) bindings
 
 	| Let (bindings, body, letrec) ->
 	    let bindings = Array.map 
-	      (fun ((name, type_), expr) -> (mklocal name, expr)) bindings in
+	      (fun ((name, type_), expr) -> (mklocal type_ name, expr)) 
+	      bindings in
 	    let locals = Array.map fst bindings in
 	    let env' = Array.fold_right
 	      (fun var env -> StringMap.add var.var_name var env)

File blub_common.ml

     Typevar(ref None, !cur_index)
 ;;
 
-let mklocal = 
+let mklocal type_ = 
   let cur_index = ref 0 in
   fun name ->
     incr cur_index;
     { var_name=name; 
       var_uname="%" ^ name ^ "." ^ (string_of_int !cur_index);
-      var_type=typevar () }
+      var_type=type_ }
 ;;
   
-let mkglobal name =
+let mkglobal type_ name =
   { var_name=name;
     var_uname=name;
-    var_type=typevar () }
+    var_type=type_ }
 ;;
 
 let _pp_list ppe f = function

File blub_environment.ml

 open Printf
 open Blub_types
+open Blub_common
 open Blub_ast
 
 
   type t = env_frame
 
   let create () =
-    { vars = Array.create 10000 (Blub_common.mkglobal "");
+    let temp_tv = typevar () in
+    { vars = Array.create 10000 (Blub_common.mkglobal temp_tv "");
       vals = Array.create 10000 Sunbound }
   ;;
 
   ;;
 
 
+  let mkglobal name = Blub_common.mkglobal (typevar ()) name ;;
+
   let set_pfn env fn name =
-    bind env (Blub_common.mkglobal name) (Spfn fn)
+    bind env (mkglobal name) (Spfn fn)
   ;;
 
   let set_pf0 env fn name =
     let wrapper = function
 	[|  |] -> fn ()
     in
-    bind env (Blub_common.mkglobal name) (Spfn wrapper)
+    bind env (mkglobal name) (Spfn wrapper)
   ;;
   let set_pf1 env fn name =
     let wrapper = function
 	[| arg |] -> fn arg
     in
-    bind env (Blub_common.mkglobal name) (Spfn wrapper)
+    bind env (mkglobal name) (Spfn wrapper)
   ;;
 
   let set_pf2 env fn name =
     let wrapper = function
 	[| arg1; arg2 |] -> fn arg1 arg2
     in
-    bind env (Blub_common.mkglobal name) (Spfn wrapper)
+    bind env (mkglobal name) (Spfn wrapper)
   ;;
 
   let set_pf3 env fn name =
     let wrapper = function
 	[| arg1; arg2; arg3 |] -> fn arg1 arg2 arg3
     in
-    bind env (Blub_common.mkglobal name) (Spfn wrapper)
+    bind env (mkglobal name) (Spfn wrapper)
   ;;
 
   let set_pfe env fn name =
-    bind env (Blub_common.mkglobal name) (Spfe fn)
+    bind env (mkglobal name) (Spfe fn)
   ;;
 
 

File blub_lexer.mll

 {
   open Blub_parse
+  open Blub_types
 }
 
 let digit = ['0' - '9']
 	STRING s
       }
 
+  | "#Int" { TYPE_ANNOT Int }
+
   | (initial subsequent*) | peculiar_id as id { IDENTIFIER id }
       
 

File blub_parse.mly

 open Printf
 open Blub_types
 open Blub_ast.Ast
+open Blub_common
 
-let mkvar name = (name, 33) ;;
+let mkvar name = (name, typevar ()) ;;
 %}
 
 
 %token <string> STRING
 %token QUOTE TINYQUOTE IF BEGIN LAMBDA LET LETREC LETSTAR DEFINE DOT SET CALLCC SHIFT RESET
 %token COND ELSE ARROW
+%token <Blub_types.type_> TYPE_ANNOT 
 
 %start command_or_definition
 %type <Blub_ast.Ast.expr_or_def> command_or_definition
 
 variable:
   IDENTIFIER { mkvar $1 }
+| IDENTIFIER TYPE_ANNOT { ($1, $2) }
 ;
 
 cond:

File blub_primitives.ml

 	    eval_expr global_frame expr
 	| Blub_ast.Ast.Def ((name, type_), expr) ->
 	    (* create a global variable for 'name' and eval the expression *)
-	    Blub_environment.Env.bind global_frame (Blub_common.mkglobal name) Sunbound;
+	    Blub_environment.Env.bind global_frame (Blub_common.mkglobal (typevar ()) name) Sunbound;
 	    eval_expr global_frame (Blub_ast.Ast.Set ((name, type_), expr))
       in
       if is_repl then 
 	  eval acc globals env rib stack next
 	    
       | B_conti x ->
-	  let var = mklocal "conti" in
+	  let var = mklocal (typevar ()) "conti" in
 	  let body = B_nuate (stack, (var, Lbinding (0, 0))) in
 	  let abs = { lam_params = [| var |];
 		      lam_varargs = false;