From: Chris Hanson Date: Thu, 2 Mar 2017 07:46:38 +0000 (-0800) Subject: Another round of eliminations. X-Git-Tag: mit-scheme-pucked-9.2.12~198^2~4 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d4fb1b561fcd40d8db7e12cb048c406d5da6f71d;p=mit-scheme.git Another round of eliminations. --- diff --git a/src/runtime/error.scm b/src/runtime/error.scm index cf86e8cde..0aad2b939 100644 --- 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")))) - (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) ;;;; Utilities diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 39d76e98f..a9f3c926b 100644 --- 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 6ed347e3e..273384c6c 100644 --- 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") ;;;; Integration Declarations diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index f76abb4ba..acaf8a2de 100644 --- 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 d3b2d8c87..53a0c084e 100644 --- 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 1ee13513e..7aa8ae655 100644 --- 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 6b5ab792b..28b23761d 100644 --- 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 fdea73527..72de48281 100644 --- 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") ;;;; 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 905307c94..d93b95d4a 100644 --- 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))) (define-xml-type comment diff --git a/src/xml/xml.pkg b/src/xml/xml.pkg index 68c9a743a..b2c97ed30 100644 --- 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. - 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