From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 2 Jul 2004 00:54:07 +0000 (+0000)
Subject: Fix definitions of OBJECT-POINTER? and OBJECT-NON-POINTER? so they are
X-Git-Tag: 20090517-FFI~1629
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1d30ad9d22abb9ccc68aeba3b0a883643b8b5ec1;p=mit-scheme.git

Fix definitions of OBJECT-POINTER? and OBJECT-NON-POINTER? so they are
more accurate.
---

diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm
index cf278527d..d9a1a80ff 100644
--- a/v7/src/runtime/global.scm
+++ b/v7/src/runtime/global.scm
@@ -1,9 +1,9 @@
 #| -*-Scheme-*-
 
-$Id: global.scm,v 14.61 2003/04/14 19:56:15 cph Exp $
+$Id: global.scm,v 14.62 2004/07/02 00:53:27 cph Exp $
 
 Copyright 1988,1989,1991,1992,1993,1995 Massachusetts Institute of Technology
-Copyright 1998,2000,2001,2003 Massachusetts Institute of Technology
+Copyright 1998,2000,2001,2003,2004 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -44,7 +44,6 @@ USA.
 
   ;; Pointers
   (object-type 1)
-  (object-gc-type 1)
   (object-datum 1)
   (object-type? 2)
   (object-new-type object-set-type 2)
@@ -260,11 +259,67 @@ USA.
 (define (unbind-variable environment name)
   ((ucode-primitive unbind-variable 2) (->environment environment) name))
 
-(define-integrable (object-non-pointer? object)
-  (zero? (object-gc-type object)))
+(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))))
+
+(define (object-non-pointer? object)
+  (case (object-gc-type object)
+    ((NON-POINTER) #t)
+    ((GC-INTERNAL)
+     (or (object-type? (ucode-type manifest-nm-vector) object)
+	 (object-type? (ucode-type manifest-special-nm-vector) object)
+	 (and (object-type? (ucode-type reference-trap) object)
+	      (<= (object-datum object) trap-max-immediate))))
+    (else #f)))
+
+(define (object-pointer? object)
+  (case (object-gc-type object)
+    ((CELL PAIR TRIPLE QUADRUPLE VECTOR COMPILED-ENTRY) #t)
+    ((GC-INTERNAL)
+     (or (object-type? (ucode-type broken-heart) object)
+	 (and (object-type? (ucode-type reference-trap) object)
+	      (> (object-datum object) trap-max-immediate))))
+    (else #f)))
 
-(define-integrable (object-pointer? object)
-  (not (object-non-pointer? object)))
+(define (undefined-value? object)
+  ;; Note: the unparser takes advantage of the fact that objects
+  ;; satisfying this predicate also satisfy:
+  ;; (object-type? (ucode-type constant) object)
+  (or (eq? object undefined-conditional-branch)
+      ;; same as `undefined-conditional-branch'.
+      ;; (eq? object *the-non-printing-object*)
+      ;; (eq? object unspecific)
+      (eq? object (microcode-object/unassigned))))
+
+(define unspecific
+  (object-new-type (ucode-type constant) 1))
+
+(define *the-non-printing-object*
+  unspecific)
+
+(define (obarray->list #!optional obarray)
+  (let ((obarray
+	 (if (default-object? obarray)
+	     (fixed-objects-item 'OBARRAY)
+	     obarray)))
+    (let per-bucket
+	((index (fix:- (vector-length obarray) 1))
+	 (accumulator '()))
+      (if (fix:< index 0)
+	  accumulator
+	  (let per-symbol
+	      ((bucket (vector-ref obarray index))
+	       (accumulator accumulator))
+	    (if (pair? bucket)
+		(per-symbol (cdr bucket) (cons (car bucket) accumulator))
+		(per-bucket (fix:- index 1) accumulator)))))))
 
 (define (impurify object)
   (if (and (object-pointer? object) (object-pure? object))
@@ -301,37 +356,4 @@ USA.
 		 (lambda ()
 		   (write-string " -- done" port)
 		   (newline port))))
-	(do-it no-print no-print))))
-
-(define (undefined-value? object)
-  ;; Note: the unparser takes advantage of the fact that objects
-  ;; satisfying this predicate also satisfy:
-  ;; (object-type? (microcode-type 'CONSTANT) object)
-  (or (eq? object undefined-conditional-branch)
-      ;; same as `undefined-conditional-branch'.
-      ;; (eq? object *the-non-printing-object*)
-      ;; (eq? object unspecific)
-      (eq? object (microcode-object/unassigned))))
-
-(define unspecific
-  (object-new-type (ucode-type constant) 1))
-
-(define *the-non-printing-object*
-  unspecific)
-
-(define (obarray->list #!optional obarray)
-  (let ((obarray
-	 (if (default-object? obarray)
-	     (fixed-objects-item 'OBARRAY)
-	     obarray)))
-    (let per-bucket
-	((index (fix:- (vector-length obarray) 1))
-	 (accumulator '()))
-      (if (fix:< index 0)
-	  accumulator
-	  (let per-symbol
-	      ((bucket (vector-ref obarray index))
-	       (accumulator accumulator))
-	    (if (pair? bucket)
-		(per-symbol (cdr bucket) (cons (car bucket) accumulator))
-		(per-bucket (fix:- index 1) accumulator)))))))
\ No newline at end of file
+	(do-it no-print no-print))))
\ No newline at end of file
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 6fe6c6b27..269db22ee 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.487 2004/06/12 02:14:56 cph Exp $
+$Id: runtime.pkg,v 14.488 2004/07/02 00:54:07 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -2710,7 +2710,9 @@ USA.
 	  make-macro-reference-trap-expression)
   (export (runtime unsyntaxer)
 	  macro-reference-trap-expression-transformer
-	  macro-reference-trap-expression?))
+	  macro-reference-trap-expression?)
+  (export (runtime miscellaneous-global)
+	  trap-max-immediate))
 
 (define-package (runtime rep)
   (files "rep")