diff -r 25eaa3660123 -r 0cff73279f34 src/Pure/sign.ML --- a/src/Pure/sign.ML Tue May 16 21:33:05 2006 +0200 +++ b/src/Pure/sign.ML Tue May 16 21:33:07 2006 +0200 @@ -23,8 +23,6 @@ val del_modesyntax_i: (string * bool) -> (bstring * typ * mixfix) list -> theory -> theory val add_consts: (bstring * string * mixfix) list -> theory -> theory val add_consts_i: (bstring * typ * mixfix) list -> theory -> theory - val add_abbrevs: string * bool -> (bstring * string * mixfix) list -> theory -> theory - val add_abbrevs_i: string * bool -> (bstring * term * mixfix) list -> theory -> theory val add_const_constraint: xstring * string option -> theory -> theory val add_const_constraint_i: string * typ option -> theory -> theory val primitive_class: string * class list -> theory -> theory @@ -193,6 +191,9 @@ val simple_read_term: theory -> typ -> string -> term val read_term: theory -> string -> term val read_prop: theory -> string -> term + val add_const_syntax: string * bool -> (string * mixfix) list -> theory -> theory + val add_consts_authentic: (bstring * typ * mixfix) list -> theory -> theory + val add_abbrevs: string * bool -> (bstring * term * mixfix) list -> theory -> theory include SIGN_THEORY end @@ -710,41 +711,47 @@ val del_modesyntax = gen_syntax Syntax.remove_const_gram (read_typ_syntax o no_def_sort); val del_modesyntax_i = gen_syntax Syntax.remove_const_gram certify_typ_syntax; +fun add_const_syntax prmode args thy = + thy |> add_modesyntax_i prmode (map (Consts.syntax (consts_of thy)) args); + (* add constants *) local -fun gen_add_consts prep_typ raw_args thy = +fun gen_add_consts prep_typ early raw_args thy = let val prepT = Compress.typ thy o Type.varifyT o Type.no_tvars o Term.no_dummyT o prep_typ thy; - fun prep (c, T, mx) = ((c, prepT T, mx) handle TYPE (msg, _, _) => error msg) - handle ERROR msg => - cat_error msg ("in declaration of constant " ^ quote (Syntax.const_name c mx)); + fun prep (raw_c, raw_T, raw_mx) = + let + val (c, mx) = Syntax.const_mixfix raw_c raw_mx; + val (c', b) = if early then (c, true) else Syntax.mixfix_const (full_name thy c) mx; + val T = (prepT raw_T handle TYPE (msg, _, _) => error msg) handle ERROR msg => + cat_error msg ("in declaration of constant " ^ quote c); + in (((c, T), b), (c', T, mx)) end; val args = map prep raw_args; - val decls = args |> map (fn (c, T, mx) => ((Syntax.const_name c mx, T), true)); in thy - |> map_consts (fold (Consts.declare (naming_of thy)) decls) - |> add_syntax_i args + |> map_consts (fold (Consts.declare (naming_of thy) o #1) args) + |> map_syn (Syntax.extend_consts (map (#1 o #1 o #1) args)) + |> add_syntax_i (map #2 args) end; in -val add_consts = gen_add_consts (read_typ o no_def_sort); -val add_consts_i = gen_add_consts certify_typ; +val add_consts = gen_add_consts (read_typ o no_def_sort) true; +val add_consts_i = gen_add_consts certify_typ true; +val add_consts_authentic = gen_add_consts certify_typ false; end; (* add abbreviations *) -local - -fun gen_abbrevs prep_term (mode, inout) = fold (fn (raw_c, raw_t, raw_mx) => fn thy => +fun add_abbrevs (mode, inout) = fold (fn (raw_c, raw_t, raw_mx) => fn thy => let - val prep_tm = - Compress.term thy o Logic.varify o no_vars (pp thy) o Term.no_dummy_patterns o prep_term thy; + val prep_tm = Compress.term thy o Logic.varify o no_vars (pp thy) o + Term.no_dummy_patterns o cert_term_abbrev thy; val (c, mx) = Syntax.const_mixfix raw_c raw_mx; val (c', b) = Syntax.mixfix_const (full_name thy c) mx; @@ -758,13 +765,6 @@ |> add_modesyntax_i (mode, inout) [(c', T, mx)] end); -in - -val add_abbrevs = gen_abbrevs read_term; -val add_abbrevs_i = gen_abbrevs cert_term_abbrev; - -end; - (* add constraints *)