Commit 320cb519 authored by Pietro Abate's avatar Pietro Abate

[r2003-03-14 16:14:17 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-14 16:15:14+00:00
parent 88300a9b
......@@ -8,18 +8,18 @@ parser/ast.cmo: types/ident.cmo parser/location.cmi types/types.cmi
parser/ast.cmx: types/ident.cmx parser/location.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/chars.cmi \
types/ident.cmo types/intervals.cmi parser/location.cmi \
parser/parser.cmo: parser/ast.cmo types/atoms.cmi types/builtin.cmo \
types/chars.cmi types/ident.cmo types/intervals.cmi parser/location.cmi \
types/sequence.cmi types/types.cmi parser/wlexer.cmo parser/parser.cmi
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/chars.cmx \
types/ident.cmx types/intervals.cmx parser/location.cmx \
parser/parser.cmx: parser/ast.cmx types/atoms.cmx types/builtin.cmx \
types/chars.cmx types/ident.cmx types/intervals.cmx parser/location.cmx \
types/sequence.cmx types/types.cmx parser/wlexer.cmx parser/parser.cmi
parser/wlexer.cmo: parser/location.cmi
parser/wlexer.cmx: parser/location.cmx
typing/typed.cmo: types/ident.cmo parser/location.cmi types/patterns.cmi \
types/sortedMap.cmi types/types.cmi
types/types.cmi
typing/typed.cmx: types/ident.cmx parser/location.cmx types/patterns.cmx \
types/sortedMap.cmx types/types.cmx
types/types.cmx
typing/typer.cmo: parser/ast.cmo types/builtin.cmo types/ident.cmo \
types/intervals.cmi parser/location.cmi types/patterns.cmi \
types/sequence.cmi typing/typed.cmo types/types.cmi typing/typer.cmi
......@@ -59,11 +59,11 @@ types/sortedMap.cmx: types/sortedMap.cmi
types/type_bool.cmo: types/boolean.cmi types/recursive.cmo
types/type_bool.cmx: types/boolean.cmx types/recursive.cmx
types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
types/intervals.cmi types/normal.cmi misc/pool.cmi types/recursive.cmo \
types/sortedList.cmi types/sortedMap.cmi misc/state.cmi types/types.cmi
types/ident.cmo types/intervals.cmi types/normal.cmi types/recursive.cmo \
types/sortedList.cmi misc/state.cmi types/types.cmi
types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
types/intervals.cmx types/normal.cmx misc/pool.cmx types/recursive.cmx \
types/sortedList.cmx types/sortedMap.cmx misc/state.cmx types/types.cmi
types/ident.cmx types/intervals.cmx types/normal.cmx types/recursive.cmx \
types/sortedList.cmx misc/state.cmx types/types.cmi
runtime/eval.cmo: types/atoms.cmi types/ident.cmo types/intervals.cmi \
runtime/load_xml.cmi parser/location.cmi runtime/print_xml.cmo \
runtime/run_dispatch.cmi misc/state.cmi typing/typed.cmo \
......@@ -72,22 +72,24 @@ runtime/eval.cmx: types/atoms.cmx types/ident.cmx types/intervals.cmx \
runtime/load_xml.cmx parser/location.cmx runtime/print_xml.cmx \
runtime/run_dispatch.cmx misc/state.cmx typing/typed.cmx \
runtime/value.cmx runtime/eval.cmi
runtime/load_xml.cmo: types/atoms.cmi parser/location.cmi types/sortedMap.cmi \
types/types.cmi runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: types/atoms.cmx parser/location.cmx types/sortedMap.cmx \
types/types.cmx runtime/value.cmx runtime/load_xml.cmi
runtime/print_xml.cmo: types/atoms.cmi types/chars.cmi types/sequence.cmi \
types/types.cmi runtime/value.cmi
runtime/print_xml.cmx: types/atoms.cmx types/chars.cmx types/sequence.cmx \
types/types.cmx runtime/value.cmx
runtime/run_dispatch.cmo: types/patterns.cmi types/types.cmi \
runtime/value.cmi runtime/run_dispatch.cmi
runtime/run_dispatch.cmx: types/patterns.cmx types/types.cmx \
runtime/value.cmx runtime/run_dispatch.cmi
runtime/value.cmo: types/atoms.cmi types/chars.cmi types/intervals.cmi \
types/sequence.cmi types/sortedMap.cmi types/types.cmi runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/chars.cmx types/intervals.cmx \
types/sequence.cmx types/sortedMap.cmx types/types.cmx runtime/value.cmi
runtime/load_xml.cmo: types/atoms.cmi types/ident.cmo parser/location.cmi \
runtime/value.cmi runtime/load_xml.cmi
runtime/load_xml.cmx: types/atoms.cmx types/ident.cmx parser/location.cmx \
runtime/value.cmx runtime/load_xml.cmi
runtime/print_xml.cmo: types/atoms.cmi types/chars.cmi types/ident.cmo \
types/sequence.cmi runtime/value.cmi
runtime/print_xml.cmx: types/atoms.cmx types/chars.cmx types/ident.cmx \
types/sequence.cmx runtime/value.cmx
runtime/run_dispatch.cmo: types/chars.cmi types/ident.cmo types/patterns.cmi \
types/types.cmi runtime/value.cmi runtime/run_dispatch.cmi
runtime/run_dispatch.cmx: types/chars.cmx types/ident.cmx types/patterns.cmx \
types/types.cmx runtime/value.cmx runtime/run_dispatch.cmi
runtime/value.cmo: types/atoms.cmi types/builtin.cmo types/chars.cmi \
types/ident.cmo types/intervals.cmi types/sequence.cmi types/types.cmi \
runtime/value.cmi
runtime/value.cmx: types/atoms.cmx types/builtin.cmx types/chars.cmx \
types/ident.cmx types/intervals.cmx types/sequence.cmx types/types.cmx \
runtime/value.cmi
driver/cduce.cmo: parser/ast.cmo types/builtin.cmo runtime/eval.cmi \
types/ident.cmo parser/location.cmi parser/parser.cmi types/patterns.cmi \
misc/state.cmi typing/typed.cmo typing/typer.cmi types/types.cmi \
......@@ -110,16 +112,15 @@ parser/parser.cmi: parser/ast.cmo
typing/typer.cmi: parser/ast.cmo types/ident.cmo typing/typed.cmo \
types/types.cmi
types/boolean.cmi: types/sortedList.cmi
types/normal.cmi: types/boolean.cmi
types/patterns.cmi: types/ident.cmo types/types.cmi
types/sequence.cmi: types/atoms.cmi types/types.cmi
types/sortedMap.cmi: types/sortedList.cmi
types/syntax.cmi: types/patterns.cmi types/types.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
misc/pool.cmi types/sortedMap.cmi
types/types.cmi: types/atoms.cmi types/chars.cmi types/ident.cmo \
types/intervals.cmi
runtime/eval.cmi: types/ident.cmo typing/typed.cmo runtime/value.cmi
runtime/load_xml.cmi: runtime/value.cmi
runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi
runtime/value.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
types/sortedMap.cmi types/types.cmi
runtime/value.cmi: types/atoms.cmi types/chars.cmi types/ident.cmo \
types/intervals.cmi types/types.cmi
driver/cduce.cmi: runtime/eval.cmi typing/typer.cmi
......@@ -97,6 +97,10 @@ EXTEND
mk noloc (Op ("raise",[mk noloc (Var (ident "x"))]))) in
mk loc (Try (e,b@[default]))
| "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
| "if"; e = SELF; "then"; e1 = SELF; "else"; e2 = SELF ->
let p1 = mk loc (Internal (Builtin.true_type))
and p2 = mk loc (Internal (Builtin.false_type)) in
mk loc (Match (e, [p1,e1; p2,e2]))
| "transform"; e = SELF; "with"; b = branches ->
let default = mk noloc (Capture (ident "x")), cst_nil in
mk loc (Op ("flatten", [mk loc (Map (e,b@[default]))]))
......@@ -109,6 +113,15 @@ EXTEND
]
|
[ e1 = expr; op = ["=" | "<=" | "<<" | ">>" | ">=" ]; e2 = expr ->
let op = match op with
| "<<" -> "<"
| ">>" -> ">"
| s -> s in
mk loc (Op (op,[e1;e2]))
]
|
[ e1 = expr; op = ["+" | "-" | "@"]; e2 = expr -> mk loc (Op (op,[e1;e2]))
]
......
This diff is collapsed.
......@@ -18,6 +18,7 @@ classes
exception Unterminated_string
exception Unterminated_string_in_comment
(* Buffer for string literals *)
let string_buff = Buffer.create 1024
......@@ -26,6 +27,11 @@ classes
let s = Buffer.contents string_buff in
Buffer.clear string_buff;
s
let store_special = function
| 'n' -> store_char '\n'
| 'r' -> store_char '\r'
| 't' -> store_char '\t'
| c -> raise (Illegal_character '\\')
let string_start_pos = ref 0;;
let comment_start_pos : int list ref = ref [];;
......@@ -61,7 +67,7 @@ rule token = parse
}
| [ "<>=.,:;+-*/@&{}[]()|?`!" ]
| "->" | "::" | ";;" | "--" | ":=" | "\\" | "++"
| "{|" | "|}"
| "{|" | "|}" | "<=" | ">=" | "<<" | ">>"
| ["?+*"] "?"
{ "",Lexing.lexeme lexbuf }
......@@ -119,6 +125,9 @@ and string2 = parse
| '\\' ['\\' '"']
{ store_char (Lexing.lexeme_char lexbuf 1);
string2 engine lexbuf }
| '\\' lowercase {
store_special (Lexing.lexeme_char lexbuf 1);
string1 engine lexbuf }
| '\\' ascii_digit+
{ store_char (char_for_decimal_code (Lexing.lexeme lexbuf));
string2 engine lexbuf }
......@@ -135,6 +144,9 @@ and string1 = parse
| '\\' ['\\' '\'']
{ store_char (Lexing.lexeme_char lexbuf 1);
string1 engine lexbuf }
| '\\' lowercase {
store_special (Lexing.lexeme_char lexbuf 1);
string1 engine lexbuf }
| '\\' ascii_digit+
{ store_char (char_for_decimal_code (Lexing.lexeme lexbuf));
string1 engine lexbuf }
......
......@@ -70,6 +70,11 @@ let rec eval env e0 =
| Typed.Op ("string_of", [e]) -> eval_string_of (eval env e)
| Typed.Op ("dump_to_file", [e1; e2]) ->
eval_dump_to_file (eval env e1) (eval env e2)
| Typed.Op ("=",[e1; e2]) -> eval_equal (eval env e1) (eval env e2)
| Typed.Op ("<",[e1; e2]) -> eval_lt (eval env e1) (eval env e2)
| Typed.Op ("<=",[e1; e2]) -> eval_lte (eval env e1) (eval env e2)
| Typed.Op (">",[e1; e2]) -> eval_gt (eval env e1) (eval env e2)
| Typed.Op (">=",[e1; e2]) -> eval_gte (eval env e1) (eval env e2)
| Typed.Dot (e, l) -> eval_dot l (eval env e)
| Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
......@@ -170,3 +175,23 @@ and eval_string_of v =
Format.pp_print_flush ppf ();
string (Buffer.contents b)
and eval_equal v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 = 0)
and eval_lt v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 < 0)
and eval_lte v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 <= 0)
and eval_gt v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 > 0)
and eval_gte v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 >= 0)
......@@ -4,6 +4,13 @@ open Value
open Ident
open Patterns.Compile
(*
module Array = struct
include Array
let get = unsafe_get
end
*)
let make_result_prod v1 r1 v2 r2 v (code,r) =
let ret = Array.map
(function
......
......@@ -16,6 +16,10 @@ exception CDuceExn of t
let nil = Atom Sequence.nil_atom
let string s = String (0,String.length s, s, nil)
let vtrue = Atom Builtin.true_atom
let vfalse = Atom Builtin.false_atom
let vbool x = if x then vtrue else vfalse
let const = function
| Types.Integer i -> Integer i
......@@ -109,8 +113,49 @@ and print_field ppf (l,v) =
Format.fprintf ppf "%s=%a" (LabelPool.value l) print v
let normalize_string i j s q =
if i = j then q else
Pair (Char (Chars.mk_char (String.unsafe_get s i)), String (succ i,j,s,q))
let normalize = function
| String (i,j,s,q) ->
if i = j then q else
Pair (Char (Chars.mk_char s.[i]), String (succ i,j,s,q))
| String (i,j,s,q) -> normalize_string i j s q
| v -> assert false
let rec compare x y =
if (x == y) then 0
else
match (x,y) with
| Pair (x1,x2), Pair (y1,y2) | Xml (x1,x2), Xml (y1,y2) ->
let c = compare x1 y1 in if c <> 0 then c
else compare x2 y2
| Record rx, Record ry -> LabelMap.compare compare rx ry
| Atom x, Atom y -> Atoms.vcompare x y
| Integer x, Integer y -> Intervals.vcompare x y
| Char x, Char y -> Chars.vcompare x y
| Abstraction (_,_), Abstraction (_,_) ->
raise (CDuceExn (string "comparing functional values"))
| Absent,_ | _,Absent -> assert false
| String (ix,jx,sx,qx), String (iy,jy,sy,qy) ->
if (sx == sy) && (ix = iy) && (jx = jy) then compare qx qy
else
(* Note: we would like to compare first jx-ix and jy-iy,
but this is not compatible with the equivalence of values *)
let rec aux ix iy =
if (ix = jx) then
if (iy = jy) then compare qx qy
else compare qx (normalize_string iy jy sy qy)
else
if (iy = jy) then compare (normalize_string ix jx sx qx) qy
else
let c1 = String.unsafe_get sx ix
and c2 = String.unsafe_get sy iy in
if c1 < c2 then -1 else
if c1 > c2 then 1 else aux (ix + 1) (iy + 1)
in
aux ix iy
| String (i,j,s,q), _ -> compare (normalize_string i j s q) y
| _, String (i,j,s,q) -> compare x (normalize_string i j s q)
| _,_ -> Obj.tag (Obj.repr x) - Obj.tag (Obj.repr y)
(* TODO: rewrite this case *)
......@@ -27,6 +27,11 @@ val normalize: t -> t
val const : Types.const -> t
val string : string -> t
val nil : t
val vtrue : t
val vfalse : t
val vbool : bool -> t
val get_string : t -> string
val is_str : t -> bool
val compare : t -> t -> int
This diff is collapsed.
......@@ -2,6 +2,7 @@ module AtomPool = Pool.Make(SortedList.String)
type v = AtomPool.t
let value = AtomPool.value
let mk = AtomPool.mk
let vcompare = AtomPool.compare
module SList = SortedList.Make_transp(SortedList.Lift(AtomPool))
type t = Finite of unit SList.t | Cofinite of unit SList.t
......
......@@ -2,6 +2,7 @@ type v
val value: v -> string
val mk: string -> v
val print_v: Format.formatter -> v -> unit
val vcompare: v -> v -> int
type t
......
......@@ -5,6 +5,13 @@ let intstr =
)
)
let true_atom = Atoms.mk "true"
let false_atom = Atoms.mk "false"
let true_type = Types.atom (Atoms.atom true_atom)
let false_type = Types.atom (Atoms.atom false_atom)
let bool = Types.cup true_type false_type
let types =
[
"Empty", Types.empty;
......@@ -16,4 +23,5 @@ let types =
"Arrow", Types.Arrow.any;
"Record", Types.Record.any;
"String", Sequence.string;
"Bool", bool
];
......@@ -23,6 +23,9 @@ let print_v ppf c =
let print_v_in_string ppf c =
Format.fprintf ppf "%c" (Char.chr c)
let vcompare (v1:int) v2 =
if v1 = v2 then 0 else if v1 < v2 then -1 else 1
type t = (v * v) list
......
......@@ -5,6 +5,7 @@ val to_int: v -> int
val to_char: v -> char
val print_v : Format.formatter -> v -> unit
val print_v_in_string : Format.formatter -> v -> unit
val vcompare: v -> v -> int
type t (* = (Unichar.t * Unichar.t) list *)
val equal : t -> t -> bool
......
......@@ -2,6 +2,7 @@ open Big_int
type v = big_int
let print_v ppf i = Format.fprintf ppf "%s" (string_of_big_int i)
let vcompare = compare_big_int
let mk = big_int_of_string
let vadd = add_big_int
let vmult = mult_big_int
......
......@@ -2,6 +2,7 @@ type v
val print_v : Format.formatter -> v -> unit
val mk: string -> v
val vcompare: v -> v -> int
val vadd: v -> v -> v
val vmult: v -> v -> v
val vsub: v -> v -> v
......
......@@ -78,6 +78,8 @@ sig
val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list
val mapi_to_list: ('a elem -> 'b -> 'c) -> ('a,'b) map -> 'c list
val assoc: 'a elem -> ('a,'b) map -> 'b
val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int
end
end
......@@ -337,6 +339,16 @@ module Map = struct
else raise Not_found
| [] -> raise Not_found
let rec compare f l1 l2 =
if l1 == l2 then 0
else match (l1,l2) with
| (x1,y1)::l1, (x2,y2)::l2 ->
let c = X.compare x1 x2 in if c <> 0 then c
else let c = f y1 y2 in if c <> 0 then c
else compare f l1 l2
| [],_ -> -1
| _,[] -> 1
end
end
......
......@@ -75,6 +75,7 @@ sig
val map_to_list: ('b -> 'c) -> ('a,'b) map -> 'c list
val mapi_to_list: ('a elem -> 'b -> 'c) -> ('a,'b) map -> 'c list
val assoc: 'a elem -> ('a,'b) map -> 'b
val compare: ('b -> 'b -> int) -> ('a,'b) map -> ('a,'b) map -> int
end
end
......
(* TODO:
rewrite type-checking of operators to propagate constraint *)
(* I. Transform the abstract syntax of types and patterns into
the internal form *)
......@@ -893,6 +896,14 @@ and type_op loc op args =
Types.interval Intervals.any
| "string_of", [loc1,t1] ->
Sequence.string
| ("=" | "<=" | "<" | ">" | ">=" ), [loc1,t1; loc2,t2] ->
(* could prevent comparision of functional value here... *)
(* could also handle the case when t1 and t2 are the same
singleton type *)
if Types.is_empty (Types.cap t1 t2) then
Builtin.false_type
else
Builtin.bool
| _ -> assert false
and type_int_binop f loc1 t1 loc2 t2 =
......
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