From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 4 Jul 2004 05:28:56 +0000 (+0000)
Subject: Add new operations to categorize type codes.
X-Git-Tag: 20090517-FFI~1626
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0ce1be4689ff5db14b8783bbef565c7fadd881d1;p=mit-scheme.git

Add new operations to categorize type codes.
---

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index d9a1a80ff..8c075cc96 100644
--- 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))
 
 (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 269db22ee..485b6f6f3 100644
--- 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