From bcc4242438744e9357fff90da249e6b5fe99bb6b Mon Sep 17 00:00:00 2001
From: Neil Jerram <neil@ossau.uklinux.net>
Date: Tue, 4 Aug 2009 18:57:18 +0100
Subject: [PATCH] Fix set-source-properties so that the special source properties work

* libguile/srcprop.c (scm_set_source_properties_x): Look for the special
  source properties, save them off, and then construct a srcprops object
  using them.
---
 libguile/srcprop.c            |   63 +++++++++++++++++++++++++++++++++++++++++
 test-suite/tests/srcprop.test |   42 ++++++++++++++++++++++++++-
 2 files changed, 104 insertions(+), 1 deletions(-)

diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index a43f4ce..c182702 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -208,11 +208,74 @@ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0,
 #define FUNC_NAME s_scm_set_source_properties_x
 {
   SCM handle;
+  long line = 0, col = 0;
+  SCM fname = SCM_UNDEFINED, copy = SCM_UNDEFINED, breakpoint = SCM_BOOL_F;
+  SCM others = SCM_EOL;
+  SCM *others_cdrloc = &others;
+  int need_srcprops = 0;
+  SCM tail, key;
+
   SCM_VALIDATE_NIM (1, obj);
   if (SCM_MEMOIZEDP (obj))
     obj = SCM_MEMOIZED_EXP (obj);
   else if (!scm_is_pair (obj))
     SCM_WRONG_TYPE_ARG(1, obj);
+
+  tail = alist;
+  while (!scm_is_null (tail))
+    {
+      key = SCM_CAAR (tail);
+      if (scm_is_eq (key, scm_sym_line))
+	{
+	  line = scm_to_long (SCM_CDAR (tail));
+	  need_srcprops = 1;
+	}
+      else if (scm_is_eq (key, scm_sym_column))
+	{
+	  col = scm_to_long (SCM_CDAR (tail));
+	  need_srcprops = 1;
+	}
+      else if (scm_is_eq (key, scm_sym_filename))
+	{
+	  fname = SCM_CDAR (tail);
+	  need_srcprops = 1;
+	}
+      else if (scm_is_eq (key, scm_sym_copy))
+	{
+	  copy = SCM_CDAR (tail);
+	  need_srcprops = 1;
+	}
+      else if (scm_is_eq (key, scm_sym_breakpoint))
+	{
+	  breakpoint = SCM_CDAR (tail);
+	  need_srcprops = 1;
+	}
+      else
+	{
+	  /* Do we allocate here, or clobber the caller's alist?
+
+	     Source properties aren't supposed to be used for anything
+	     except the special properties above, so the mainline case
+	     is that we never execute this else branch, and hence it
+	     doesn't matter much.
+
+	     We choose allocation here, as that seems safer.
+	  */
+	  *others_cdrloc = scm_cons (scm_cons (key, SCM_CDAR (tail)),
+				     SCM_EOL);
+	  others_cdrloc = SCM_CDRLOC (*others_cdrloc);
+	}
+      tail = SCM_CDR (tail);
+    }
+  if (need_srcprops)
+    {
+      alist = scm_make_srcprops (line, col, fname, copy, others);
+      if (scm_is_true (breakpoint))
+	SETSRCPROPBRK (alist);
+    }
+  else
+    alist = others;
+
   handle = scm_hashq_create_handle_x (scm_source_whash, obj, alist);
   SCM_SETCDR (handle, alist);
   return alist;
diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test
index 8ec2989..17d8ae2 100644
--- a/test-suite/tests/srcprop.test
+++ b/test-suite/tests/srcprop.test
@@ -36,11 +36,51 @@
       (not (null? (source-properties s))))))
 
 ;;;
+;;; set-source-property!
+;;;
+
+(with-test-prefix "set-source-property!"
+  (read-enable 'positions)
+
+  (pass-if "setting the breakpoint property works"
+    (let ((s (read (open-input-string "(+ 3 4)"))))
+      (set-source-property! s 'breakpoint #t)
+      (let ((current-trap-opts (evaluator-traps-interface))
+	    (current-debug-opts (debug-options-interface))
+	    (trap-called #f))
+	(trap-set! enter-frame-handler (lambda _ (set! trap-called #t)))
+	(trap-enable 'traps)
+	(debug-enable 'debug)
+	(debug-enable 'breakpoints)
+	(with-traps (lambda ()
+		      (primitive-eval s)))
+	(evaluator-traps-interface current-trap-opts)
+	(debug-options-interface current-debug-opts)
+	trap-called))))
+
+;;;
 ;;; set-source-properties!
 ;;;
 
 (with-test-prefix "set-source-properties!"
   (read-enable 'positions)
+
+  (pass-if "setting the breakpoint property works"
+    (let ((s (read (open-input-string "(+ 3 4)"))))
+      (set-source-properties! s '((breakpoint #t)))
+      (let ((current-trap-opts (evaluator-traps-interface))
+	    (current-debug-opts (debug-options-interface))
+	    (trap-called #f))
+	(trap-set! enter-frame-handler (lambda _ (set! trap-called #t)))
+	(trap-enable 'traps)
+	(debug-enable 'debug)
+	(debug-enable 'breakpoints)
+	(with-traps (lambda ()
+		      (primitive-eval s)))
+	(evaluator-traps-interface current-trap-opts)
+	(debug-options-interface current-debug-opts)
+	trap-called)))
+
   (let ((s (read (open-input-string "(1 . 2)"))))
     
     (with-test-prefix "copied props"
@@ -48,7 +88,7 @@
 	(let ((t (cons 3 4)))
 	  (set-source-properties! t (source-properties s))
 	  (number? (source-property t 'line))))
-      
+
       (pass-if "visible to source-properties"
 	(let ((t (cons 3 4)))
 	  (set-source-properties! t (source-properties s))
-- 
1.5.6.5