From 833c316911c8959c5928139add74004f594ebccf Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 18 Nov 1987 00:09:22 +0000 Subject: [PATCH] Allow #T as a parameter make tohe microcode version of make-primitive-procedure. --- v7/src/microcode/extern.c | 18 ++++++++++++------ v7/src/microcode/primutl.c | 37 ++++++++++++++++++++++--------------- 2 files changed, 34 insertions(+), 21 deletions(-) diff --git a/v7/src/microcode/extern.c b/v7/src/microcode/extern.c index 5afee8cfe..faf5659eb 100644 --- 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 c118d1226..2c2bdf86b 100644 --- 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)); } -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) + + /* Search the undefined primitives table if allowed. */ + + if (!allow_p) { return (NIL); } - + /* 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) /* 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); -- 2.25.1