From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 8 Mar 2003 02:40:14 +0000 (+0000)
Subject: Use angle notation for type descriptor.
X-Git-Tag: 20090517-FFI~1976
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=de62c9157bbce528d50b2b5405c05202e7c80e7d;p=mit-scheme.git

Use angle notation for type descriptor.
---

diff --git a/v7/src/edwin/abbrev.scm b/v7/src/edwin/abbrev.scm
index 3f7cca910..1465f0139 100644
--- a/v7/src/edwin/abbrev.scm
+++ b/v7/src/edwin/abbrev.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: abbrev.scm,v 1.9 2003/02/14 18:28:10 cph Exp $
+$Id: abbrev.scm,v 1.10 2003/03/08 02:38:57 cph Exp $
 
-Copyright 2000-2001 Massachusetts Institute of Technology
+Copyright 2000,2001,2003 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -32,35 +32,31 @@ USA.
 (define make-abbrev-table make-string-hash-table)
 (define abbrev-table? hash-table?)
 
-(define-structure (abbrev-entry (type-descriptor abbrev-entry-rtd))
+(define-structure (abbrev-entry (type-descriptor <abbrev-entry>))
   (expansion #f read-only #t)
   (hook #f read-only #t)
   (count 0))
 
+(define (guarantee-abbrev-table object caller)
+  (if (not (abbrev-table? object))
+      (error:wrong-type-argument object "abbrev table" caller)))
+
 (define (clear-abbrev-table table)
   (set! abbrevs-changed? #t)
   (hash-table/clear! table))
 
 (define (define-abbrev table abbrev expansion #!optional hook count)
-  (if (not (abbrev-table? table))
-      (error:wrong-type-argument table "abbrev table" 'DEFINE-ABBREV))
-  (if (not (string? abbrev))
-      (error:wrong-type-argument abbrev "string" 'DEFINE-ABBREV))
-  (if (not (string? expansion))
-      (error:wrong-type-argument expansion "string" 'DEFINE-ABBREV))
-  (if (not (or (default-object? hook) (not hook) (symbol? hook)))
-      (error:wrong-type-argument hook "symbol" 'DEFINE-ABBREV))
-  (if (not (or (default-object? count) (exact-nonnegative-integer? count)))
-      (error:wrong-type-argument count
-				 "exact non-negative integer"
-				 'DEFINE-ABBREV))
-  (set! abbrevs-changed? #t)
-  (hash-table/put! table
-		   (string-downcase abbrev)
-		   (make-abbrev-entry
-		    expansion
-		    (if (default-object? hook) #f hook)
-		    (if (default-object? count) 0 count))))
+  (let ((hook (if (default-object? hook) #f hook))
+	(count (if (default-object? count) 0 count)))
+    (guarantee-abbrev-table table 'DEFINE-ABBREV)
+    (guarantee-string abbrev 'DEFINE-ABBREV)
+    (guarantee-string expansion 'DEFINE-ABBREV)
+    (if hook (guarantee-symbol hook 'DEFINE-ABBREV))
+    (guarantee-exact-nonnegative-integer count 'DEFINE-ABBREV)
+    (set! abbrevs-changed? #t)
+    (hash-table/put! table
+		     (string-downcase abbrev)
+		     (make-abbrev-entry expansion hook count))))
 
 (define (define-global-abbrev abbrev expansion)
   (define-abbrev (ref-variable global-abbrev-table #f) abbrev expansion))
@@ -72,10 +68,8 @@ USA.
     (define-abbrev table abbrev expansion)))
 
 (define (undefine-abbrev table abbrev)
-  (if (not (abbrev-table? table))
-      (error:wrong-type-argument table "abbrev table" 'UNDEFINE-ABBREV))
-  (if (not (string? abbrev))
-      (error:wrong-type-argument abbrev "string" 'UNDEFINE-ABBREV))
+  (guarantee-abbrev-table table 'UNDEFINE-ABBREV)
+  (guarantee-string abbrev 'UNDEFINE-ABBREV)
   (set! abbrevs-changed? #t)
   (hash-table/remove! table (string-downcase abbrev)))
 
diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index da8528fa2..35d24e71e 100644
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: imail-core.scm,v 1.150 2003/03/07 05:49:18 cph Exp $
+$Id: imail-core.scm,v 1.151 2003/03/08 02:40:14 cph Exp $
 
 Copyright 1999,2000,2001,2003 Massachusetts Institute of Technology
 
@@ -719,7 +719,7 @@ USA.
 ;;;; Folder orders
 
 (define-structure (folder-order
-		   (type-descriptor folder-order-rtd)
+		   (type-descriptor <folder-order>)
 		   (constructor make-folder-order (predicate)))
   (predicate #f read-only #t)
   (forward #f)
@@ -879,7 +879,7 @@ USA.
 ;;;; Header fields
 
 (define-structure (header-field
-		   (type-descriptor header-field-rtd)
+		   (type-descriptor <header-field>)
 		   (safe-accessors #t)
 		   (constructor #f)
 		   (print-procedure
@@ -891,7 +891,7 @@ USA.
   (value #f read-only #t))
 
 (define make-header-field
-  (let ((constructor (record-constructor header-field-rtd)))
+  (let ((constructor (record-constructor <header-field>)))
     (lambda (name value)
       (guarantee-header-field-name name 'MAKE-HEADER-FIELD)
       (constructor name value))))