From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 5 Jun 1987 17:29:53 +0000 (+0000)
Subject: Define new type code for compiled code blocks to guarantee that they
X-Git-Tag: 20090517-FFI~13410
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e5a6866174c5bf677d66fde800d60b8a8bd3a327;p=mit-scheme.git

Define new type code for compiled code blocks to guarantee that they
are not put in pure space.
---

diff --git a/v7/src/microcode/bchpur.c b/v7/src/microcode/bchpur.c
index ab9eba90e..a58e72d45 100644
--- a/v7/src/microcode/bchpur.c
+++ b/v7/src/microcode/bchpur.c
@@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. */
 
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.29 1987/06/02 08:43:02 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.30 1987/06/05 17:29:53 cph Exp $
  *
  * This file contains the code for primitives dealing with pure
  * and constant space.  Garbage collection to disk version.
@@ -130,6 +130,8 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode)
 	break;
 
       case_compiled_entry_point:
+	if (GC_Mode == PURE_COPY)
+	  break;
 	Old = Get_Pointer(Temp);
 	if (Old >= Low_Constant)
 	  continue;
@@ -178,6 +180,7 @@ purifyloop(Scan, To_ptr, To_Address_ptr, purify_mode)
       case_Quadruple:
 	relocate_normal_pointer(copy_quadruple(), 4);
 
+      case TC_COMPILED_CODE_BLOCK:
       case TC_ENVIRONMENT:
 	if (purify_mode == PURE_COPY)
 	  break;
diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c
index 41a89c401..90caa65b9 100644
--- a/v7/src/microcode/purify.c
+++ b/v7/src/microcode/purify.c
@@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. */
 
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.27 1987/06/02 00:17:36 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.28 1987/06/05 17:29:07 cph Rel $
  *
  * This file contains the code that copies objects into pure
  * and constant space.
@@ -162,6 +162,7 @@ PurifyLoop(Scan, To_Pointer, GC_Mode)
 	   GC dameons spliced them, but this should not occur.
 	 */
 
+      case TC_COMPILED_CODE_BLOCK:
       case TC_FUTURE:
       case TC_ENVIRONMENT:
 	if (GC_Mode == PURE_COPY)
diff --git a/v7/src/microcode/purutl.c b/v7/src/microcode/purutl.c
index 4f1910422..b79a72bf4 100644
--- a/v7/src/microcode/purutl.c
+++ b/v7/src/microcode/purutl.c
@@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising,
 promotional, or sales literature without prior written consent from
 MIT in each case. */
 
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.28 1987/04/16 02:28:06 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.29 1987/06/05 17:29:30 cph Rel $ */
 
 /* Pure/Constant space utilities. */
 
@@ -219,13 +219,14 @@ Built_In_Primitive(Prim_Pure_P, 1, "PURE?", 0xBB)
   if ((GC_Type_Non_Pointer(Arg1)) ||
       (GC_Type_Special(Arg1)))
     return TRUTH;
-  if (GC_Type_Compiled(Arg1))
-    return NIL;
   Touch_In_Primitive(Arg1, Arg1);
   {
     Pointer *Obj_Address;
 
-    Obj_Address = Get_Pointer(Arg1);
+    Obj_Address =
+      ((GC_Type_Compiled(Arg1))
+       ? (Get_Compiled_Block(Get_Pointer(Arg1)))
+       : (Get_Pointer(Arg1)));
     if (Is_Pure(Obj_Address))
       return TRUTH;
   }
@@ -243,8 +244,7 @@ Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?", 0xBA)
   Touch_In_Primitive(Arg1, Arg1);
   return ((GC_Type_Non_Pointer(Arg1)) ||
 	  (GC_Type_Special(Arg1)) ||
-          ((Get_Pointer(Arg1) >= Constant_Space) &&
-           (Get_Pointer(Arg1) < Free_Constant))) ?
+	  (Is_Constant(Get_Pointer(Arg1)))) ?
          TRUTH : NIL;
 }
 
diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm
index e65f3b07e..459d5c26f 100644
--- a/v7/src/microcode/utabmd.scm
+++ b/v7/src/microcode/utabmd.scm
@@ -37,7 +37,7 @@
 
 ;;;; Machine Dependent Type Tables
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.33 1987/06/05 16:25:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.34 1987/06/05 17:28:37 cph Exp $
 
 (declare (usual-integrations))
 
@@ -159,7 +159,7 @@
 	       COMPILER-LINK				;3A
 	       STACK-ENVIRONMENT			;3B
 	       COMPLEX       				;3C
-	       #F					;3D
+	       COMPILED-CODE-BLOCK			;3D
 	       #F					;3E
 	       #F					;3F
 	       #F        				;40
@@ -863,4 +863,4 @@
 
 ;;; This identification string is saved by the system.
 
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.33 1987/06/05 16:25:42 cph Exp $"
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.34 1987/06/05 17:28:37 cph Exp $"
diff --git a/v8/src/microcode/utabmd.scm b/v8/src/microcode/utabmd.scm
index 313b78096..1a527fa16 100644
--- a/v8/src/microcode/utabmd.scm
+++ b/v8/src/microcode/utabmd.scm
@@ -37,7 +37,7 @@
 
 ;;;; Machine Dependent Type Tables
 
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.33 1987/06/05 16:25:42 cph Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.34 1987/06/05 17:28:37 cph Exp $
 
 (declare (usual-integrations))
 
@@ -159,7 +159,7 @@
 	       COMPILER-LINK				;3A
 	       STACK-ENVIRONMENT			;3B
 	       COMPLEX       				;3C
-	       #F					;3D
+	       COMPILED-CODE-BLOCK			;3D
 	       #F					;3E
 	       #F					;3F
 	       #F        				;40
@@ -863,4 +863,4 @@
 
 ;;; This identification string is saved by the system.
 
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.33 1987/06/05 16:25:42 cph Exp $"
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.34 1987/06/05 17:28:37 cph Exp $"