From 087ea609510e7c85e1048219f4aa96348d1eaeda Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Thu, 26 Sep 2013 14:40:33 +0100
Subject: [PATCH] Implement goalloc.
---
goaljobs-reference.pod | 15 +++++++++++++++
pa_goal.ml | 9 ++++++++-
2 files changed, 23 insertions(+), 1 deletion(-)
diff --git a/goaljobs-reference.pod b/goaljobs-reference.pod
index 393e4b5..2ca27c7 100644
--- a/goaljobs-reference.pod
+++ b/goaljobs-reference.pod
@@ -193,6 +193,21 @@ would print:
my name is foo
+=head2 goalloc
+
+Inside goals, you can use C<goalloc> to get a printable source
+location of the goal, ie:
+
+ let goal foo () =
+ printf "%s\n" goalloc
+
+would print:
+
+ File "source.ml", line 2, characters 13-71 (end at line 3, character 23)
+
+Note that the actual string format depends on the internal OCaml
+function C<Loc.to_string> so it might change in future.
+
=head2 onfail, onsuccess, onrun
Inside goals you can register function(s) which run if the goal
diff --git a/pa_goal.ml b/pa_goal.ml
index e795233..13ea23c 100644
--- a/pa_goal.ml
+++ b/pa_goal.ml
@@ -68,6 +68,9 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
(* Rename the function to goal_<name>. *)
let gname = "goal_" ^ name in
+ (* Convert loc to string for goalloc. *)
+ let goalloc = Loc.to_string _loc in
+
(* Split the function into parameters and body. *)
let params, body = function_parameters expr in
@@ -87,6 +90,10 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
let body = <:expr<
(* Define a goal name which the body may use. *)
let goalname = $str:name$ in
+
+ (* Source location. *)
+ let goalloc = $str:goalloc$ in
+
(* Define onsuccess, onrun, onfail functions that the body may call. *)
let _on, _call_on =
let _on fns f = fns := f :: !fns in
@@ -109,7 +116,7 @@ let generate_let_goal _loc (r : rec_flag) (lets : binding) =
_call_onsuccesses ();
(* Avoid a compiler warning: *)
- ignore (goalname)
+ ignore (goalname); ignore (goalloc)
with
(* target() within the body may raise Goal_OK meaning that the
* goal should be short-circuited. We return as if it's an
--
1.8.3.1