Add new procedures to signal wrong type and bad range errors.

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index 31dc45dd7e2cb64633a8e424bb7c6276516e0c51..188860082d5b82cfd7e43421c0a66db1f026466d 100644 (file)
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.16 1990/07/20 01:12:03 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.17 1990/09/11 21:58:52 cph Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -196,7 +196,7 @@ MIT in each case. |#
    (->environment to)
    (->environment from)
    name))
-\f
+
 (define-integrable (object-non-pointer? object)
   (zero? (object-gc-type object)))
 
@@ -218,7 +218,7 @@ MIT in each case. |#
        (error "FASDUMP: Object is too large to be dumped" object))
     (write-string " -- done" port))
   object)
-
+\f
 (define (undefined-value? object)
   ;; Note: the unparser takes advantage of the fact that objects
   ;; satisfying this predicate also satisfy:
@@ -234,8 +234,6 @@ MIT in each case. |#
 
 (define unspecific
   (object-new-type (ucode-type true) 1))
-\f
-;;;; Obarray->list
 
 (define (obarray->list #!optional obarray)
   (let ((table (if (default-object? obarray)
@@ -251,4 +249,20 @@ MIT in each case. |#
                (per-bucket (-1+ index) accumulator)
                (per-symbol
                 (cdr bucket)
-                (cons (car bucket) accumulator))))))))
\ No newline at end of file
+                (cons (car bucket) accumulator))))))))
+
+(define (error:illegal-datum object #!optional operator-name)
+  (if (default-object? operator-name)
+      (error error-type:wrong-type-argument object)
+      (error error-type:wrong-type-argument object
+            (error-irritant/noise char:newline)
+            (error-irritant/noise "within procedure")
+            operator-name)))
+
+(define (error:datum-out-of-range object #!optional operator-name)
+  (if (default-object? operator-name)
+      (error error-type:bad-range-argument object)
+      (error error-type:bad-range-argument object
+            (error-irritant/noise char:newline)
+            (error-irritant/noise "within procedure")
+            operator-name)))
\ No newline at end of file

diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm
index 37c7941723bf6e3021b62d49662ed1e17741c6d6..58d36b2586e16e033da69f9ddd384169b72b8c0b 100644 (file)
--- a/v8/src/runtime/global.scm
+++ b/v8/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.16 1990/07/20 01:12:03 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.17 1990/09/11 21:58:52 cph Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -196,7 +196,7 @@ MIT in each case. |#
    (->environment to)
    (->environment from)
    name))
-\f
+
 (define-integrable (object-non-pointer? object)
   (zero? (object-gc-type object)))
 
@@ -218,7 +218,7 @@ MIT in each case. |#
        (error "FASDUMP: Object is too large to be dumped" object))
     (write-string " -- done" port))
   object)
-
+\f
 (define (undefined-value? object)
   ;; Note: the unparser takes advantage of the fact that objects
   ;; satisfying this predicate also satisfy:
@@ -234,8 +234,6 @@ MIT in each case. |#
 
 (define unspecific
   (object-new-type (ucode-type true) 1))
-\f
-;;;; Obarray->list
 
 (define (obarray->list #!optional obarray)
   (let ((table (if (default-object? obarray)
@@ -251,4 +249,20 @@ MIT in each case. |#
                (per-bucket (-1+ index) accumulator)
                (per-symbol
                 (cdr bucket)
-                (cons (car bucket) accumulator))))))))
\ No newline at end of file
+                (cons (car bucket) accumulator))))))))
+
+(define (error:illegal-datum object #!optional operator-name)
+  (if (default-object? operator-name)
+      (error error-type:wrong-type-argument object)
+      (error error-type:wrong-type-argument object
+            (error-irritant/noise char:newline)
+            (error-irritant/noise "within procedure")
+            operator-name)))
+
+(define (error:datum-out-of-range object #!optional operator-name)
+  (if (default-object? operator-name)
+      (error error-type:bad-range-argument object)
+      (error error-type:bad-range-argument object
+            (error-irritant/noise char:newline)
+            (error-irritant/noise "within procedure")
+            operator-name)))
\ No newline at end of file