# HG changeset patch
# User berghofe
# Date 1303925226 -7200
# Node ID adfa6ad43ab60cc68fc958b67bcbad9521c2c51c
# Parent  2777a27506d0d8a56f5df615e82e240e1be04ea9
Properly treat proof functions with no arguments.

diff -r 2777a27506d0 -r adfa6ad43ab6 src/HOL/SPARK/Tools/spark_vcs.ML
--- a/src/HOL/SPARK/Tools/spark_vcs.ML	Wed Apr 27 13:21:12 2011 +0200
+++ b/src/HOL/SPARK/Tools/spark_vcs.ML	Wed Apr 27 19:27:06 2011 +0200
@@ -440,7 +440,9 @@
       | tm_of (tab, _) (Ident s) =
           (case Symtab.lookup tab s of
              SOME t_ty => t_ty
-           | NONE => error ("Undeclared identifier " ^ s))
+           | NONE => (case lookup_prfx prfx pfuns s of
+               SOME (SOME ([], resty), t) => (t, resty)
+             | _ => error ("Undeclared identifier " ^ s)))
 
       | tm_of _ (Number i) = (HOLogic.mk_number HOLogic.intT i, integerN)
 
@@ -696,8 +698,9 @@
           (fold_expr f g) (fold_opt (fold_expr f g)))))
         (fold_expr f g)) assocs;
 
-val add_expr_pfuns = fold_expr
-  (fn s => if is_pfun s then I else insert (op =) s) (K I);
+fun add_expr_pfuns funs = fold_expr
+  (fn s => if is_pfun s then I else insert (op =) s)
+  (fn s => if is_none (lookup funs s) then I else insert (op =) s);
 
 val add_expr_idents = fold_expr (K I) (insert (op =));
 
@@ -765,14 +768,14 @@
 fun fold_vcs f vcs =
   VCtab.fold (fn (_, (_, _, ps, cs)) => fold f ps #> fold f cs) vcs;
 
-fun pfuns_of_vcs prfx pfuns vcs =
-  fold_vcs (add_expr_pfuns o snd) vcs [] |>
+fun pfuns_of_vcs prfx funs pfuns vcs =
+  fold_vcs (add_expr_pfuns funs o snd) vcs [] |>
   filter (is_none o lookup_prfx prfx pfuns);
 
 fun declare_missing_pfuns thy prfx funs pfuns vcs (tab, ctxt) =
   let
     val (fs, (tys, Ts)) =
-      pfuns_of_vcs prfx pfuns vcs |>
+      pfuns_of_vcs prfx funs pfuns vcs |>
       map_filter (fn s => lookup funs s |>
         Option.map (fn ty => (s, (SOME ty, pfun_type thy prfx ty)))) |>
       split_list ||> split_list;
@@ -963,15 +966,16 @@
   (map (fn ((s, i), _) => s ^ "(" ^ string_of_int i ^ ")") rules);
 
 (* sort definitions according to their dependency *)
-fun sort_defs _ _ _ [] sdefs = rev sdefs
-  | sort_defs prfx pfuns consts defs sdefs =
+fun sort_defs _ _ _ _ [] sdefs = rev sdefs
+  | sort_defs prfx funs pfuns consts defs sdefs =
       (case find_first (fn (_, (_, e)) =>
-         forall (is_some o lookup_prfx prfx pfuns) (add_expr_pfuns e []) andalso
+         forall (is_some o lookup_prfx prfx pfuns)
+           (add_expr_pfuns funs e []) andalso
          forall (fn id =>
            member (fn (s, (_, (s', _))) => s = s') sdefs id orelse
            consts id)
              (add_expr_idents e [])) defs of
-         SOME d => sort_defs prfx pfuns consts
+         SOME d => sort_defs prfx funs pfuns consts
            (remove (op =) d defs) (d :: sdefs)
        | NONE => error ("Bad definitions: " ^ rulenames defs));
 
@@ -993,7 +997,7 @@
         (filter_out (is_trivial_vc o snd) vcs)) vcs);
 
     val _ = (case filter_out (is_some o lookup funs)
-        (pfuns_of_vcs prfx pfuns vcs') of
+        (pfuns_of_vcs prfx funs pfuns vcs') of
         [] => ()
       | fs => error ("Undeclared proof function(s) " ^ commas fs));
 
@@ -1007,7 +1011,7 @@
       fold (snd oo add_const prfx) consts' |> (fn ids_thy as ((tab, _), _) =>
         ids_thy |>
         fold_map (add_def prfx types pfuns consts)
-          (sort_defs prfx pfuns (Symtab.defined tab) defs []) ||>>
+          (sort_defs prfx funs pfuns (Symtab.defined tab) defs []) ||>>
         fold_map (add_var prfx) (items vars) ||>>
         add_init_vars prfx vcs');