Implement symbol=? for R7RS.

Also fix some symbol procedures that were unsafe.

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e0b33bd4bfe54d2bafcd825ed7bec15c3dbfcff8..8b8aed8efb07eb9327dce6f6b87da68bb0dc9568 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -751,6 +751,7 @@ USA.
          symbol->string
          symbol-hash
          symbol<?
+         symbol=?                      ;R7RS
          symbol>?
          symbol?
          uninterned-symbol?))

diff --git a/src/runtime/symbol.scm b/src/runtime/symbol.scm
index 989a34584abd7765471969378a190c54b97af231..43e31cb69113373b2c046eab2e4e447b5b4bb9e3 100644 (file)
--- a/src/runtime/symbol.scm
+++ b/src/runtime/symbol.scm
@@ -44,6 +44,15 @@ USA.
 (define-guarantee interned-symbol "interned symbol")
 (define-guarantee uninterned-symbol "uninterned symbol")
 
+(define (symbol=? symbol1 symbol2 . symbols)
+  (guarantee symbol? symbol1 'symbol=?)
+  (guarantee symbol? symbol2 'symbol=?)
+  (and (eq? symbol1 symbol2)
+       (every (lambda (symbol)
+               (guarantee symbol? symbol 'symbol=?)
+               (eq? symbol1 symbol))
+             symbols)))
+
 (define (string->uninterned-symbol string #!optional start end)
   ((ucode-primitive system-pair-cons) (ucode-type uninterned-symbol)
                                      (string->utf8 string start end)
@@ -60,8 +69,7 @@ USA.
        (string->utf8 string start end))))
 
 (define (symbol->string symbol)
-  (if (not (symbol? symbol))
-      (error:not-a symbol? symbol 'symbol->string))
+  (guarantee symbol? symbol 'symbol->string)
   (symbol-name symbol))
 
 (define (symbol-name symbol)
@@ -79,13 +87,13 @@ USA.
   ((ucode-primitive find-symbol) (foldcase->utf8 string)))
 
 (define (symbol-hash symbol #!optional modulus)
-  (string-hash (symbol-name symbol) modulus))
+  (string-hash (symbol->string symbol) modulus))
 
 (define (symbol<? x y)
-  (string<? (symbol-name x) (symbol-name y)))
+  (string<? (symbol->string x) (symbol->string y)))
 
 (define (symbol>? x y)
-  (string<? (symbol-name y) (symbol-name x)))
+  (string<? (symbol->string y) (symbol->string x)))
 \f
 (define generate-uninterned-symbol
   (let ((mutex (make-thread-mutex))