[r2004-06-28 00:23:45 by afrisch] Types abstraits, unit, Any

Original author: afrisch
Date: 2004-06-28 00:23:46+00:00

ocamliface/mlstub.ml

@@ -49,8 +49,11 @@ and typ_descr = function
   | Abstract "int" -> Builtin_defs.caml_int
   | Abstract "char" -> Builtin_defs.char_latin1
   | Abstract "string" -> Builtin_defs.string_latin1
+  | Abstract s -> Types.abstract (Types.Abstract.atom s)
   | Builtin ("list", [t]) -> Types.descr (Sequence.star_node (typ t))
   | Builtin ("Pervasives.ref", [t]) -> Builtin_defs.ref_type (typ t)
+  | Builtin ("CDuce_all.Value.t", []) -> Types.any
+  | Builtin ("unit", []) -> Sequence.nil_type
   | _ -> assert false
 	   
 and pvariant = function
@@ -174,11 +177,14 @@ and to_cd_descr e = function
   | Abstract "int" -> <:expr< ocaml2cduce_int $e$ >>
   | Abstract "char" -> <:expr< ocaml2cduce_char $e$ >>
   | Abstract "string" -> <:expr< ocaml2cduce_string $e$ >>
+  | Abstract s -> <:expr< Value.abstract $str:String.escaped s$ $e$ >>
   | Builtin ("list",[t]) ->
       (* Value.sequence_rev (List.rev_map fun_t <...>) *)
       <:expr< Value.sequence_rev (List.rev_map $lid:to_cd_fun t$ $e$) >>
   | Builtin ("Pervasives.ref",[t]) ->
        failwith "to_cd: Reference. TODO"
+  | Builtin ("CDuce_all.Value.t", []) -> e
+  | Builtin ("unit", []) -> <:expr< do { $e$; Value.nil } >>
   | _ -> assert false
 
 and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd <:expr< $lid:id$ >> t) tl vars
@@ -275,6 +281,7 @@ and to_ml_descr e = function
   | Abstract "int" -> <:expr< cduce2ocaml_int $e$ >>
   | Abstract "char" -> <:expr< cduce2ocaml_char $e$ >>
   | Abstract "string" -> <:expr< cduce2ocaml_string $e$ >>
+  | Abstract s -> <:expr< Value.get_abstract $e$ >>
   | Builtin ("list",[t]) ->
       (* List.rev_map fun_t (Value.get_sequence_rev <...> *)
       <:expr< List.rev_map $lid:to_ml_fun t$ (Value.get_sequence_rev $e$) >>
@@ -283,6 +290,8 @@ and to_ml_descr e = function
       let e = <:expr< Value.get_field $e$ $label_ascii "get"$ >> in
       let e = <:expr< Eval.eval_apply $e$ Value.nil >> in
       <:expr< Pervasives.ref $to_ml e t$ >>
+  | Builtin ("CDuce_all.Value.t", []) -> e
+  | Builtin ("unit", []) -> <:expr< ignore $e$ >>
   | _ -> assert false
 
 and tuple_to_ml tl vars = List.map2 (fun t id -> to_ml <:expr< $lid:id$ >> t) tl vars

ocamliface/mltypes.ml

@@ -78,7 +78,7 @@ let new_slot () =
 
 let builtins =
   List.fold_left (fun m x -> StringMap.add x () m) StringMap.empty
-    ["list"; "Pervasives.ref" ]
+    ["list"; "Pervasives.ref"; "CDuce_all.Value.t"; "unit" ]
 
 let rec unfold seen constrs ty =
   try
@@ -141,8 +141,8 @@ let rec unfold seen constrs ty =
 		       Link (loop t)
 		   | Type_abstract, None ->
 		       (match args with
-			  | [] -> Abstract (Path.name p)
-			  | _ -> failwith "Polymorphic abstract type")))
+			  | [] -> Abstract pn
+			  | _ -> failwith ("Polymorphic abstract type: " ^ pn))))
        | _ -> failwith "Unsupported feature"
     );
     slot

parser/parser.ml

@@ -518,6 +518,8 @@ EXTEND
       | schema = IDENT; "#"; typ = [ IDENT | keyword ];
         kind = OPT [ "as"; k = schema_kind -> k] ->
           mk loc (SchemaVar (kind, U.mk schema, U.mk typ))
+      | "!"; a = IDENT ->
+	  mk loc (Internal (Types.abstract (Types.Abstract.atom a)))
       | a = IDENT -> 
 	  mk loc (PatVar (U.mk a))
       | i = INT ; "--"; j = INT -> 

runtime/value.ml

@@ -256,10 +256,8 @@ let rec print ppf v =
 	(Utf8.get_idx i) (Utf8.get_idx j) (Utf8.get_str s) print q
     | Concat (x,y) ->
 	Format.fprintf ppf "<concat:%a;%a>" print x print y
-    | Abstract ((cu,id),_) ->
-	Format.fprintf ppf "<abstract=%a:%a>" 
-	  Utf8.print (Types.CompUnit.value cu) 
-	  Utf8.print (Id.value id)
+    | Abstract (s,_) ->
+	Format.fprintf ppf "<abstract=%s>" s
     | Absent -> 	
 	Format.fprintf ppf "<[absent]>"
     | Delayed x ->
@@ -353,10 +351,8 @@ let dump_xml ppf v =
     | Abstraction2 _ ->
         Format.fprintf ppf "@[<hv1>";
         Format.fprintf ppf "<abstraction2 />@]"
-    | Abstract ((cu,id),_) ->
-	Format.fprintf ppf "<abstract><unit>%a</unit><type>%a</type></abstract>" 
-	  Utf8.print (Types.CompUnit.value cu) 
-	  Utf8.print (Id.value id)
+    | Abstract (s,_) ->
+	Format.fprintf ppf "<abstract>%s</abstract>" s
     | String_latin1 (_, _, s, v) ->
         Format.fprintf ppf "@[<hv1>";
         Format.fprintf ppf "<string_latin1>@,%s@,</string_latin1>@," s;
@@ -397,14 +393,12 @@ let rec compare x y =
       | Integer x, Integer y -> Intervals.V.compare x y
       | Char x, Char y -> Chars.V.compare x y
       | Abstraction (_,_), _
-      | _, Abstraction (_,_) -> 
-	  raise (CDuceExn (string_latin1 "comparing functional values"))
+      | _, Abstraction (_,_)
       | Abstraction2 (_,_,_), _
       | _, Abstraction2 (_,_,_) -> 
 	  raise (CDuceExn (string_latin1 "comparing functional values"))
-      | Abstract ((cu1,id1),v1), Abstract ((cu2,id2),v2) ->
-	  let c = Types.CompUnit.compare cu1 cu2 in if c <> 0 then c 
-	  else let c = Id.compare id1 id2 in if c <> 0 then c
+      | Abstract (s1,v1), Abstract (s2,v2) ->
+	  let c = Types.Abstract.T.compare s1 s2 in if c <> 0 then c 
 	  else raise (CDuceExn (string_latin1 "comparing abstract values"))
       | Absent,_ | _,Absent 
       | Delayed _, _ | _, Delayed _ -> assert false
@@ -575,3 +569,10 @@ let get_field v l =
     | Record fields -> LabelMap.assoc l fields
     | _ -> raise Not_found
 
+let abstract a v =
+  Abstract (a,Obj.repr v)
+
+let get_abstract = function
+  | Abstract (_,v) -> Obj.magic v
+  | _ -> assert false
+  

runtime/value.mli

@@ -61,6 +61,9 @@ val get_field : t -> label -> t
 
 val get_variant : t -> string * t option
 
+val abstract : Types.Abstract.abs -> 'a -> t
+val get_abstract : t -> 'a
+
   (* iterator on the content of an Xml value. First callback is invoked on Utf8
   character children; second callback is invoked on other children values *)
 val iter_xml : (U.t -> unit) -> (t -> unit) -> t -> unit

types/builtin_defs.ml

@@ -63,7 +63,7 @@ let ref_type t =
   Types.record' (false , mk_ref ~get ~set)
 
 let float_abs =
-  Types.CompUnit.pervasives, Ident.Id.mk (Encodings.Utf8.mk "float")
+  "float"
 
 let float =
   Types.abstract (Types.Abstract.atom float_abs)

types/sample.ml

@@ -33,7 +33,10 @@ let rec get memo t =
     let r = List.sort (fun (_,_,n1) (_,_,n2) -> -(compare n1 n2)) r in
     try_seq record r with Not_found ->
   try Types.Arrow.sample t with Not_found ->
+    t
+(*
   raise Not_found
+*)
      
 let get = get D.empty
 

types/types.ml

@@ -172,7 +172,7 @@ end
 
 module Abstract =
 struct
-  module T = Custom.Pair(CompUnit)(Id)
+  module T = Custom.String
   type abs = T.t
 
   module V =
@@ -185,7 +185,8 @@ struct
   let print = function
     | Finite [] -> [ ]
     | Cofinite [] -> [ fun ppf -> Format.fprintf ppf "Abstract" ]
-    | _ -> failwith "Types.Abstract.print"
+    | Finite l -> List.map (fun x ppf -> Format.fprintf ppf "!%s" x) l
+    | Cofinite _ -> assert false
 
 end
 

types/types.mli

@@ -29,10 +29,12 @@ module CompUnit : sig
 end
 
 module Abstract : sig
-  type abs = CompUnit.t * Ident.id
+  module T : Custom.T with type t = string
+  type abs = T.t
   type t
   val any: t
   val atom: abs -> t
+  val compare: t -> t -> int
 
   module V : sig
     type t = abs * Obj.t
@@ -253,3 +255,4 @@ sig
   val print: Format.formatter -> t -> unit
 end
 
+