mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

Fix set-source-properties so that the special source properties work

Browse source 
* 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.
This commit is contained in:
Neil Jerram 2009-08-04 18:57:18 +01:00
parent 67a967348a
commit 1b872adf2e
2 changed files with 104 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

63
libguile/srcprop.c
View file

@ -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;

40
test-suite/tests/srcprop.test
View file

@ -35,12 +35,52 @@
(pass-if "read properties"
(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"