From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 25 Jun 1997 03:51:58 +0000 (+0000)
Subject: Error-check arguments to MAKE-CLASS.  Make sure that dispatch tag of
X-Git-Tag: 20090517-FFI~5110
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f4a2907d21ef887ab8797f28031edf9ed1315ba8;p=mit-scheme.git

Error-check arguments to MAKE-CLASS.  Make sure that dispatch tag of
record-type class is correct.
---

diff --git a/v7/src/sos/class.scm b/v7/src/sos/class.scm
index 58de0efb1..4ac2ad136 100644
--- a/v7/src/sos/class.scm
+++ b/v7/src/sos/class.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: class.scm,v 1.6 1997/06/25 03:44:50 cph Exp $
+;;; $Id: class.scm,v 1.7 1997/06/25 03:51:58 cph Exp $
 ;;;
 ;;; Copyright (c) 1995-97 Massachusetts Institute of Technology
 ;;;
@@ -56,6 +56,13 @@
   dispatch-tag)
 
 (define (make-class name direct-superclasses direct-slots)
+  (if (not (and (list? direct-superclasses)
+		(for-all? direct-superclasse sclass?)))
+      (error:wrong-type-argument direct-superclasses
+				 "list of classes"
+				 'MAKE-CLASS))
+  (if (not (list? direct-slots))
+      (error:wrong-type-argument direct-slots "list" 'MAKE-CLASS))
   (let ((class
 	 (%make-class name
 		      (if (null? direct-superclasses)
@@ -344,9 +351,13 @@
 	  (else <object>))))
 
 (define (make-record-type-class type)
-  (make-class (string->symbol (string-append "<" (record-type-name type) ">"))
-	      (list <record>)
-	      (record-type-field-names type)))
+  (let ((class
+	 (make-class (string->symbol
+		      (string-append "<" (record-type-name type) ">"))
+		     (list <record>)
+		     (record-type-field-names type))))
+    (set-class/dispatch-tag! class (record-type-dispatch-tag type))
+    class))
 
 (define built-in-class-table
   (make-eq-hash-table))