Commit 81f5fd25 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Test the OCaml interface, and introduce native support for floats

(float litteral are not allowed in patterns since testing the equality of floats
 is a tricky business).
 While adding a test using OCaml's complex number module, fixed several bugs in the
 parser (for overloaded functions) and in the runtime.
parent a8dfb887
......@@ -59,6 +59,7 @@ and compile_aux env = function
| Typed.Apply (e1,e2) -> Apply (compile env e1, compile env e2)
| Typed.Abstraction a -> compile_abstr env a
| Typed.Cst c -> Const (Value.const c)
| Typed.Abstract v -> Const (Value.Abstract v)
| Typed.Pair (e1,e2) -> Pair(compile env e1, compile env e2)
| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }, None) ->
Xml (compile env e1, compile env e2, compile env e3)
......
......@@ -266,10 +266,14 @@ let phrases ppf phs =
ev_top ~run:true ~show:(show ppf) ~directive:(directive ppf) phs
let catch_exn ppf_err exn =
if not catch_exceptions then raise exn;
if not catch_exceptions then begin
if Printexc.backtrace_status () then Printexc.print_backtrace stderr;
raise exn;
end;
match exn with
| (End_of_file | Failure _ | Not_found | Invalid_argument _ | Sys.Break) as e
->
if Printexc.backtrace_status () then Printexc.print_backtrace stderr;
raise e
| exn ->
print_exn ppf_err exn;
......
......@@ -60,6 +60,7 @@ and pexpr =
| Xml of pexpr * pexpr
| RecordLitt of (label * pexpr) list
| String of U.uindex * U.uindex * U.t * pexpr
| Abstract of Types.Abstract.V.t
(* Data destructors *)
| Match of pexpr * branches
......
......@@ -26,6 +26,8 @@ let pp_token ?(content = false) fmt t =
| EOI -> pp "%s" "EOI"
| EQ -> pp "%s" "EQ"
| EQQMARK -> pp "%s" "EQQMARK"
| FLOAT f -> pp "%s" "IDENT";
if content then pp "(\"%s\")" (string_of_float f)
| FROM -> pp "%s" "FROM"
| FUN -> pp "%s" "FUN"
| GT -> pp "%s" "GT"
......@@ -130,6 +132,7 @@ let all_tokens =
(EOI, "the end of input");
(EQ, "=");
(EQQMARK, "=?");
(FLOAT 42.0, "a float");
(FROM, "from");
(FUN, "fun");
(GT, ">");
......@@ -227,11 +230,14 @@ let string_of_token tok =
| ANY_IN_NS n -> n ^ ":*"
| HASH_DIRECTIVE n -> "n"
| INT i -> i
| IDENT i -> i
| FLOAT f -> string_of_float f
| STRING1 s -> "'" ^ escape_string s ^ "'"
| STRING2 s -> "\"" ^ escape_string s ^ "\""
| RESOLVED_INCLUDE _ -> ""
| _ -> List.assoc tok all_tokens
| _ ->try
List.assoc tok all_tokens
with Not_found -> Format.sprintf "Unknown token %d\n" (Obj.tag (Obj.repr tok))
let text_of_token tok = try List.assoc tok all_tokens with Not_found -> ""
let expect_message fmt l =
......
......@@ -156,13 +156,14 @@ let id_dummy = U.mk "$$$"
%token <string> STRING1
%token <string> STRING2
%token <string> INT
%token <float> FLOAT
%token <string> HASH_DIRECTIVE
%token <Ast.pprog> RESOLVED_INCLUDE
%token EOI
/* Priorities */
%nonassoc "in"
%nonassoc "with"
%nonassoc "->"
%nonassoc "|"
%nonassoc below_SEMI
%nonassoc ";"
......@@ -183,7 +184,7 @@ let id_dummy = U.mk "$$$"
%nonassoc "!" unary_op
%left "::"
%left "."
%nonassoc "," ")"
%nonassoc ","
%start <Ast.pprog> prog
%start <Ast.pprog> top_phrases
......@@ -674,11 +675,19 @@ let_binding:
;
%inline fun_decl_after_lpar:
x = or_pat "->" y = or_pat
other_arrows = list (";" p1 = or_pat "->" p2 = or_pat {(p1,p2)})
x = var_pat "->" y = separated_nonempty_list ("->", var_pat)
other_arrows =
list (";" p1 = var_pat "->" p2 = separated_nonempty_list("->", var_pat) {(p1,p2)})
")"
b = branches {
(x, y) :: other_arrows, b
let pre_intf = (x, y) :: other_arrows in
let intf = List.map (fun (x, y) ->
(x, List.fold_right (fun e acc ->
let loc = Cduce_loc.(merge_loc e.loc acc.loc) in
Cduce_loc.mk_loc loc (Arrow (e,acc)))(List.tl y) (List.hd y))
) pre_intf
in
(intf, b)
}
| x = or_pat ":" t = pat args = loption(p = pair(",",
separated_nonempty_list(",", x = pat ":" t = pat { (x, t)})) { snd p})
......@@ -722,13 +731,14 @@ ident_or_let_pat_constr:
branches_:
| b = branch { [ b ] }
| bl = branches_ "|" b = branch { b :: bl }
| b = branch "|" bl = branches_ { b :: bl }
;
%inline branches:
"|"? b = branches_ { List.rev b }
"|"? b = branches_ { b }
;
branch:
%inline branch:
p = or_pat "->" e = multi_expr { (p, e) }
;
......@@ -922,6 +932,7 @@ simple_expr:
| v = IDENT { exp $sloc (Var (ident v)) }
| "`" t = ident_or_keyword { exp $sloc (Atom (ident t)) }
| i = INT { exp $sloc (Integer (Intervals.V.mk i)) }
| f = FLOAT { exp $sloc (Abstract (("float", Obj.repr f))) }
;
with_annot:
......
......@@ -56,6 +56,16 @@ let ncname =
let qname = [%sedlex.regexp? Opt (ncname, ':'), ncname]
let digit = [%sedlex.regexp? '0' .. '9']
let float_exp = [%sedlex.regexp? ('e' | 'E'), Opt ('+' | '-'), Plus digit]
let float_frac = [%sedlex.regexp? '.', Star digit]
let floating_point =
[%sedlex.regexp?
Plus digit, float_frac | Plus digit, Opt float_frac, float_exp]
let illegal lexbuf =
error (L.lexeme_start lexbuf) (L.lexeme_end lexbuf)
(Printf.sprintf "Illegal character : %s" (L.Utf8.lexeme lexbuf))
......@@ -99,86 +109,92 @@ let ident_or_keyword =
in
let hash = Hashtbl.create 17 in
List.iter (fun (a, b) -> Hashtbl.add hash a b) l;
function s -> ( try Hashtbl.find hash s with Not_found -> IDENT s )
function s -> ( try Hashtbl.find hash s with Not_found -> IDENT s)
let rec token lexbuf =
match%sedlex lexbuf with
| Plus xml_blank -> token lexbuf
| qname -> ident_or_keyword (L.Utf8.lexeme lexbuf)
| "_" -> UNDERSCORE
| "#print_type" -> HASH_PRINT_TYPE
| "#dump_value" -> HASH_DUMP_VALUE
| "#ascii" -> HASH_ASCII
| "#latin1" -> HASH_LATIN1
| "#utf8" -> HASH_UTF8
| "#", qname -> HASH_DIRECTIVE (L.Utf8.lexeme lexbuf)
| ncname, ":*" ->
| Plus xml_blank -> token lexbuf
| qname -> ident_or_keyword (L.Utf8.lexeme lexbuf)
| "_" -> UNDERSCORE
| "#print_type" -> HASH_PRINT_TYPE
| "#dump_value" -> HASH_DUMP_VALUE
| "#ascii" -> HASH_ASCII
| "#latin1" -> HASH_LATIN1
| "#utf8" -> HASH_UTF8
| "#", qname -> HASH_DIRECTIVE (L.Utf8.lexeme lexbuf)
| ncname, ":*" ->
let s = L.Utf8.sub_lexeme lexbuf 0 (L.lexeme_length lexbuf - 2) in
ANY_IN_NS s
| ".:*" -> ANY_IN_NS ""
| ".:*" -> ANY_IN_NS ""
| floating_point -> (
let f = L.Utf8.lexeme lexbuf in
try FLOAT (float_of_string f)
with _ ->
error (L.lexeme_start lexbuf) (L.lexeme_end lexbuf)
("invalid floating point constant `" ^ f ^ "`"))
| Plus '0' .. '9' -> INT (L.Utf8.lexeme lexbuf)
| "(" -> LP
| ")" -> RP
| "[" -> LSB
| "]" -> RSB
| "<" -> LT
| ">" -> GT
| "{" -> LCB
| "}" -> RCB
| ":" -> COLON
| "," -> COMMA
| "?" -> QMARK
| "=" -> EQ
| "+" -> PLUS
| "-" -> MINUS
| "@" -> AT
| "|" -> BAR
| "." -> DOT
| "`" -> BQUOTE
| "!" -> BANG
| "\\" -> SETMINUS
| "*" -> STAR
| "&" -> AMP
| "/" -> SLASH
| ";" -> SEMI
| ":=" -> COLEQ
| "->" -> MINUSGT
| "<=" -> LTEQ
| "<<" -> LTLT
| ">>" -> GTGT
| ">=" -> GTEQ
| "!=" -> BANGEQ
| "&&" -> AMPAMP
| "**" -> STARSTAR
| "/@" -> SLASHAT
| "//" -> SLASHSLASH
| "::" -> COLCOL
| ".." -> DOTDOT
| "--" -> MINUSMINUS
| "??" -> QMARKQMARK
| "+?" -> PLUSQMARK
| "*?" -> STARQMARK
| "=?" -> EQQMARK
| "||" -> BARBAR
| ";;" -> SEMISEMI
| '"' | "'" ->
| "(" -> LP
| ")" -> RP
| "[" -> LSB
| "]" -> RSB
| "<" -> LT
| ">" -> GT
| "{" -> LCB
| "}" -> RCB
| ":" -> COLON
| "," -> COMMA
| "?" -> QMARK
| "=" -> EQ
| "+" -> PLUS
| "-" -> MINUS
| "@" -> AT
| "|" -> BAR
| "." -> DOT
| "`" -> BQUOTE
| "!" -> BANG
| "\\" -> SETMINUS
| "*" -> STAR
| "&" -> AMP
| "/" -> SLASH
| ";" -> SEMI
| ":=" -> COLEQ
| "->" -> MINUSGT
| "<=" -> LTEQ
| "<<" -> LTLT
| ">>" -> GTGT
| ">=" -> GTEQ
| "!=" -> BANGEQ
| "&&" -> AMPAMP
| "**" -> STARSTAR
| "/@" -> SLASHAT
| "//" -> SLASHSLASH
| "::" -> COLCOL
| ".." -> DOTDOT
| "--" -> MINUSMINUS
| "??" -> QMARKQMARK
| "+?" -> PLUSQMARK
| "*?" -> STARQMARK
| "=?" -> EQQMARK
| "||" -> BARBAR
| ";;" -> SEMISEMI
| '"' | "'" ->
let double_quote = L.Latin1.lexeme_char lexbuf 0 = '"' in
string (L.lexeme_start lexbuf) double_quote lexbuf;
let s = get_stored_string () in
if double_quote then STRING2 s else STRING1 s
| "(*" ->
| "(*" ->
in_comment := true;
comment (L.lexeme_start lexbuf) lexbuf;
in_comment := false;
token lexbuf
| "/*" ->
| "/*" ->
in_comment := true;
tcomment (L.lexeme_start lexbuf) lexbuf;
in_comment := false;
token lexbuf
| eof -> EOI
| any -> illegal lexbuf
| _ -> assert false
| eof -> EOI
| any -> illegal lexbuf
| _ -> assert false
and comment start lexbuf =
match%sedlex lexbuf with
......@@ -208,7 +224,7 @@ and string start double lexbuf =
let d = L.Latin1.lexeme_char lexbuf 0 = '"' in
if d != double then (
store_lexeme lexbuf;
string start double lexbuf )
string start double lexbuf)
| '\\', Chars "\\\"\'" ->
store_ascii (L.Latin1.lexeme_char lexbuf 1);
string start double lexbuf
......
......@@ -324,7 +324,7 @@ let rec print ppf v =
(Utf8.get_idx j) (Utf8.get_str s) print q
| Pair { fst = x; snd = y; concat = true } ->
Format.fprintf ppf "<concat:%a;%a>" print x print y
| Abstract ("float", o) -> Format.fprintf ppf "%f" (Obj.magic o : float)
| Abstract ("float", o) -> Format.fprintf ppf "%s" (string_of_float (Obj.magic o : float))
| Abstract ("cdata", o) ->
let s = Utf8.get_str (Obj.magic o : Utf8.t) in
Format.fprintf ppf "'%s'" s
......@@ -823,7 +823,13 @@ let add v1 v2 =
match (v1, v2) with
| Integer x, Integer y -> Integer (Intervals.V.add x y)
| Record r1, Record r2 -> Record (Imap.merge r1 r2)
| _ -> assert false
| Abstract ("float", x), Abstract ("float", y) ->
float (Obj.magic x +. Obj.magic y)
| Integer x, Abstract ("float", y) ->
float (Big_int.float_of_big_int (Intervals.V.get_bigint x) +. Obj.magic y)
| Abstract ("float", x), Integer y ->
float (Obj.magic x +. Big_int.float_of_big_int (Intervals.V.get_bigint y))
| _ -> assert false
let merge v1 v2 =
match (v1, v2) with
......@@ -833,22 +839,51 @@ let merge v1 v2 =
let sub v1 v2 =
match (v1, v2) with
| Integer x, Integer y -> Integer (Intervals.V.sub x y)
| _ -> assert false
| Abstract ("float", x), Abstract ("float", y) ->
float (Obj.magic x -. Obj.magic y)
| Integer x, Abstract ("float", y) ->
float (Big_int.float_of_big_int (Intervals.V.get_bigint x) -. Obj.magic y)
| Abstract ("float", x), Integer y ->
float (Obj.magic x -. Big_int.float_of_big_int (Intervals.V.get_bigint y))
| _ -> assert false
let mul v1 v2 =
match (v1, v2) with
| Integer x, Integer y -> Integer (Intervals.V.mult x y)
| _ -> assert false
| Abstract ("float", x), Abstract ("float", y) ->
float (Obj.magic x *. Obj.magic y)
| Integer x, Abstract ("float", y) ->
float (Big_int.float_of_big_int (Intervals.V.get_bigint x) *. Obj.magic y)
| Abstract ("float", x), Integer y ->
float (Obj.magic x *. Big_int.float_of_big_int (Intervals.V.get_bigint y))
| _ -> assert false
let div v1 v2 =
match (v1, v2) with
| Integer x, Integer y -> Integer (Intervals.V.div x y)
| _ -> assert false
| Abstract ("float", x), Abstract ("float", y) ->
float (Obj.magic x /. Obj.magic y)
| Integer x, Abstract ("float", y) ->
float (Big_int.float_of_big_int (Intervals.V.get_bigint x) /. Obj.magic y)
| Abstract ("float", x), Integer y ->
float (Obj.magic x /. Big_int.float_of_big_int (Intervals.V.get_bigint y))
| _ -> assert false
let modulo v1 v2 =
match (v1, v2) with
| Integer x, Integer y -> Integer (Intervals.V.modulo x y)
| _ -> assert false
| Abstract ("float", x), Abstract ("float", y) ->
float (mod_float (Obj.magic x) (Obj.magic y))
| Integer x, Abstract ("float", y) ->
float
(mod_float
(Big_int.float_of_big_int (Intervals.V.get_bigint x))
(Obj.magic y))
| Abstract ("float", x), Integer y ->
float
(mod_float (Obj.magic x)
(Big_int.float_of_big_int (Intervals.V.get_bigint y)))
| _ -> assert false
let xml v1 v2 v3 = Xml (v1, v2, v3)
......
This diff is collapsed.
......@@ -36,6 +36,8 @@ and texpr' =
| Xml of texpr * texpr * Ns.table option
| RecordLitt of texpr label_map
| String of U.uindex * U.uindex * U.t * texpr
| Abstract of Types.Abstract.V.t
(* Data destructors *)
| Match of texpr * branches
......
......@@ -533,6 +533,7 @@ let rec expr env loc = function
| Abstraction a -> abstraction env loc a
| (Integer _ | Char _ | Atom _ | Const _) as c ->
exp loc Fv.empty (Typed.Cst (const env loc c))
| Abstract v -> exp loc Fv.empty (Typed.Abstract v)
| Pair (e1, e2) ->
let fv1, e1 = expr env loc e1 and fv2, e2 = expr env loc e2 in
exp loc (Fv.cup fv1 fv2) (Typed.Pair (e1, e2))
......@@ -933,6 +934,7 @@ and type_check' loc env e constr precise =
| Var s -> verify loc (find_value s env) constr
| ExtVar (cu, s, t) -> verify loc t constr
| Cst c -> verify loc (Types.constant c) constr
| Abstract ((t,_)) -> verify loc (Types.(abstract (Abstract.atom t))) constr
| String (i, j, s, e) -> type_check_string loc env 0 s i j e constr precise
| Dot (e, l) -> (
let expect_rec = Types.record l (Types.cons constr) in
......
......@@ -2,76 +2,77 @@
open Cduce_core
let longident_parse s =
let open Ocaml_common in
match String.index_opt s '.' with
| None -> Longident.Lident s
| _ -> Parse.longident (Lexing.from_string s)
let open Ocaml_common in
match String.index_opt s '.' with
| None -> Longident.Lident s
| _ -> Parse.longident (Lexing.from_string s)
module Mlstub =
struct
let noloc id = Some id
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk (Mod.ident l))
module Mlstub = struct
let noloc id = Some id
let str_open l =
let open Ocaml_common.Ast_helper in
Str.open_ (Opn.mk (Mod.ident l))
end
module Mltypes =
struct
open Ocaml_common
let get_path_from_mty_alias = function
| Types.Mty_alias p -> p
| _ -> assert false
module Mltypes = struct
open Ocaml_common
let lookup_value li env =
Env.find_value_by_name li env
let get_path_from_mty_alias = function
| Types.Mty_alias p -> p
| _ -> assert false
let lookup_module li env =
let loc = Warnings.{ loc_start= Lexing.dummy_pos;
loc_end= Lexing.dummy_pos;
loc_ghost = true }
in
Env.lookup_module_path ~use:true ~load:true ~loc:loc li env
let load_path =
let once = ref false in
function () ->
if !once then () else begin
once := true;
List.iter Load_path.add_dir (List.rev !Cduce_loc.obj_path);
Load_path.add_dir Config.standard_library
end
let lookup_value li env = Env.find_value_by_name li env
let find_in_path file =
Misc.find_in_path_uncap (Load_path.get_paths()) file
let lookup_module li env =
let loc =
Warnings.
{
loc_start = Lexing.dummy_pos;
loc_end = Lexing.dummy_pos;
loc_ghost = true;
}
in
Env.lookup_module_path ~use:true ~load:true ~loc li env
let load_path =
let once = ref false in
function
| () ->
if !once then ()
else begin
once := true;
List.iter Load_path.add_dir (List.rev !Cduce_loc.obj_path);
Load_path.add_dir Config.standard_library
end
let get_path_from_pdot e =
match e with
Path.Pdot (p, _) -> p
| _ -> assert false
let find_in_path file = Misc.find_in_path_uncap (Load_path.get_paths ()) file
let is_sig_value_val_reg e =
match e with
Types.Sig_value (_, {val_type=_;val_kind=Val_reg; _}, _) -> true
| _ -> false
let get_path_from_pdot e =
match e with Path.Pdot (p, _) -> p | _ -> assert false
let get_id_t_from_sig_value e =
match e with
Types.Sig_value (id, {val_type=t; _}, _) -> (id, t)
| _ -> assert false
let is_sig_value_val_reg e =
match e with
| Types.Sig_value (_, { val_type = _; val_kind = Val_reg; _ }, _) -> true
| _ -> false
let get_sig_type e =
match e with
Types.Sig_type(id, t, rs, _) -> (id, t, rs)
| _ -> assert false
let get_id_t_from_sig_value e =
match e with
| Types.Sig_value (id, { val_type = t; _ }, _) -> (id, t)
| _ -> assert false
let is_sig_value_deprecated e =
match e with
Types.Sig_value (_, { val_attributes ; _ }, _) ->
List.exists (fun att ->
let txt = Parsetree.(att.attr_name.txt) in
txt = "ocaml.deprecated" || txt = "deprecated"
) val_attributes
| _ -> assert false
let get_sig_type e =
match e with
| Types.Sig_type (id, t, rs, _) -> (id, t, rs)
| _ -> assert false
let is_sig_value_deprecated e =
match e with
| Types.Sig_value (_, { val_attributes; _ }, _) ->
List.exists
(fun att ->
let txt = Parsetree.(att.attr_name.txt) in
txt = "ocaml.deprecated" || txt = "deprecated")
val_attributes
| _ -> assert false
end
......@@ -48,7 +48,7 @@
(alias (name runtest)
(deps
(source_tree ../common)
(source_tree ../../common)
(alias integer_bad_div)
(alias integer_bad_mod)
(alias no_ocamliface)
......