Merge remote-tracking branch 'local-2.0/stable-2.0'

Conflicts:
	libguile/read.c
	libguile/srcprop.c
	module/ice-9/psyntax-pp.scm

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):
 
@@ -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.
 
+@deffn {Scheme Procedure} supports-source-properties? obj
+@deffnx {C Function} scm_supports_source_properties_p (obj)
+Return #t if source properties can be associated with @var{obj},
+otherwise return #f.
+@end 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.

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_unlocked (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);

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
@@ -91,6 +92,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)
 {
@@ -157,21 +166,33 @@ 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}.")
 #define FUNC_NAME s_scm_source_properties
 {
-  SCM p;
-  SCM_VALIDATE_NIM (1, obj);
-
-  p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL); 
-
-  if (SRCPROPSP (p))
-    return scm_srcprops_to_alist (p);
+  if (SCM_IMP (obj))
+    return SCM_EOL;
   else
-    /* list from set-source-properties!, or SCM_EOL for not found */
-    return p;
+    {
+      SCM p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL); 
+
+      if (SRCPROPSP (p))
+        return scm_srcprops_to_alist (p);
+      else
+        /* list from set-source-properties!, or SCM_EOL for not found */
+        return p;
+    }
 }
 #undef FUNC_NAME
 
@@ -195,13 +216,10 @@ int
 scm_i_has_source_properties (SCM obj)
 #define FUNC_NAME "%set-source-properties"
 {
-  int ret;
-  
-  SCM_VALIDATE_NIM (1, obj);
-
-  ret = scm_is_true (scm_weak_table_refq (scm_source_whash, obj, SCM_BOOL_F));
-
-  return ret;
+  if (SCM_IMP (obj))
+    return 0;
+  else
+    return scm_is_true (scm_weak_table_refq (scm_source_whash, obj, SCM_BOOL_F));
 }
 #undef FUNC_NAME
   
@@ -228,18 +246,20 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
 #define FUNC_NAME s_scm_source_property
 {
   SCM p;
-  SCM_VALIDATE_NIM (1, obj);
+
+  if (SCM_IMP (obj))
+    return SCM_BOOL_F;
 
   p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
 
   if (!SRCPROPSP (p))
     goto alist;
   if (scm_is_eq (scm_sym_line, key))
-    p = scm_from_int (SRCPROPLINE (p));
+    return scm_from_int (SRCPROPLINE (p));
   else if (scm_is_eq (scm_sym_column, key))
-    p = scm_from_int (SRCPROPCOL (p));
+    return scm_from_int (SRCPROPCOL (p));
   else if (scm_is_eq (scm_sym_copy, key))
-    p = SRCPROPCOPY (p);
+    return SRCPROPCOPY (p);
   else
     {
       p = SRCPROPALIST (p);
@@ -247,7 +267,6 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
       p = scm_assoc (key, p);
       return (scm_is_pair (p) ? SCM_CDR (p) : SCM_BOOL_F);
     }
-  return SCM_UNBNDP (p) ? SCM_BOOL_F : p;
 }
 #undef FUNC_NAME
 

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

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)
 
@@ -463,14 +463,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))

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? "#2u32@2@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!