Commit 394baf3c authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: afrisch
Date: 2004-06-28 00:23:46+00:00
parent af3603b3
......@@ -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
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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
......@@ -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
......
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment