[PATCH] Improve support for source properties

[Mark H Weaver]

Hello all,

Here's another patch set to improve support for source properties.
In brief:

* 'read' now sets source properties on non-immediate numbers: bignums,
  floats, fractions, complex.

* add the 'supports-source-properties?' predicate (as well as
  scm_supports_source_properties_p), which cannot be implemented
  efficiently in Scheme.

* relax validation checking of source property getters so that they may
  be applied to _any_ object.  Previously, attempts to get source
  properties of immediate objects would throw an error.

* psyntax now accesses and sets source properties for all supported
  objects.  Previously it assumed that only pairs could support source
  properties.

* add tests to verify that 'read' sets source properties appropriately.

For ease of reading, the first patch shows only non-whitespace changes,
since the bodies of three functions changed indentation level.

I very nearly pushed this, but wanted to make sure there were no
objections to adding 'supports-source-properties?', or to relaxing the
validation of source property getters.

What do you think?  Okay to push?

   Thanks,
     Mark


>From fb3a112122b6406e88adbff2299aacc5230cc8ec Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Tue, 14 Feb 2012 01:54:15 -0500
Subject: [PATCH 1/5] Relax validation of source property accessors

* libguile/srcprop.c (scm_source_properties, scm_source_property,
  scm_i_has_source_properties): Relax validation to allow _any_ object
  to be queried for source properties.
---
 libguile/srcprop.c |   88 +++++++++++++++++++++++++++++----------------------
 1 files changed, 50 insertions(+), 38 deletions(-)

diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index dc333d4..c43acdf 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008, 2009, 
2010, 2011 Free Software Foundation
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2006,
+ *   2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -164,8 +164,11 @@
            "Return the source property association list of @var{obj}.")
 #define FUNC_NAME s_scm_source_properties
 {
+  if (SCM_IMP (obj))
+    return SCM_EOL;
+  else
+    {
   SCM p;
-  SCM_VALIDATE_NIM (1, obj);
 
   scm_i_pthread_mutex_lock (&source_lock);
   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); 
@@ -176,6 +179,7 @@
   else
     /* list from set-source-properties!, or SCM_EOL for not found */
     return p;
+    }
 }
 #undef FUNC_NAME
 
@@ -201,15 +201,18 @@
 scm_i_has_source_properties (SCM obj)
 #define FUNC_NAME "%set-source-properties"
 {
+  if (SCM_IMP (obj))
+    return 0;
+  else
+    {
   int ret;
   
-  SCM_VALIDATE_NIM (1, obj);
-
   scm_i_pthread_mutex_lock (&source_lock);
   ret = scm_is_true (scm_hashq_ref (scm_source_whash, obj, SCM_BOOL_F));
   scm_i_pthread_mutex_unlock (&source_lock);
 
   return ret;
+    }
 }
 #undef FUNC_NAME
   
@@ -237,8 +237,11 @@
            "@var{obj}'s source property list.")
 #define FUNC_NAME s_scm_source_property
 {
+  if (SCM_IMP (obj))
+    return SCM_BOOL_F;
+  else
+    {
   SCM p;
-  SCM_VALIDATE_NIM (1, obj);
 
   scm_i_pthread_mutex_lock (&source_lock);
   p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL);
@@ -260,6 +263,7 @@
       return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F);
     }
   return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
+    }
 }
 #undef FUNC_NAME
 
-- 
1.7.5.4

>From 76b9bac565182dd7d0ffe416c3382ac7d59d93ab Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Tue, 14 Feb 2012 02:14:10 -0500
Subject: [PATCH 2/5] Add 'supports-source-properties?' predicate

* libguile/srcprop.c (scm_supports_source_properties_p): New procedure.
  (supports_source_props): New static C function.

* libguile/srcprop.h (scm_supports_source_properties_p): Add prototype.

* doc/ref/api-debug.texi (Source Properties): Add documentation.
---
 doc/ref/api-debug.texi |    6 ++++++
 libguile/srcprop.c     |   18 ++++++++++++++++++
 libguile/srcprop.h     |    4 +++-
 3 files changed, 27 insertions(+), 1 deletions(-)

diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index c5fbe56..18371f0 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -258,6 +258,12 @@ ERROR: Unbound variable: xxx
 In the latter case, no source properties were stored, so the error
 doesn't have any source information.
 
address@hidden {Scheme Procedure} supports-source-properties? obj
address@hidden {C Function} scm_supports_source_properties_p (obj)
+Return #t if source properties can be associated with @var{obj},
+otherwise return #f.
address@hidden deffn
+
 The recording of source properties is controlled by the read option
 named ``positions'' (@pxref{Scheme Read}).  This option is switched
 @emph{on} by default.
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index c43acdf..c632bb0 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -94,6 +94,14 @@ static SCM scm_srcprops_to_alist (SCM obj);
 
 scm_t_bits scm_tc16_srcprops;
 
+
+static int
+supports_source_props (SCM obj)
+{
+  return SCM_NIMP (obj) && !scm_is_symbol (obj) && !scm_is_keyword (obj);
+}
+
+
 static int
 srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
 {
@@ -160,6 +168,16 @@ scm_srcprops_to_alist (SCM obj)
   return alist;
 }
 
+SCM_DEFINE (scm_supports_source_properties_p, "supports-source-properties?", 
1, 0, 0,
+            (SCM obj),
+            "Return #t if @var{obj} supports adding source properties,\n"
+            "otherwise return #f.")
+#define FUNC_NAME s_scm_supports_source_properties_p
+{
+  return scm_from_bool (supports_source_props (obj));
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, 
             (SCM obj),
            "Return the source property association list of @var{obj}.")
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index 250756d..0252e54 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -3,7 +3,8 @@
 #ifndef SCM_SRCPROP_H
 #define SCM_SRCPROP_H
 
-/* Copyright (C) 1995,1996,2000,2001, 2006, 2008, 2009, 2010, 2011 Free 
Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008, 2009, 2010,
+ *   2011, 2012 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -41,6 +42,7 @@ SCM_API SCM scm_sym_column;
 
 
 
+SCM_API SCM scm_supports_source_properties_p (SCM obj);
 SCM_API SCM scm_make_srcprops (long line, int col, SCM fname, SCM copy, SCM 
plist);
 SCM_API SCM scm_source_property (SCM obj, SCM key);
 SCM_API SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum);
-- 
1.7.5.4

>From 32fbc38fbb3c7544a45f7be3cf0a981a31681cbb Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Tue, 14 Feb 2012 23:22:51 -0500
Subject: [PATCH 3/5] psyntax: access source properties for all supported
 objects

* module/ice-9/psyntax.scm (decorate-source): Set source properties on
  any object that satisfies 'supports-source-properties?'.  Previously
  we used 'pair?' as the predicate.

  (source-annotation): Apply 'source-properties' to _any_ kind of source
  expression, where previously only pairs were queried.  If the argument
  is a syntax-object, apply the source-properties to the syntax-object's
  expression.

  In the peculiar case of a syntax-object whose expression is also a
  syntax-object: previously we would iterate, but with this commit we
  now call 'syntax-object-expression' only once.

* module/ice-9/psyntax-pp.scm: Regenerate.
---
 module/ice-9/psyntax-pp.scm |12795 ++++++++++++++++++++++---------------------
 module/ice-9/psyntax.scm    |   15 +-
 2 files changed, 6438 insertions(+), 6372 deletions(-)

diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 729ae6e..4290069 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -301,7 +301,7 @@
 
 
     (define (decorate-source e s)
-      (if (and (pair? e) s)
+      (if (and s (supports-source-properties? e))
           (set-source-properties! e s))
       e)
 
@@ -461,14 +461,11 @@
 
     (define source-annotation
       (lambda (x)
-        (cond
-         ((syntax-object? x)
-          (source-annotation (syntax-object-expression x)))
-         ((pair? x) (let ((props (source-properties x)))
-                      (if (pair? props)
-                          props
-                          #f)))
-         (else #f))))
+        (let ((props (source-properties
+                      (if (syntax-object? x)
+                          (syntax-object-expression x)
+                          x))))
+          (and (pair? props) props))))
 
     (define-syntax-rule (arg-check pred? e who)
       (let ((x e))
-- 
1.7.5.4

>From 38f190749da57150b5329676b6fd70ff73d66e02 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Wed, 15 Feb 2012 11:47:31 -0500
Subject: [PATCH 4/5] Add support for source properties on non-immediate
 numbers

* libguile/read.c (scm_read_number): Set source properties on
  non-immediate numbers if the 'positions' reader option is set.

* doc/ref/api-debug.texi (Source Properties): Update manual.
---
 doc/ref/api-debug.texi |    4 ++--
 libguile/read.c        |    8 +++++++-
 2 files changed, 9 insertions(+), 3 deletions(-)

diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi
index 18371f0..dd2a3d1 100644
--- a/doc/ref/api-debug.texi
+++ b/doc/ref/api-debug.texi
@@ -239,8 +239,8 @@ Guile's debugger can point back to the file and location 
where the
 expression originated.
 
 The way that source properties are stored means that Guile cannot
-associate source properties with individual numbers, symbols,
-characters, booleans, or keywords.  This can be seen by typing
+associate source properties with individual symbols, keywords,
+characters, booleans, or small integers.  This can be seen by typing
 @code{(xxx)} and @code{xxx} at the Guile prompt (where the variable
 @code{xxx} has not been defined):
 
diff --git a/libguile/read.c b/libguile/read.c
index 4b19750..bbaf3f6 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -600,6 +600,10 @@ scm_read_number (scm_t_wchar chr, SCM port)
   int overflow;
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 
+  /* Need to capture line and column numbers here. */
+  long line = SCM_LINUM (port);
+  int column = SCM_COL (port) - 1;
+
   scm_ungetc (chr, port);
   overflow = read_complete_token (port, buffer, sizeof (buffer),
                                   &overflow_buffer, &bytes_read);
@@ -611,13 +615,15 @@ scm_read_number (scm_t_wchar chr, SCM port)
                             pt->ilseq_handler);
 
   result = scm_string_to_number (str, SCM_UNDEFINED);
-  if (!scm_is_true (result))
+  if (scm_is_false (result))
     {
       /* Return a symbol instead of a number */
       if (SCM_CASE_INSENSITIVE_P)
         str = scm_string_downcase_x (str);
       result = scm_string_to_symbol (str);
     }
+  else if (SCM_NIMP (result))
+    result = maybe_annotate_source (result, port, line, column);
 
   if (overflow)
     free (overflow_buffer);
-- 
1.7.5.4

>From cac24946da089e1e1fddf9c9dc7ae7dae9e29014 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Wed, 15 Feb 2012 12:23:12 -0500
Subject: [PATCH 5/5] Add tests to verify that 'read' sets source properties
 when appropriate

* test-suite/tests/srcprop.test (source properties): Add tests.
---
 test-suite/tests/srcprop.test |   48 +++++++++++++++++++++++++++++++++++-----
 1 files changed, 42 insertions(+), 6 deletions(-)

diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test
index 0ca11b3..4afc318 100644
--- a/test-suite/tests/srcprop.test
+++ b/test-suite/tests/srcprop.test
@@ -25,15 +25,51 @@
 ;;;
 
 (with-test-prefix "source-properties"
-  
+
   (pass-if "no props"
     (null? (source-properties (list 1 2 3))))
-  
+
   (read-enable 'positions)
-  (let ((s (read (open-input-string "(1 . 2)"))))
-    
-    (pass-if "read properties"
-      (not (null? (source-properties s))))))
+  (with-test-prefix "read properties"
+    (define (reads-with-srcprops? str)
+      (let ((x (read (open-input-string str))))
+        (not (null? (source-properties x)))))
+
+    (pass-if "pairs"           (reads-with-srcprops? "(1 . 2)"))
+    (pass-if "vectors"         (reads-with-srcprops? "#(1 2 3)"))
+    (pass-if "bytevectors"     (reads-with-srcprops? "#vu8(1 2 3)"))
+    (pass-if "bitvectors"      (reads-with-srcprops? "#*101011"))
+    (pass-if "srfi4 vectors"   (reads-with-srcprops? "#f64(3.1415 2.71)"))
+    (pass-if "arrays"          (reads-with-srcprops? "address@hidden@3((1 2) 
(2 3))"))
+    (pass-if "strings"         (reads-with-srcprops? "\"hello\""))
+    (pass-if "null string"     (reads-with-srcprops? "\"\""))
+
+    (pass-if "floats"          (reads-with-srcprops? "3.1415"))
+    (pass-if "fractions"       (reads-with-srcprops? "1/2"))
+    (pass-if "complex numbers" (reads-with-srcprops? "1+1i"))
+    (pass-if "bignums"
+      (and (reads-with-srcprops? (number->string (1+ most-positive-fixnum)))
+           (reads-with-srcprops? (number->string (1- most-negative-fixnum)))))
+
+    (pass-if "fixnums (should have none)"
+      (not (or (reads-with-srcprops? "0")
+               (reads-with-srcprops? "1")
+               (reads-with-srcprops? "-1")
+               (reads-with-srcprops? (number->string most-positive-fixnum))
+               (reads-with-srcprops? (number->string most-negative-fixnum)))))
+
+    (pass-if "symbols (should have none)"
+      (not (reads-with-srcprops? "foo")))
+
+    (pass-if "keywords (should have none)"
+      (not (reads-with-srcprops? "#:foo")))
+
+    (pass-if "characters (should have none)"
+      (not (reads-with-srcprops? "#\\c")))
+
+    (pass-if "booleans (should have none)"
+      (not (or (reads-with-srcprops? "#t")
+               (reads-with-srcprops? "#f"))))))
 
 ;;;
 ;;; set-source-property!
-- 
1.7.5.4