diff options
-rw-r--r-- | libguile/eq.c | 11 | ||||
-rw-r--r-- | libguile/hash.c | 9 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 33 |
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) |