Allow #T as a parameter make tohe microcode version of

make-primitive-procedure.

diff --git a/v7/src/microcode/extern.c b/v7/src/microcode/extern.c
index 5afee8cfed30178064c1afff1d33e0bd990feadd..faf5659eb3f6c0bcbf19760b4a47ea74d50d1a6f 100644 (file)
--- a/v7/src/microcode/extern.c
+++ b/v7/src/microcode/extern.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/extern.c,v 9.23 1987/11/17 08:09:28 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.c,v 9.24 1987/11/18 00:09:22 jinx Exp $ */
 
 #include "scheme.h"
 #include "primitive.h"
@@ -195,7 +195,7 @@ Built_In_Primitive(Prim_Get_Primitive_Address, 2, "GET-PRIMITIVE-ADDRESS", 0x103
 Define_Primitive(Prim_Get_Primitive_Address, 2, "GET-PRIMITIVE-ADDRESS")
 {
   extern Pointer find_primitive();
-  Boolean intern_p, check_p;
+  Boolean intern_p, allow_p;
   long arity;
   Primitive_2_Args();
 
@@ -203,17 +203,23 @@ Define_Primitive(Prim_Get_Primitive_Address, 2, "GET-PRIMITIVE-ADDRESS")
   Touch_In_Primitive(Arg2, Arg2);
   if (Arg2 == NIL)
   {
-    check_p = false;
+    allow_p = false;
     intern_p = false;
-    arity = 0;
+    arity = UNKNOWN_PRIMITIVE_ARITY;
+  }
+  else if (Arg2 == TRUTH)
+  {
+    allow_p = true;
+    intern_p = false;
+    arity = UNKNOWN_PRIMITIVE_ARITY;
   }
   else
   {
     CHECK_ARG(2, FIXNUM_P);
-    check_p = true;
+    allow_p = true;
     intern_p = true;
     Sign_Extend(Arg2, arity);
   }
   PRIMITIVE_RETURN(find_primitive(Fast_Vector_Ref(Arg1, SYMBOL_NAME),
-                                 intern_p, arity, check_p));
+                                 intern_p, allow_p, arity));
 }

diff --git a/v7/src/microcode/primutl.c b/v7/src/microcode/primutl.c
index c118d1226ba36240ffbe4fcf55a30838adbb934a..2c2bdf86b3fa38929e0c6464ffb616e83b7c7e41 100644 (file)
--- a/v7/src/microcode/primutl.c
+++ b/v7/src/microcode/primutl.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/primutl.c,v 9.41 1987/11/17 08:15:15 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/primutl.c,v 9.42 1987/11/18 00:08:54 jinx Exp $
  *
  * This file contains the support routines for mapping primitive names
  * to numbers within the microcode.  Primitives are written in C
@@ -288,12 +288,12 @@ primitive_name(code)
   return (string_to_symbol(scheme_string));
 }
 \f
-extern Pointer find_primitiveo();
+extern Pointer find_primitive();
 
 Pointer
-find_primitive(Name, intern_p, arity, check_p)
+find_primitive(Name, intern_p, allow_p, arity)
      Pointer Name;
-     Boolean intern_p, check_p;
+     Boolean intern_p, allow_p;
      int arity;
 {
   extern Boolean string_equal();
@@ -306,8 +306,7 @@ find_primitive(Name, intern_p, arity, check_p)
   if (i != -1)
   {
     old_arity = Primitive_Arity_Table[i];
-    if ((!check_p) || (arity == old_arity) ||
-       (arity == UNKNOWN_PRIMITIVE_ARITY))
+    if ((arity == UNKNOWN_PRIMITIVE_ARITY) || (arity == old_arity))
     {
       return (Make_Non_Pointer(TC_PRIMITIVE, i));
     }
@@ -316,11 +315,14 @@ find_primitive(Name, intern_p, arity, check_p)
       return (MAKE_SIGNED_FIXNUM(old_arity));
     }
   }
-  else if (intern_p == NIL)
+\f
+  /* Search the undefined primitives table if allowed. */
+
+  if (!allow_p)
   {
     return (NIL);
   }
-\f
+
   /* The vector should be sorted for faster comparison. */
 
   Max = NUMBER_OF_UNDEFINED_PRIMITIVES();
@@ -334,10 +336,10 @@ find_primitive(Name, intern_p, arity, check_p)
 
       if (string_equal(Name, *Next++))
       {
-       if (check_p)
+       if (arity != UNKNOWN_PRIMITIVE_ARITY)
        {
          temp = User_Vector_Ref(Undefined_Primitives_Arity, i);
-         if ((temp == NIL) && (arity != UNKNOWN_PRIMITIVE_ARITY))
+         if (temp == NIL)
          {
            User_Vector_Set(Undefined_Primitives_Arity,
                            i,
@@ -346,7 +348,7 @@ find_primitive(Name, intern_p, arity, check_p)
          else
          {
            Sign_Extend(temp, old_arity);
-           if ((arity != UNKNOWN_PRIMITIVE_ARITY) && (arity != old_arity))
+           if (arity != old_arity)
            {
              return (temp);
            }
@@ -359,9 +361,14 @@ find_primitive(Name, intern_p, arity, check_p)
 \f
   /*
     Intern the primitive name by adding it to the vector of
-    undefined primitives.
+    undefined primitives, if interning is allowed.
    */
 
+  if (!intern_p)
+  {
+    return (NIL);
+  }
+
   if ((Max % CHUNK_SIZE) == 0)
   {
     Primitive_GC_If_Needed(2 * (Max + CHUNK_SIZE + 2));
@@ -392,7 +399,7 @@ find_primitive(Name, intern_p, arity, check_p)
     {
       *Free++ = Fetch(*Next++);
     }
-    *Free++ = ((check_p && (arity != UNKNOWN_PRIMITIVE_ARITY)) ?
+    *Free++ = ((arity != UNKNOWN_PRIMITIVE_ARITY) ?
               (MAKE_SIGNED_FIXNUM(arity)) :
               NIL);
     for (i = 1; i < CHUNK_SIZE; i++)
@@ -405,7 +412,7 @@ find_primitive(Name, intern_p, arity, check_p)
   {
     Max += 1;
     User_Vector_Set(Undefined_Primitives, Max, Name);
-    if (check_p && (arity != UNKNOWN_PRIMITIVE_ARITY))
+    if (arity != UNKNOWN_PRIMITIVE_ARITY)
     {
       User_Vector_Set(Undefined_Primitives_Arity,
                      Max,
@@ -560,7 +567,7 @@ install_primitive_table(table, length, flush_p)
     table += 1;
     result =
       find_primitive(Make_Pointer(TC_CHARACTER_STRING, table),
-                    true, arity, true);
+                    true, true, arity);
     if (OBJECT_TYPE(result) != TC_PRIMITIVE)
     {
       Primitive_Error(ERR_WRONG_ARITY_PRIMITIVES);