Add new operations to categorize type codes.

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index d9a1a80ff9ac476b8dd759c3cb3b1b495bebd167..8c075cc96881a36ce7edadb8e4eb72dc3dbdd60f 100644 (file)
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: global.scm,v 14.62 2004/07/02 00:53:27 cph Exp $
+$Id: global.scm,v 14.63 2004/07/04 05:28:37 cph Exp $
 
 Copyright 1988,1989,1991,1992,1993,1995 Massachusetts Institute of Technology
 Copyright 1998,2000,2001,2003,2004 Massachusetts Institute of Technology
@@ -260,14 +260,19 @@ USA.
   ((ucode-primitive unbind-variable 2) (->environment environment) name))
 \f
 (define (object-gc-type object)
-  (let ((t ((ucode-primitive object-gc-type 1) object)))
-    (if (not (and (fix:fixnum? t)
-                 (fix:>= t -4)
-                 (fix:<= t 4)))
-       (error "Illegal GC-type value:" t))
-    (vector-ref '#(COMPILED-ENTRY VECTOR GC-INTERNAL UNDEFINED NON-POINTER
-                                 CELL PAIR TRIPLE QUADRUPLE)
-               (fix:+ t 4))))
+  (%encode-gc-type ((ucode-primitive object-gc-type 1) object)))
+
+(define (type-code->gc-type code)
+  (%encode-gc-type ((ucode-primitive type-code->gc-type 1) code)))
+
+(define (%encode-gc-type t)
+  (if (not (and (fix:fixnum? t)
+               (fix:>= t -4)
+               (fix:<= t 4)))
+      (error "Illegal GC-type value:" t))
+  (vector-ref '#(COMPILED-ENTRY VECTOR GC-INTERNAL UNDEFINED NON-POINTER
+                               CELL PAIR TRIPLE QUADRUPLE)
+             (fix:+ t 4)))
 
 (define (object-non-pointer? object)
   (case (object-gc-type object)
@@ -288,6 +293,20 @@ USA.
              (> (object-datum object) trap-max-immediate))))
     (else #f)))
 
+(define (non-pointer-type-code? code)
+  (case (type-code->gc-type code)
+    ((NON-POINTER) #t)
+    ((GC-INTERNAL)
+     (or (fix:= (ucode-type manifest-nm-vector) code)
+        (fix:= (ucode-type manifest-special-nm-vector) code)))
+    (else #f)))
+
+(define (pointer-type-code? code)
+  (case (type-code->gc-type code)
+    ((CELL PAIR TRIPLE QUADRUPLE VECTOR COMPILED-ENTRY) #t)
+    ((GC-INTERNAL) (fix= (ucode-type broken-heart) code))
+    (else #f)))
+
 (define (undefined-value? object)
   ;; Note: the unparser takes advantage of the fact that objects
   ;; satisfying this predicate also satisfy:

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 269db22eed6228b45f345b509431687222b867c6..485b6f6f34d084ad5c686873cf5fe680718e1900 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.488 2004/07/02 00:54:07 cph Exp $
+$Id: runtime.pkg,v 14.489 2004/07/04 05:28:56 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -306,6 +306,7 @@ USA.
          local-assignment
          make-cell
          make-non-pointer-object
+         non-pointer-type-code?
          null-procedure
          obarray->list
          object-component-binder
@@ -317,6 +318,7 @@ USA.
          object-type
          object-type?
          pa
+         pointer-type-code?
          primitive-procedure-arity
          primitive-procedure-documentation
          pwd
@@ -345,6 +347,7 @@ USA.
          system-vector-set!
          system-vector?
          true-procedure
+         type-code->gc-type
          unbind-variable
          undefined-value?
          unspecific