Another round of eliminations.

diff --git a/src/runtime/error.scm b/src/runtime/error.scm
index cf86e8cde6ae63d622b9e966fa053d128d0161b6..0aad2b93928d1044e436c31f3b57a127d640a2a1 100644 (file)
--- a/src/runtime/error.scm
+++ b/src/runtime/error.scm
@@ -726,7 +726,6 @@ USA.
 (define condition-type:invalid-floating-point-operation)
 (define condition-type:macro-binding)
 (define condition-type:no-such-restart)
-(define condition-type:not-8-bit-char)
 (define condition-type:port-error)
 (define condition-type:serious-condition)
 (define condition-type:simple-condition)
@@ -754,7 +753,6 @@ USA.
 (define error:derived-thread)
 (define error:illegal-pathname-component)
 (define error:macro-binding)
-(define error:not-8-bit-char)
 (define error:unassigned-variable)
 (define error:unbound-variable)
 (define error:wrong-number-of-arguments)
@@ -1175,13 +1173,6 @@ USA.
              '()
            (arithmetic-error-report "Floating-point underflow"))))
 \f
-  (set! condition-type:not-8-bit-char
-       (make-condition-type 'NOT-8-BIT-CHAR condition-type:error '(CHAR)
-         (lambda (condition port)
-           (write-string "Character too large for 8-bit string: " port)
-           (write (access-condition condition 'CHAR) port)
-           (newline port))))
-
   (set! make-simple-error
        (condition-constructor condition-type:simple-error
                               '(MESSAGE IRRITANTS)))
@@ -1233,10 +1224,6 @@ USA.
        (condition-signaller condition-type:macro-binding
                             '(ENVIRONMENT LOCATION)
                             standard-error-handler))
-  (set! error:not-8-bit-char
-       (condition-signaller condition-type:not-8-bit-char
-                            '(CHAR)
-                            standard-error-handler))
   unspecific)
 \f
 ;;;; Utilities

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 39d76e98f3edd5745c12aa8dbf0b5df87371caa0..a9f3c926b2e519f35314ea9345b14245abfbf997 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1970,7 +1970,6 @@ USA.
          condition-type:invalid-floating-point-operation
          condition-type:macro-binding
          condition-type:no-such-restart
-         condition-type:not-8-bit-char
          condition-type:port-error
          condition-type:serious-condition
          condition-type:simple-condition
@@ -2009,7 +2008,6 @@ USA.
          error:file-operation
          error:illegal-pathname-component
          error:no-such-restart
-         error:not-8-bit-char
          error:wrong-number-of-arguments
          error:wrong-type-argument
          error:wrong-type-datum

diff --git a/src/sf/pardec.scm b/src/sf/pardec.scm
index 6ed347e3e3d8fa54dda5de5c296a4201a737efe7..273384c6c49840a77d3e9e64d308d56136f78189 100644 (file)
--- a/src/sf/pardec.scm
+++ b/src/sf/pardec.scm
@@ -73,7 +73,9 @@ USA.
                   ((LOCAL)     operations/bind)
                   ((TOP-LEVEL) operations/bind-top-level)
                   ((GLOBAL)    operations/bind-global)
-                  (else (error "Unrecognized binding level" (declaration/binding-level declaration))))
+                  (else
+                   (error "Unrecognized binding level"
+                          (declaration/binding-level declaration))))
                 operations
                 (declaration/operation declaration)
                 (declaration/variable declaration)
@@ -166,8 +168,6 @@ USA.
 (define (known-declaration? operation)
   (or (eq? operation 'EXPAND) ; this one is special
       (assq operation known-declarations)))
-
-(define-guarantee known-declaration "known declaration")
 \f
 ;;;; Integration Declarations
 

diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index f76abb4ba21538244e0cd6512d9c98e03782ce75..acaf8a2dea69bd40455d82311af90f5f16bf7564 100644 (file)
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -123,7 +123,7 @@ USA.
           declarations/map
           declarations/original
           declarations/parse
-          guarantee-known-declaration
+          known-declaration?
           operations->external))
 
 (define-package (scode-optimizer copy)

diff --git a/src/sf/tables.scm b/src/sf/tables.scm
index d3b2d8c87af32beb21235c0553e2a934a1a3cb13..53a0c084eea656c9a59e82d246f5f88a7343f201 100644 (file)
--- a/src/sf/tables.scm
+++ b/src/sf/tables.scm
@@ -226,7 +226,7 @@ USA.
          (vector-ref operations 2)))
 
 (define (operations/bind operations operation variable value)
-  (guarantee-known-declaration operation 'operations/bind)
+  (guarantee known-declaration? operation 'operations/bind)
   (guarantee-variable variable 'operations/bind)
   (vector (cons (cons* variable operation value)
                (vector-ref operations 0))
@@ -234,7 +234,7 @@ USA.
          (vector-ref operations 2)))
 
 (define (operations/bind-top-level operations operation variable value)
-  (guarantee-known-declaration operation 'operations/bind-top-level)
+  (guarantee known-declaration? operation 'operations/bind-top-level)
   (guarantee-variable variable 'operations/bind-top-level)
   (vector (vector-ref operations 0)
          (cons (cons* variable operation value)
@@ -242,7 +242,7 @@ USA.
          (vector-ref operations 2)))
 
 (define (operations/bind-global operations operation variable value)
-  (guarantee-known-declaration operation 'operations/bind-global)
+  (guarantee known-declaration? operation 'operations/bind-global)
   (guarantee-variable variable 'operations/bind-global)
   (vector (vector-ref operations 0)
          (vector-ref operations 1)

diff --git a/src/star-parser/parser.pkg b/src/star-parser/parser.pkg
index 1ee13513e1c0a52f14eea80294244ee840abc920..7aa8ae655ff435670d6af161eb27a27ebe7e2c7d 100644 (file)
--- a/src/star-parser/parser.pkg
+++ b/src/star-parser/parser.pkg
@@ -40,7 +40,6 @@ USA.
          define-*parser-expander
          define-*parser-macro
          global-parser-macros
-         guarantee-parser-macros
          make-parser-macros
          parser-macros?
          set-current-parser-macros!

diff --git a/src/star-parser/shared.scm b/src/star-parser/shared.scm
index 6b5ab792bae00038400fdbcc3cc4330741ed4844..28b23761dcfe95cf2584fce8100a37e2052a7db0 100644 (file)
--- a/src/star-parser/shared.scm
+++ b/src/star-parser/shared.scm
@@ -156,7 +156,7 @@ USA.
   (parser-table parser-macros-table))
 
 (define (make-parser-macros parent)
-  (if parent (guarantee-parser-macros parent 'MAKE-PARSER-MACROS))
+  (if parent (guarantee parser-macros? parent 'MAKE-PARSER-MACROS))
   (%make-parser-macros (or parent *global-parser-macros*)
                       (make-strong-eq-hash-table)
                       (make-strong-eq-hash-table)))
@@ -166,10 +166,6 @@ USA.
                       (make-strong-eq-hash-table)
                       (make-strong-eq-hash-table)))
 
-(define (guarantee-parser-macros object procedure)
-  (if (not (parser-macros? object))
-      (error:wrong-type-argument object "parser macros" procedure)))
-
 (define (define-matcher-macro name expander)
   (hash-table/put! (matcher-macros-table *parser-macros*) name expander))
 
@@ -189,7 +185,7 @@ USA.
             (loop (parent-macros environment))))))
 
 (define (with-current-parser-macros macros thunk)
-  (guarantee-parser-macros macros 'WITH-CURRENT-PARSER-MACROS)
+  (guarantee parser-macros? macros 'WITH-CURRENT-PARSER-MACROS)
   (fluid-let ((*parser-macros* macros))
     (thunk)))
 
@@ -197,7 +193,7 @@ USA.
   *parser-macros*)
 
 (define (set-current-parser-macros! macros)
-  (guarantee-parser-macros macros 'SET-CURRENT-PARSER-MACROS!)
+  (guarantee parser-macros? macros 'SET-CURRENT-PARSER-MACROS!)
   (set! *parser-macros* macros)
   unspecific)
 

diff --git a/src/xml/xml-names.scm b/src/xml/xml-names.scm
index fdea7352715e1ab9b2b495260d0de449aa3f6ef8..72de482815d706d21b3ac22e70d6fc0b41083833 100644 (file)
--- a/src/xml/xml-names.scm
+++ b/src/xml/xml-names.scm
@@ -36,7 +36,7 @@ USA.
           name-symbol)
          (else
           (let ((uri (->absolute-uri uri 'MAKE-XML-NAME)))
-            (guarantee-xml-qname name-symbol 'MAKE-XML-NAME)
+            (guarantee xml-qname? name-symbol 'MAKE-XML-NAME)
             (if (not (case (xml-qname-prefix name-symbol)
                        ((xml) (uri=? uri xml-uri))
                        ((xmlns) (uri=? uri xmlns-uri))
@@ -70,15 +70,13 @@ USA.
   (or (xml-name-symbol? object)
       (combo-name? object)))
 
-(define-guarantee xml-name "an XML Name")
-
 (define (xml-name-string name)
   (symbol->string (xml-name->symbol name)))
 
 (define (xml-name->symbol name)
   (cond ((xml-name-symbol? name) name)
        ((combo-name? name) (combo-name-qname name))
-       (else (error:not-xml-name name 'XML-NAME->SYMBOL))))
+       (else (error:not-a xml-name? name 'XML-NAME->SYMBOL))))
 
 (define (xml-name=? n1 n2)
   (if (and (combo-name? n1) (combo-name? n2))
@@ -166,10 +164,6 @@ USA.
 (define xml-name-symbol? (name-predicate string-is-xml-name?))
 (define xml-nmtoken? (name-predicate string-is-xml-nmtoken?))
 (define xml-qname? (name-predicate string-is-xml-qname?))
-
-(define-guarantee xml-name-symbol "an XML name symbol")
-(define-guarantee xml-nmtoken "an XML name token")
-(define-guarantee xml-qname "an XML QName")
 \f
 ;;;; Namespace support
 
@@ -177,13 +171,10 @@ USA.
   (or (xml-qname? object)
       (combo-name? object)))
 
-(define-guarantee xml-namespace-conformant-name
-  "XML Namespaces conformant name")
-
 (define (xml-name-uri name)
   (cond ((xml-qname? name) (null-xml-namespace-uri))
        ((combo-name? name) (expanded-name-uri (combo-name-expanded name)))
-       (else (error:not-xml-namespace-conformant-name name 'XML-NAME-URI))))
+       (else (error:not-a xml-namespace-conformant-name? name 'XML-NAME-URI))))
 
 (define (xml-name-uri=? name uri)
   (uri=? (xml-name-uri name) uri))
@@ -193,7 +184,7 @@ USA.
    (cond ((xml-qname? name) name)
         ((combo-name? name) (combo-name-qname name))
         (else
-         (error:not-xml-namespace-conformant-name name 'XML-NAME-PREFIX)))))
+         (error:not-a xml-namespace-conformant-name? name 'XML-NAME-PREFIX)))))
 
 (define (null-xml-name-prefix? object)
   (eq? object '||))
@@ -207,7 +198,8 @@ USA.
 (define (xml-name-local name)
   (cond ((xml-qname? name) (%xml-qname-local name))
        ((combo-name? name) (expanded-name-local (combo-name-expanded name)))
-       (else (error:not-xml-namespace-conformant-name name 'XML-NAME-LOCAL))))
+       (else
+        (error:not-a xml-namespace-conformant-name? name 'XML-NAME-LOCAL))))
 
 (define (xml-name-local=? name local)
   (eq? (xml-name-local name) local))
@@ -226,7 +218,7 @@ USA.
 (define xmlns-uri (->uri xmlns-uri-string))
 
 (define (xml-qname-prefix qname)
-  (guarantee-xml-qname qname 'XML-QNAME-PREFIX)
+  (guarantee xml-qname? qname 'XML-QNAME-PREFIX)
   (%xml-qname-prefix qname))
 
 (define (%xml-qname-prefix qname)
@@ -237,7 +229,7 @@ USA.
          (null-xml-name-prefix)))))
 
 (define (xml-qname-local qname)
-  (guarantee-xml-qname qname 'XML-QNAME-LOCAL)
+  (guarantee xml-qname? qname 'XML-QNAME-LOCAL)
   (%xml-qname-local qname))
 
 (define (%xml-qname-local qname)

diff --git a/src/xml/xml-struct.scm b/src/xml/xml-struct.scm
index 905307c9440b39002164d1bdde71e6af888b142f..d93b95d4a7e63369030cff44d990d284380f05bd 100644 (file)
--- a/src/xml/xml-struct.scm
+++ b/src/xml/xml-struct.scm
@@ -66,17 +66,6 @@ USA.
                    (MAKE-RECORD-TYPE ',root '(,@(map car slots))))
                  (DEFINE ,predicate
                    (RECORD-PREDICATE ,rtd))
-                 (DEFINE (,(symbol 'GUARANTEE- root) OBJECT CALLER)
-                   (IF (NOT ,predicate)
-                       (,error:not OBJECT CALLER)))
-                 (DEFINE (,error:not OBJECT CALLER)
-                   (ERROR:WRONG-TYPE-ARGUMENT
-                    OBJECT
-                    ,(string-append "an XML "
-                                    (string-replace (symbol->string (cadr form))
-                                                    #\-
-                                                    #\space))
-                    CALLER))
                  (DEFINE ,%constructor
                    (RECORD-CONSTRUCTOR ,rtd '(,@(map car slots))))
                  (DEFINE (,constructor ,@slot-vars)
@@ -198,8 +187,6 @@ USA.
                  (loop (cdr attrs)))
             #t))))
 
-(define-guarantee xml-attribute-list "XML attribute list")
-
 (define (xml-content? object)
   (list-of-type? object xml-content-item?))
 
@@ -268,7 +255,7 @@ USA.
               (if (xml-element? elt)
                   (xml-element-attributes elt)
                   (begin
-                    (guarantee-xml-attribute-list elt 'FIND-XML-ATTR)
+                    (guarantee xml-attribute-list? elt 'FIND-XML-ATTR)
                     elt)))))
     (if (and (not attr) (if (default-object? error?) #f error?))
        (error:bad-range-argument name 'FIND-XML-ATTR))
@@ -279,7 +266,7 @@ USA.
   (if (string? arg)
       (make-xml-name arg)
       (begin
-       (guarantee-xml-name arg caller)
+       (guarantee xml-name? arg caller)
        arg)))
 \f
 (define-xml-type comment

diff --git a/src/xml/xml.pkg b/src/xml/xml.pkg
index 68c9a743aabe3df5f2b7a546bfe9b647cc0b00f0..b2c97ed3097e0a5562cff8e369b4a11c8f2e76a4 100644 (file)
--- a/src/xml/xml.pkg
+++ b/src/xml/xml.pkg
@@ -51,16 +51,6 @@ USA.
   (files "xml-names")
   (parent (runtime xml))
   (export ()
-         error:not-xml-name
-         error:not-xml-name-symbol
-         error:not-xml-namespace-conformant-name
-         error:not-xml-nmtoken
-         error:not-xml-qname
-         guarantee-xml-name
-         guarantee-xml-name-symbol
-         guarantee-xml-namespace-conformant-name
-         guarantee-xml-nmtoken
-         guarantee-xml-qname
          make-xml-name
          make-xml-name-symbol
          make-xml-nmtoken
@@ -121,42 +111,8 @@ USA.
          <xml-parameter-entity-ref>
          <xml-processing-instructions>
          <xml-unparsed-!entity>
-         error:not-xml-!attlist
-         error:not-xml-!element
-         error:not-xml-!entity
-         error:not-xml-!notation
-         error:not-xml-attribute
-         error:not-xml-attribute-list
-         error:not-xml-comment
-         error:not-xml-declaration
-         error:not-xml-document
-         error:not-xml-dtd
-         error:not-xml-element
-         error:not-xml-entity-ref
-         error:not-xml-external-id
-         error:not-xml-parameter-!entity
-         error:not-xml-parameter-entity-ref
-         error:not-xml-processing-instructions
-         error:not-xml-unparsed-!entity
          find-xml-attr
          flatten-xml-element-content
-         guarantee-xml-!attlist
-         guarantee-xml-!element
-         guarantee-xml-!entity
-         guarantee-xml-!notation
-         guarantee-xml-attribute
-         guarantee-xml-attribute-list
-         guarantee-xml-comment
-         guarantee-xml-declaration
-         guarantee-xml-document
-         guarantee-xml-dtd
-         guarantee-xml-element
-         guarantee-xml-entity-ref
-         guarantee-xml-external-id
-         guarantee-xml-parameter-!entity
-         guarantee-xml-parameter-entity-ref
-         guarantee-xml-processing-instructions
-         guarantee-xml-unparsed-!entity
          make-xml-!attlist
          make-xml-!element
          make-xml-!entity
@@ -326,10 +282,6 @@ USA.
          (html-document html-1.0-document)
          (html-dtd html-1.0-dtd)
          (html-external-id html-1.0-external-id)
-         error:not-html-element
-         error:not-html-element-name
-         guarantee-html-element
-         guarantee-html-element-name
          html-1.0-document
          html-1.0-dtd
          html-1.0-external-id
@@ -559,29 +511,9 @@ USA.
          canonicalize-rdf-subject
          canonicalize-rdf-uri
          copy-rdf-prefix-registry
-         error:not-rdf-bnode
-         error:not-rdf-graph
-         error:not-rdf-literal
-         error:not-rdf-object
-         error:not-rdf-predicate
-         error:not-rdf-prefix
-         error:not-rdf-prefix-registry
-         error:not-rdf-qname
-         error:not-rdf-subject
-         error:not-rdf-triple
          event:new-rdf-graph
          event:new-rdf-triple
          for-each-rdf-triple
-         guarantee-rdf-bnode
-         guarantee-rdf-graph
-         guarantee-rdf-literal
-         guarantee-rdf-object
-         guarantee-rdf-predicate
-         guarantee-rdf-prefix
-         guarantee-rdf-prefix-registry
-         guarantee-rdf-qname
-         guarantee-rdf-subject
-         guarantee-rdf-triple
          make-rdf-bnode
          make-rdf-graph
          make-rdf-literal