Implement GUARANTEE- procedures for symbols.

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index d3ad735be668592938f23737a2a96f4ab698effc..5182343011d29fae950a6c924cb2dcf4c4d17986 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.434 2003/03/07 21:23:46 cph Exp $
+$Id: runtime.pkg,v 14.435 2003/03/08 02:26:01 cph Exp $
 
 Copyright (c) 1988,1989,1990,1991,1992 Massachusetts Institute of Technology
 Copyright (c) 1993,1994,1995,1996,1997 Massachusetts Institute of Technology
@@ -449,6 +449,9 @@ USA.
   (files "symbol")
   (parent (runtime))
   (export ()
+         guarantee-interned-symbol
+         guarantee-symbol
+         guarantee-uninterned-symbol
          intern
          intern-soft
          interned-symbol?

diff --git a/v7/src/runtime/symbol.scm b/v7/src/runtime/symbol.scm
index 78aa099851483861e1043a8433f13425b09c3574..0ab4991448f8f52d0869538bd78135190f4c68c6 100644 (file)
--- a/v7/src/runtime/symbol.scm
+++ b/v7/src/runtime/symbol.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: symbol.scm,v 1.9 2003/02/14 18:28:34 cph Exp $
+$Id: symbol.scm,v 1.10 2003/03/08 02:25:19 cph Exp $
 
-Copyright (c) 1992-2001 Massachusetts Institute of Technology
+Copyright 1992,1993,2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -38,9 +38,20 @@ USA.
 (define-integrable (uninterned-symbol? object)
   (object-type? (ucode-type uninterned-symbol) object))
 
+(define-integrable (guarantee-symbol object caller)
+  (if (not (symbol? object))
+      (error:wrong-type-argument object "symbol" caller)))
+
+(define-integrable (guarantee-interned-symbol object caller)
+  (if (not (interned-symbol? object))
+      (error:wrong-type-argument object "interned symbol" caller)))
+
+(define-integrable (guarantee-uninterned-symbol object caller)
+  (if (not (uninterned-symbol? object))
+      (error:wrong-type-argument object "uninterned symbol" caller)))
+
 (define (string->uninterned-symbol string)
-  (if (not (string? string))
-      (error:wrong-type-argument string "string" 'STRING->UNINTERNED-SYMBOL))
+  (guarantee-string string 'STRING->UNINTERNED-SYMBOL)
   ((ucode-primitive system-pair-cons) (ucode-type uninterned-symbol)
                                      string
                                      (make-unmapped-unbound-reference-trap)))
@@ -64,8 +75,7 @@ USA.
        (string-downcase string))))
 
 (define (symbol-name symbol)
-  (if (not (symbol? symbol))
-      (error:wrong-type-argument symbol "symbol" 'SYMBOL-NAME))
+  (guarantee-symbol symbol 'SYMBOL-NAME)
   (system-pair-car symbol))
 
 (define-integrable (symbol->string symbol)