From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Mon, 9 Feb 1987 00:37:58 +0000 (+0000)
Subject: Split purify.c into purify.c and purutl.c
X-Git-Tag: 20090517-FFI~13713
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7c388cfe2c3b4fd2dbbbea3f02efbeec364b136c;p=mit-scheme.git

Split purify.c into purify.c and purutl.c
---

diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c
index 3c257523c..363466da8 100644
--- a/v7/src/microcode/purify.c
+++ b/v7/src/microcode/purify.c
@@ -30,9 +30,9 @@ 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.23 1987/02/08 23:05:47 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.24 1987/02/09 00:34:50 jinx Exp $
  *
- * This file contains the code for primitives dealing with pure
+ * This file contains the code that copies objects into pure
  * and constant space.
  *
  */
@@ -374,210 +374,3 @@ Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY")
  Pushed();
   longjmp(*Back_To_Eval, PRIM_APPLY); /*NOTREACHED*/
 }
-
-Pointer Make_Impure(Object)
-Pointer Object;
-{ Pointer *New_Address, *End_Of_Area;
-  fast Pointer *Obj_Address, *Constant_Address;
-  long Length, Block_Length;
-  fast long i;
-
-  /* Calculate size of object to be "impurified".
-     Note that this depends on the fact that Compiled Entries CANNOT
-     be pure.
-   */
-
-  Switch_by_GC_Type(Object)
-  { case TC_BROKEN_HEART:
-    case TC_MANIFEST_NM_VECTOR:
-    case TC_MANIFEST_SPECIAL_NM_VECTOR:
-    case_Non_Pointer:
-      printf("Impurify Non-Pointer.\n");
-      Microcode_Termination(TERM_NON_POINTER_RELOCATION);
-    case TC_BIG_FLONUM:
-    case TC_FUTURE:
-    case_Vector:     Length = Vector_Length(Object) + 1; break;
-    case_Quadruple:  Length = 4; break;
-    case TC_VARIABLE:
-    case_Triple:     Length = 3; break;
-    case TC_WEAK_CONS:
-    case_Pair:       Length = 2; break;
-    case_Cell:       Length = 1; break;
-    default:
-      fprintf(stderr, "Impurify: Bad type code = 0x%02x\n",
-	      Type_Code(Object));
-      Invalid_Type_Code();
-  }
-
-  /* Add a copy of the object to the last constant block in memory.
-   */
-
-  Constant_Address = Free_Constant;
-
-  Obj_Address = Get_Pointer(Object);
-  if (!Test_Pure_Space_Top(Constant_Address+Length)) return NIL;
-  Block_Length = Get_Integer(*(Constant_Address-1));
-  Constant_Address = Constant_Address-2;
-  New_Address = Constant_Address;
-
-#ifdef FLOATING_ALIGNMENT
-  /* This should be done more cleanly, always align before doing a
-     block, or something like it. -- JINX
-   */
-
-  if (Type_Code(Object) == TC_BIG_FLONUM)
-  { Pointer *Start = Constant_Address;
-    Align_Float(Constant_Address);
-    for (i=0; i < Length; i++) *Constant_Address++ = *Obj_Address++;
-    Length = Constant_Address-Start;
-  }
-  else
-#endif
-    for (i = Length; --i >= 0; )
-    { *Constant_Address++ = *Obj_Address;
-      *Obj_Address++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, i);
-    }
-  *Constant_Address++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
-  *Constant_Address++ = Make_Non_Pointer(END_OF_BLOCK, Block_Length+Length);
-  *(New_Address+2-Block_Length) =
-    Make_Non_Pointer(PURE_PART, Block_Length+Length);
-  Obj_Address -= Length;
-  Free_Constant = Constant_Address;
-
-  /* Run through memory relocating pointers to this object, including
-   * those in pure areas.
-   */
-
-  Set_Pure_Top();
-  Terminate_Old_Stacklet();
-  Terminate_Constant_Space(End_Of_Area);
-  Update(Heap_Bottom, Free, Obj_Address, New_Address);
-  Update(Constant_Space, End_Of_Area, Obj_Address, New_Address);
-  return Make_Pointer(Type_Code(Object), New_Address);
-}
-
-/* (IMPURIFY OBJECT)
-      [Primitive number 0xBD]
-*/
-Built_In_Primitive(Prim_Impurify, 1, "IMPURIFY")
-{ Pointer Result;
-  Primitive_1_Arg();
-  Touch_In_Primitive(Arg1, Arg1);
-  Result = Make_Impure(Arg1);
-  if (Result != NIL) return Result;
-  Primitive_Error(ERR_IMPURIFY_OUT_OF_SPACE); /*NOTREACHED*/
-}
-
-Update(From, To, Was, Will_Be)
-fast Pointer *From, *To, *Was, *Will_Be;
-{ for (; From < To; From++)
-  { if (GC_Type_Special(*From))
-    { if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
-        From += Get_Integer(*From);
-      continue;
-    }
-    if (GC_Type_Non_Pointer(*From)) continue;
-    if (Get_Pointer(*From) == Was)
-      *From = Make_Pointer(Type_Code(*From), Will_Be);
-  }
-}
-
-Boolean Pure_Test(Obj_Address)
-fast Pointer *Obj_Address;
-{ fast Pointer *Where;
-#ifdef FLOATING_ALIGNMENT
-  fast Pointer Float_Align_Value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
-#endif
-  Where = Free_Constant-1;
-  while (Where >= Constant_Space)
-  {
-#ifdef FLOATING_ALIGNMENT
-    while (*Where == Float_Align_Value) Where -= 1;
-#endif
-    Where -= 1+Get_Integer(*Where);
-    if (Where <= Obj_Address)
-      return (Boolean) (Obj_Address <= (Where+1+Get_Integer(*(Where+1))));
-  }
-  return (Boolean) false;
-}
-
-/* (PURE? OBJECT)
-      [Primitive number 0xBB]
-      Returns #!TRUE if the object is pure (ie it doesn't point to any
-      other object, or it is in a pure section of the constant space).
-*/
-Built_In_Primitive(Prim_Pure_P, 1, "PURE?")
-{ Primitive_1_Arg();
-
-  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);
-    if (Is_Pure(Obj_Address)) return TRUTH;
-  }
-  return NIL;
-}
-
-/* (CONSTANT? OBJECT)
-      [Primitive number 0xBA]
-      Returns #!TRUE if the object is in constant space or isn't a
-      pointer.
-*/
-Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?")
-{ Primitive_1_Arg();
-  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))) ?
-         TRUTH : NIL;
-}
-
-/* (GET-NEXT-CONSTANT)
-      [Primitive number 0xE4]
-      Returns the next free address in constant space.
-*/
-Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT")
-{ Pointer *Next_Address = Free_Constant+1;
-  Primitive_0_Args();
-  return Make_Pointer(TC_ADDRESS, Next_Address);
-}
-
-/* copy_to_constant_space is a microcode utility procedure.
-   It takes care of making legal constant space blocks.
-   The microcode kills itself if there is not enough constant
-   space left.
- */
-
-extern Pointer *copy_to_constant_space();
-
-Pointer *
-copy_to_constant_space(source, nobjects)
-fast Pointer *source;
-long nobjects;
-{ fast Pointer *dest;
-  fast long i;
-  Pointer *result;
-
-  dest = Free_Constant;
-  if (!Test_Pure_Space_Top(dest+nobjects+6))
-  { fprintf(stderr,
-	    "copy_to_constant_space: Not enough constant space!\n");
-    Microcode_Termination(TERM_NO_SPACE);
-  }
-  *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 3);
-  *dest++ = Make_Non_Pointer(PURE_PART, nobjects+5);
-  *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
-  *dest++ = Make_Non_Pointer(CONSTANT_PART, 3);
-  result = dest;
-  for (i = nobjects; --i >= 0; )
-    *dest++ = *source++;
-  *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
-  *dest++ = Make_Non_Pointer(END_OF_BLOCK, nobjects+5);
-  Free_Constant = dest;
-
-  return result;
-}
diff --git a/v7/src/microcode/purutl.c b/v7/src/microcode/purutl.c
new file mode 100644
index 000000000..d86003abd
--- /dev/null
+++ b/v7/src/microcode/purutl.c
@@ -0,0 +1,247 @@
+/* -*-C-*-
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+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.26 1987/02/09 00:37:58 jinx Exp $ */
+
+/* Pure/Constant space utilities. */
+
+#include "scheme.h"
+#include "primitive.h"
+#include "gccode.h"
+#include "zones.h"
+
+Pointer Make_Impure(Object)
+Pointer Object;
+{ Pointer *New_Address, *End_Of_Area;
+  fast Pointer *Obj_Address, *Constant_Address;
+  long Length, Block_Length;
+  fast long i;
+
+  /* Calculate size of object to be "impurified".
+     Note that this depends on the fact that Compiled Entries CANNOT
+     be pure.
+   */
+
+  Switch_by_GC_Type(Object)
+  { case TC_BROKEN_HEART:
+    case TC_MANIFEST_NM_VECTOR:
+    case TC_MANIFEST_SPECIAL_NM_VECTOR:
+    case_Non_Pointer:
+      printf("Impurify Non-Pointer.\n");
+      Microcode_Termination(TERM_NON_POINTER_RELOCATION);
+    case TC_BIG_FLONUM:
+    case TC_FUTURE:
+    case_Vector:     Length = Vector_Length(Object) + 1; break;
+    case_Quadruple:  Length = 4; break;
+    case TC_VARIABLE:
+    case_Triple:     Length = 3; break;
+    case TC_WEAK_CONS:
+    case_Pair:       Length = 2; break;
+    case_Cell:       Length = 1; break;
+    default:
+      fprintf(stderr, "Impurify: Bad type code = 0x%02x\n",
+	      Type_Code(Object));
+      Invalid_Type_Code();
+  }
+
+  /* Add a copy of the object to the last constant block in memory.
+   */
+
+  Constant_Address = Free_Constant;
+
+  Obj_Address = Get_Pointer(Object);
+  if (!Test_Pure_Space_Top(Constant_Address+Length)) return NIL;
+  Block_Length = Get_Integer(*(Constant_Address-1));
+  Constant_Address = Constant_Address-2;
+  New_Address = Constant_Address;
+
+#ifdef FLOATING_ALIGNMENT
+  /* This should be done more cleanly, always align before doing a
+     block, or something like it. -- JINX
+   */
+
+  if (Type_Code(Object) == TC_BIG_FLONUM)
+  { Pointer *Start = Constant_Address;
+    Align_Float(Constant_Address);
+    for (i=0; i < Length; i++) *Constant_Address++ = *Obj_Address++;
+    Length = Constant_Address-Start;
+  }
+  else
+#endif
+    for (i = Length; --i >= 0; )
+    { *Constant_Address++ = *Obj_Address;
+      *Obj_Address++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, i);
+    }
+  *Constant_Address++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+  *Constant_Address++ = Make_Non_Pointer(END_OF_BLOCK, Block_Length+Length);
+  *(New_Address+2-Block_Length) =
+    Make_Non_Pointer(PURE_PART, Block_Length+Length);
+  Obj_Address -= Length;
+  Free_Constant = Constant_Address;
+
+  /* Run through memory relocating pointers to this object, including
+   * those in pure areas.
+   */
+
+  Set_Pure_Top();
+  Terminate_Old_Stacklet();
+  Terminate_Constant_Space(End_Of_Area);
+  Update(Heap_Bottom, Free, Obj_Address, New_Address);
+  Update(Constant_Space, End_Of_Area, Obj_Address, New_Address);
+  return Make_Pointer(Type_Code(Object), New_Address);
+}
+
+/* (IMPURIFY OBJECT)
+      [Primitive number 0xBD]
+*/
+Built_In_Primitive(Prim_Impurify, 1, "IMPURIFY")
+{ Pointer Result;
+  Primitive_1_Arg();
+  Touch_In_Primitive(Arg1, Arg1);
+  Result = Make_Impure(Arg1);
+  if (Result != NIL) return Result;
+  Primitive_Error(ERR_IMPURIFY_OUT_OF_SPACE); /*NOTREACHED*/
+}
+
+Update(From, To, Was, Will_Be)
+fast Pointer *From, *To, *Was, *Will_Be;
+{ for (; From < To; From++)
+  { if (GC_Type_Special(*From))
+    { if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
+        From += Get_Integer(*From);
+      continue;
+    }
+    if (GC_Type_Non_Pointer(*From)) continue;
+    if (Get_Pointer(*From) == Was)
+      *From = Make_Pointer(Type_Code(*From), Will_Be);
+  }
+}
+
+Boolean Pure_Test(Obj_Address)
+fast Pointer *Obj_Address;
+{ fast Pointer *Where;
+#ifdef FLOATING_ALIGNMENT
+  fast Pointer Float_Align_Value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
+#endif
+  Where = Free_Constant-1;
+  while (Where >= Constant_Space)
+  {
+#ifdef FLOATING_ALIGNMENT
+    while (*Where == Float_Align_Value) Where -= 1;
+#endif
+    Where -= 1+Get_Integer(*Where);
+    if (Where <= Obj_Address)
+      return (Boolean) (Obj_Address <= (Where+1+Get_Integer(*(Where+1))));
+  }
+  return (Boolean) false;
+}
+
+/* (PURE? OBJECT)
+      [Primitive number 0xBB]
+      Returns #!TRUE if the object is pure (ie it doesn't point to any
+      other object, or it is in a pure section of the constant space).
+*/
+Built_In_Primitive(Prim_Pure_P, 1, "PURE?")
+{ Primitive_1_Arg();
+
+  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);
+    if (Is_Pure(Obj_Address)) return TRUTH;
+  }
+  return NIL;
+}
+
+/* (CONSTANT? OBJECT)
+      [Primitive number 0xBA]
+      Returns #!TRUE if the object is in constant space or isn't a
+      pointer.
+*/
+Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?")
+{ Primitive_1_Arg();
+  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))) ?
+         TRUTH : NIL;
+}
+
+/* (GET-NEXT-CONSTANT)
+      [Primitive number 0xE4]
+      Returns the next free address in constant space.
+*/
+Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT")
+{ Pointer *Next_Address = Free_Constant+1;
+  Primitive_0_Args();
+  return Make_Pointer(TC_ADDRESS, Next_Address);
+}
+
+/* copy_to_constant_space is a microcode utility procedure.
+   It takes care of making legal constant space blocks.
+   The microcode kills itself if there is not enough constant
+   space left.
+ */
+
+extern Pointer *copy_to_constant_space();
+
+Pointer *
+copy_to_constant_space(source, nobjects)
+fast Pointer *source;
+long nobjects;
+{ fast Pointer *dest;
+  fast long i;
+  Pointer *result;
+
+  dest = Free_Constant;
+  if (!Test_Pure_Space_Top(dest+nobjects+6))
+  { fprintf(stderr,
+	    "copy_to_constant_space: Not enough constant space!\n");
+    Microcode_Termination(TERM_NO_SPACE);
+  }
+  *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 3);
+  *dest++ = Make_Non_Pointer(PURE_PART, nobjects+5);
+  *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+  *dest++ = Make_Non_Pointer(CONSTANT_PART, 3);
+  result = dest;
+  for (i = nobjects; --i >= 0; )
+    *dest++ = *source++;
+  *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
+  *dest++ = Make_Non_Pointer(END_OF_BLOCK, nobjects+5);
+  Free_Constant = dest;
+
+  return result;
+}
diff --git a/v7/src/microcode/storage.c b/v7/src/microcode/storage.c
index 43bff4166..f132508b2 100644
--- a/v7/src/microcode/storage.c
+++ b/v7/src/microcode/storage.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/storage.c,v 9.23 1987/02/03 16:00:50 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.24 1987/02/09 00:36:08 jinx Exp $
 
 This file defines the storage for global variables for
 the Scheme Interpreter. */
@@ -1549,10 +1549,10 @@ char *Primitive_Names[] = {
 /* 0xB7 in fasdump */	"DUMP-BAND",
 /* 0xB8 in string */	"SUBSTRING-SEARCH",
 /* 0xB9 in fasload */	"LOAD-BAND",
-/* 0xBA in purify */	"CONSTANT?",
-/* 0xBB in purify */	"PURE?",
+/* 0xBA in purutl */	"CONSTANT?",
+/* 0xBB in purutl */	"PURE?",
 /* 0xBC in prim */	"PRIMITIVE-GC-TYPE",
-/* 0xBD in purify */	"IMPURIFY",
+/* 0xBD in purutl */	"IMPURIFY",
 /* 0xBE in hooks */	"WITH-THREADED-CONTINUATION",
 /* 0xBF in hooks */	"WITHIN-CONTROL-POINT",
 /* 0xC0 in sysprim */	"SET-RUN-LIGHT!",
@@ -1596,7 +1596,7 @@ char *Primitive_Names[] = {
 /* 0xE1 in hooks */	"MAKE-STATE-SPACE",
 /* 0xE2 in hooks */	"EXECUTE-AT-NEW-POINT",
 /* 0xE3 in hooks */	"TRANSLATE-TO-POINT",
-/* 0xE4 in purify */	"GET-NEXT-CONSTANT",
+/* 0xE4 in purutl */	"GET-NEXT-CONSTANT",
 
 /* Primitive names continue on the next page */
 
diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h
index 5e0233c0b..21a4733df 100644
--- a/v7/src/microcode/version.h
+++ b/v7/src/microcode/version.h
@@ -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/version.h,v 9.25 1987/02/08 23:05:21 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.26 1987/02/09 00:35:37 jinx Exp $
 
 This file contains version information for the microcode. */
 
@@ -46,7 +46,7 @@ This file contains version information for the microcode. */
 #define VERSION		9
 #endif
 #ifndef SUBVERSION
-#define SUBVERSION	25
+#define SUBVERSION	26
 #endif
 
 #ifndef UCODE_TABLES_FILENAME
diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h
index 37be933bc..c0a110d5e 100644
--- a/v8/src/microcode/version.h
+++ b/v8/src/microcode/version.h
@@ -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/v8/src/microcode/version.h,v 9.25 1987/02/08 23:05:21 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.26 1987/02/09 00:35:37 jinx Exp $
 
 This file contains version information for the microcode. */
 
@@ -46,7 +46,7 @@ This file contains version information for the microcode. */
 #define VERSION		9
 #endif
 #ifndef SUBVERSION
-#define SUBVERSION	25
+#define SUBVERSION	26
 #endif
 
 #ifndef UCODE_TABLES_FILENAME