Commit 2c1fdf63 authored by Pietro Abate's avatar Pietro Abate

[r2005-03-21 16:38:36 by afrisch] Empty log message

Original author: afrisch
Date: 2005-03-21 16:38:37+00:00
parent 6fd7a218
DIRS= misc types
DIRS= misc types compile runtime
SRC= \
misc/serialize.mli \
......@@ -42,7 +42,13 @@ SRC= \
types/sample.mli \
types/sample.ml \
types/patterns.mli \
types/patterns.ml
types/patterns.ml \
compile/lambda.mli \
compile/lambda.ml \
runtime/value.mli \
runtime/value.ml \
runtime/serial.mli \
runtime/serial.ml
ML_SRC=$(filter %.ml,$(SRC))
......
module T = Custom.Pair(Custom.Array(Types))(Custom.Array(Patterns.Node))
module P = struct
let typs = ref [] and nb_typs = ref (-1)
let pats = ref [] and nb_pats = ref (-1)
let init () = typs:=[]; pats:=[]; nb_typs:=0; nb_pats:=0
let mk () =
let typs = Array.of_list !typs in
let pats = Array.of_list !pats in
Serialize.Put.run T.serialize (typs,pats)
let typ t = typs:=t::!typs; incr nb_typs; !nb_typs
let pat t = pats:=t::!pats; incr nb_pats; !nb_pats
end
module G = struct
type chunk = Types.t array * Patterns.Node.t array
let mk s = Serialize.Get.run T.deserialize s
let typ (x,_) i = x.(i)
let pat (_,x) i = x.(i)
end
module P : sig
val init: unit -> unit
val mk: unit -> string
val typ: Types.t -> int
val pat: Patterns.Node.t -> int
end
module G : sig
type chunk
val mk: string -> chunk
val typ: chunk -> int -> Types.t
val pat: chunk -> int -> Patterns.Node.t
end
......@@ -602,11 +602,16 @@ let get_abstract = function
| _ -> assert false
let get_label = LabelPool.mk (Ns.empty, U.mk "get")
let set_label = LabelPool.mk (Ns.empty, U.mk "set")
let mk_rf ~get ~set =
LabelMap.from_list_disj [ get_label, get; set_label, set ]
let mk_ref t v =
let r = ref v in
let get = Abstraction (Some [Sequence.nil_type, t], fun _ -> !r)
and set = Abstraction (Some [t, Sequence.nil_type], fun x -> r := x; nil) in
Record (Builtin_defs.mk_ref ~get ~set)
Record (mk_rf ~get ~set)
let mk_ext_ref t get set =
......@@ -616,7 +621,7 @@ let mk_ext_ref t get set =
and set = Abstraction (
(match t with Some t -> Some [t, Sequence.nil_type] | None -> None),
fun v -> set v; nil) in
Record (Builtin_defs.mk_ref ~get ~set)
Record (mk_rf ~get ~set)
let ocaml2cduce_int i =
......@@ -637,16 +642,24 @@ let cduce2ocaml_string_utf8 s = fst (get_string_utf8 s)
let ocaml2cduce_char c =
Char (Chars.V.mk_char c)
let ocaml2cduce_wchar c =
Char (Chars.V.mk_int c)
let cduce2ocaml_char = function
| Char c -> Chars.V.to_char c
| _ -> assert false
(*
let ocaml2cduce_bigint i =
Integer (Intervals.V.from_bigint i)
let cduce2ocaml_bigint = function
| Integer i -> Intervals.V.get_bigint i
| _ -> assert false
*)
let ocaml2cduce_atom ns l =
Atom (Atoms.V.mk (Ns.mk ns) l)
let print_utf8 v =
print_string (U.get_str v);
......@@ -654,7 +667,7 @@ let print_utf8 v =
let float n =
Abstract (Builtin_defs.float_abs, Obj.repr n)
Abstract ("float", Obj.repr n)
let cduce2ocaml_option f v =
match normalize v with
......@@ -668,3 +681,20 @@ let ocaml2cduce_option f = function
let add v1 v2 = match (v1,v2) with
| (Integer x, Integer y) -> Integer (Intervals.V.add x y)
| (Record r1, Record r2) -> Record (LabelMap.merge (fun x y -> y) r1 r2)
| _ -> assert false
let pair v1 v2 = Pair (v1,v2)
let xml v1 v2 v3 = Xml (v1,v2,v3)
let mk_record labels fields =
let l = ref [] in
assert (Array.length labels == Array.length fields);
for i = 0 to Array.length labels - 1 do
let (ns,lab) = labels.(i) in
l := (LabelPool.mk (Ns.mk ns, lab), fields.(i)) :: !l
done;
Record (LabelMap.from_list_disj !l)
......@@ -120,10 +120,17 @@ val ocaml2cduce_string_utf8 : U.t -> t
val cduce2ocaml_string_utf8 : t -> U.t
val ocaml2cduce_char : char -> t
val cduce2ocaml_char : t -> char
val ocaml2cduce_bigint : Big_int.big_int -> t
val cduce2ocaml_bigint : t -> Big_int.big_int
(*val ocaml2cduce_bigint : Big_int.big_int -> t
val cduce2ocaml_bigint : t -> Big_int.big_int*)
val ocaml2cduce_option: ('a -> t) -> 'a option -> t
val cduce2ocaml_option: (t -> 'a) -> t -> 'a option
val ocaml2cduce_wchar : int -> t
val ocaml2cduce_atom : U.t -> U.t -> t
val print_utf8: U.t -> unit
val add: t -> t -> t
val pair: t -> t -> t
val xml: t -> t -> t -> t
val mk_record: (U.t * U.t) array -> t array -> t
......@@ -256,10 +256,7 @@ binary_op_gen "+"
Types.Record.merge t1 t2
)
else raise (Typer.Error "The first argument mixes integers and records"))
(fun v1 v2 -> match (v1,v2) with
| (Value.Integer x, Value.Integer y) -> Value.Integer (Intervals.V.add x y)
| (Value.Record r1, Value.Record r2) -> Value.Record (LabelMap.merge (fun x y -> y) r1 r2)
| _ -> assert false);;
Value.add;;
binary_op "-"
int int
......
......@@ -71,7 +71,6 @@ module Compile: sig
val actions: dispatcher -> actions
val types_of_codes: dispatcher -> Types.t array
type 'a rhs = Match of (id * int) list * 'a | Fail
......
......@@ -58,14 +58,14 @@ types/types.cmi: types/atoms.cmi types/chars.cmi misc/custom.cmo \
types/ident.cmo types/intervals.cmi misc/inttbl.cmi misc/ns.cmi
types/types.cmo: types/atoms.cmi misc/bool.cmi types/chars.cmi \
misc/custom.cmo misc/encodings.cmi types/ident.cmo types/intervals.cmi \
misc/inttbl.cmi types/normal.cmi misc/pool.cmi misc/pretty.cmi \
misc/serialize.cmi types/sortedList.cmi misc/state.cmi misc/stats.cmi \
types/types.cmi
misc/inttbl.cmi types/normal.cmi misc/ns.cmi misc/pool.cmi \
misc/pretty.cmi misc/serialize.cmi types/sortedList.cmi misc/state.cmi \
misc/stats.cmi types/types.cmi
types/types.cmx: types/atoms.cmx misc/bool.cmx types/chars.cmx \
misc/custom.cmx misc/encodings.cmx types/ident.cmx types/intervals.cmx \
misc/inttbl.cmx types/normal.cmx misc/pool.cmx misc/pretty.cmx \
misc/serialize.cmx types/sortedList.cmx misc/state.cmx misc/stats.cmx \
types/types.cmi
misc/inttbl.cmx types/normal.cmx misc/ns.cmx misc/pool.cmx \
misc/pretty.cmx misc/serialize.cmx types/sortedList.cmx misc/state.cmx \
misc/stats.cmx types/types.cmi
types/sequence.cmi: types/atoms.cmi types/types.cmi
types/sequence.cmo: types/atoms.cmi types/types.cmi types/sequence.cmi
types/sequence.cmx: types/atoms.cmx types/types.cmx types/sequence.cmi
......@@ -84,3 +84,23 @@ types/patterns.cmx: types/atoms.cmx types/chars.cmx misc/custom.cmx \
types/ident.cmx types/sample.cmx types/sequence.cmx misc/serialize.cmx \
types/sortedList.cmx misc/state.cmx misc/stats.cmx types/types.cmx \
types/patterns.cmi
compile/lambda.cmi: types/ident.cmo misc/ns.cmi types/patterns.cmi \
misc/serialize.cmi types/types.cmi
compile/lambda.cmo: types/ident.cmo misc/ns.cmi types/patterns.cmi \
misc/serialize.cmi types/types.cmi compile/lambda.cmi
compile/lambda.cmx: types/ident.cmx misc/ns.cmx types/patterns.cmx \
misc/serialize.cmx types/types.cmx compile/lambda.cmi
runtime/value.cmi: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cmi misc/ns.cmi \
types/types.cmi
runtime/value.cmo: types/atoms.cmi types/chars.cmi misc/encodings.cmi \
types/ident.cmo types/intervals.cmi compile/lambda.cmi misc/ns.cmi \
types/sequence.cmi types/types.cmi runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/chars.cmx misc/encodings.cmx \
types/ident.cmx types/intervals.cmx compile/lambda.cmx misc/ns.cmx \
types/sequence.cmx types/types.cmx runtime/value.cmi
runtime/serial.cmi: types/patterns.cmi types/types.cmi
runtime/serial.cmo: types/patterns.cmi misc/serialize.cmi types/types.cmi \
runtime/serial.cmi
runtime/serial.cmx: types/patterns.cmx misc/serialize.cmx types/types.cmx \
runtime/serial.cmi
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