summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/srcprop.c63
-rw-r--r--test-suite/tests/srcprop.test42
2 files changed, 104 insertions, 1 deletions
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index a43f4ce67..c182702ac 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 8ec298960..17d8ae2d9 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))