Syntax objects are comparable with equal?

* libguile/eq.c (scm_equal_p, scm_raw_ihash): Add cases for syntax
  objects, which should be comparable with equal?.
* test-suite/tests/syntax.test ("syntax objects"): Add tests.

3 files changed, 53 insertions, 0 deletions

diff --git a/libguile/eq.c b/libguile/eq.c
index bbb061655..4680de7d8 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -33,6 +33,7 @@
 #include "libguile/vectors.h"
 #include "libguile/hashtab.h"
 #include "libguile/bytevectors.h"
+#include "libguile/syntax.h"
 
 #include "libguile/struct.h"
 #include "libguile/goops.h"
@@ -362,6 +363,16 @@ scm_equal_p (SCM x, SCM y)
     case scm_tc7_vector:
     case scm_tc7_wvect:
       return scm_i_vector_equal_p (x, y);
+    case scm_tc7_syntax:
+      if (scm_is_false (scm_equal_p (scm_syntax_wrap (x),
+                                     scm_syntax_wrap (y))))
+        return SCM_BOOL_F;
+      if (scm_is_false (scm_equal_p (scm_syntax_module (x),
+                                     scm_syntax_module (y))))
+        return SCM_BOOL_F;
+      x = scm_syntax_expression (x);
+      y = scm_syntax_expression (y);
+      goto tailrecurse;
     }
 
   /* Otherwise just return false. Dispatching to the generic is the wrong thing
diff --git a/libguile/hash.c b/libguile/hash.c
index d6ddb6b3b..604708438 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -35,6 +35,7 @@
 #include "libguile/ports.h"
 #include "libguile/strings.h"
 #include "libguile/symbols.h"
+#include "libguile/syntax.h"
 #include "libguile/vectors.h"
 
 #include "libguile/validate.h"
@@ -333,6 +334,14 @@ scm_raw_ihash (SCM obj, size_t depth)
             h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
         return h;
       }
+    case scm_tc7_syntax:
+      {
+        unsigned long h;
+        h = scm_raw_ihash (scm_syntax_expression (obj), depth);
+        h ^= scm_raw_ihash (scm_syntax_wrap (obj), depth);
+        h ^= scm_raw_ihash (scm_syntax_module (obj), depth);
+        return h;
+      }
     case scm_tcs_cons_imcar: 
     case scm_tcs_cons_nimcar:
       if (depth)
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index ffe8099b1..883004a27 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -20,6 +20,7 @@
 (define-module (test-suite test-syntax)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 local-eval)
+  #:use-module ((system syntax) #:select (syntax?))
   #:use-module (test-suite lib))
 
 
@@ -1617,6 +1618,38 @@
                       (length #'(x …))))
                   env))))
 
+(with-test-prefix "syntax objects"
+  (let ((interpreted (eval '#'(foo bar baz) (current-module)))
+        (interpreted-bis (eval '#'(foo bar baz) (current-module)))
+        (compiled ((@ (system base compile) compile) '#'(foo bar baz)
+                   #:env (current-module))))
+    ;; Guile's expander doesn't wrap lists.
+    (pass-if "interpreted syntax object?"
+      (and (list? interpreted)
+           (and-map syntax? interpreted)))
+    (pass-if "compiled syntax object?"
+      (and (list? compiled)
+           (and-map syntax? compiled)))
+
+    (pass-if "interpreted syntax objects are not vectors"
+      (not (vector? interpreted)))
+    (pass-if "compiled syntax objects are not vectors"
+      (not (vector? compiled)))
+
+    (pass-if-equal "syntax objects comparable with equal? (eval/eval)"
+        interpreted interpreted-bis)
+    (pass-if-equal "syntax objects comparable with equal? (eval/compile)"
+        interpreted compiled)
+
+    (pass-if-equal "syntax objects hash the same (eval/eval)"
+        (hash interpreted most-positive-fixnum)
+      (hash interpreted-bis most-positive-fixnum))
+
+    (pass-if-equal "syntax objects hash the same (eval/compile)"
+        (hash interpreted most-positive-fixnum)
+      (hash compiled most-positive-fixnum))))
+
+
 ;;; Local Variables:
 ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
 ;;; eval: (put 'with-ellipsis 'scheme-indent-function 1)