diff options
Diffstat (limited to 'parsing/g_zsyntaxnew.ml')
| -rw-r--r-- | parsing/g_zsyntaxnew.ml | 168 |
1 files changed, 168 insertions, 0 deletions
diff --git a/parsing/g_zsyntaxnew.ml b/parsing/g_zsyntaxnew.ml new file mode 100644 index 000000000..24b6d4137 --- /dev/null +++ b/parsing/g_zsyntaxnew.ml @@ -0,0 +1,168 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id$ *) + +open Coqast +open Pcoq +open Pp +open Util +open Names +open Ast +open Extend +open Topconstr +open Libnames +open Bignat + +(**********************************************************************) +(* Parsing positive via scopes *) +(**********************************************************************) + +open Libnames +open Rawterm +let make_dir l = make_dirpath (List.map id_of_string (List.rev l)) +let fast_integer_module = make_dir ["Coq";"ZArith";"fast_integer"] + +(* TODO: temporary hack *) +let make_path dir id = Libnames.encode_kn dir id + +let positive_path = make_path fast_integer_module (id_of_string "positive") +let path_of_xI = ((positive_path,0),1) +let path_of_xO = ((positive_path,0),2) +let path_of_xH = ((positive_path,0),3) +let glob_xI = ConstructRef path_of_xI +let glob_xO = ConstructRef path_of_xO +let glob_xH = ConstructRef path_of_xH + +let pos_of_bignat dloc x = + let ref_xI = RRef (dloc, glob_xI) in + let ref_xH = RRef (dloc, glob_xH) in + let ref_xO = RRef (dloc, glob_xO) in + let rec pos_of x = + match div2_with_rest x with + | (q,false) -> RApp (dloc, ref_xO,[pos_of q]) + | (q,true) when is_nonzero q -> RApp (dloc,ref_xI,[pos_of q]) + | (q,true) -> ref_xH + in + pos_of x + +let interp_positive dloc = function + | POS n when is_nonzero n -> pos_of_bignat dloc n + | _ -> + user_err_loc (dloc, "interp_positive", + str "Only strictly positive numbers in type \"positive\"!") + +let rec pat_pos_of_bignat dloc x name = + match div2_with_rest x with + | (q,false) -> + PatCstr (dloc,path_of_xO,[pat_pos_of_bignat dloc q Anonymous],name) + | (q,true) when is_nonzero q -> + PatCstr (dloc,path_of_xI,[pat_pos_of_bignat dloc q Anonymous],name) + | (q,true) -> + PatCstr (dloc,path_of_xH,[],name) + +let pat_interp_positive dloc = function + | POS n -> pat_pos_of_bignat dloc n + | NEG n -> + user_err_loc (dloc, "interp_positive", + str "No negative number in type \"positive\"!") + +(**********************************************************************) +(* Printing positive via scopes *) +(**********************************************************************) + +exception Non_closed_number + +let rec bignat_of_pos = function + | RApp (_, RRef (_,b),[a]) when b = glob_xO -> mult_2(bignat_of_pos a) + | RApp (_, RRef (_,b),[a]) when b = glob_xI -> add_1(mult_2(bignat_of_pos a)) + | RRef (_, a) when a = glob_xH -> Bignat.one + | _ -> raise Non_closed_number + +let uninterp_positive p = + try + Some (POS (bignat_of_pos p)) + with Non_closed_number -> + None + +(***********************************************************************) +(* Declaring interpreters and uninterpreters for positive *) +(***********************************************************************) + +let _ = Symbols.declare_numeral_interpreter "positive_scope" + ["Coq";"ZArith";"Zsyntax"] + (interp_positive,Some pat_interp_positive) + ([RRef (dummy_loc, glob_xI); + RRef (dummy_loc, glob_xO); + RRef (dummy_loc, glob_xH)], + uninterp_positive, + None) + +(**********************************************************************) +(* Parsing Z via scopes *) +(**********************************************************************) + +let z_path = make_path fast_integer_module (id_of_string "Z") +let glob_z = IndRef (z_path,0) +let path_of_ZERO = ((z_path,0),1) +let path_of_POS = ((z_path,0),2) +let path_of_NEG = ((z_path,0),3) +let glob_ZERO = ConstructRef path_of_ZERO +let glob_POS = ConstructRef path_of_POS +let glob_NEG = ConstructRef path_of_NEG + +let z_of_posint dloc pos_or_neg n = + if is_nonzero n then + let sgn = if pos_or_neg then glob_POS else glob_NEG in + RApp(dloc, RRef (dloc,sgn), [pos_of_bignat dloc n]) + else + RRef (dloc, glob_ZERO) + +let z_of_int dloc z = + match z with + | POS n -> z_of_posint dloc true n + | NEG n -> z_of_posint dloc false n + +let pat_z_of_posint dloc pos_or_neg n name = + if is_nonzero n then + let sgn = if pos_or_neg then path_of_POS else path_of_NEG in + PatCstr (dloc, sgn, [pat_pos_of_bignat dloc n Anonymous], name) + else + PatCstr (dloc, path_of_ZERO, [], name) + +let pat_z_of_int dloc n name = + match n with + | POS n -> pat_z_of_posint dloc true n name + | NEG n -> pat_z_of_posint dloc false n name + +(**********************************************************************) +(* Printing Z via scopes *) +(**********************************************************************) + +let bigint_of_z = function + | RApp (_, RRef (_,b),[a]) when b = glob_POS -> POS (bignat_of_pos a) + | RApp (_, RRef (_,b),[a]) when b = glob_NEG -> NEG (bignat_of_pos a) + | RRef (_, a) when a = glob_ZERO -> POS (Bignat.zero) + | _ -> raise Non_closed_number + +let uninterp_z p = + try + Some (bigint_of_z p) + with Non_closed_number -> None + +(***********************************************************************) +(* Declaring interpreters and uninterpreters for Z *) + +let _ = Symbols.declare_numeral_interpreter "Z_scope" + ["Coq";"ZArith";"Zsyntax"] + (z_of_int,Some pat_z_of_int) + ([RRef (dummy_loc, glob_ZERO); + RRef (dummy_loc, glob_POS); + RRef (dummy_loc, glob_NEG)], + uninterp_z, + None) |