From 162a1cf286b203d7dfe1bf1c690f168095f2903d Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 18 Nov 1987 19:31:34 +0000 Subject: [PATCH] Some changes for primitives accessed specially from compiled code (arithmetic). --- v7/src/microcode/boot.c | 21 ++++++++----- v7/src/microcode/primutl.c | 64 +++++++++++++++++++++++++------------- v7/src/microcode/version.h | 4 +-- v8/src/microcode/version.h | 4 +-- 4 files changed, 60 insertions(+), 33 deletions(-) diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index 55a6d1949..285ce2db1 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.40 1987/11/17 08:07:35 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.41 1987/11/18 19:31:34 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -412,27 +412,34 @@ Start_Scheme(Start_Prim, File_Name) depending on the value of Start_Prim. */ - FName = C_String_To_Scheme_String(File_Name); - Fasload_Call = Free; switch (Start_Prim) { case BOOT_FASLOAD: /* (SCODE-EVAL (BINARY-FASLOAD ) GLOBAL-ENV) */ - *Free++ = make_primitive("BINARY-FASLOAD"); + FName = C_String_To_Scheme_String(File_Name); + prim = make_primitive("BINARY-FASLOAD"); + Fasload_Call = Free; + *Free++ = prim; *Free++ = FName; + prim = make_primitive("SCODE-EVAL"); Init_Prog = Make_Pointer(TC_PCOMB2, Free); - *Free++ = make_primitive("SCODE-EVAL"); + *Free++ = prim; *Free++ = Make_Pointer(TC_PCOMB1, Fasload_Call); *Free++ = Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL); break; case BOOT_LOAD_BAND: /* (LOAD-BAND ) */ - *Free++ = make_primitive("LOAD-BAND"); + FName = C_String_To_Scheme_String(File_Name); + prim = make_primitive("LOAD-BAND"); + Fasload_Call = Free; + *Free++ = prim; *Free++ = FName; Init_Prog = Make_Pointer(TC_PCOMB1, Fasload_Call); break; case BOOT_GET_WORK: /* ((GET-WORK)) */ - *Free++ = make_primitive("GET-WORK"); + prim = make_primitive("GET-WORK"); + Fasload_Call = Free; + *Free++ = prim; *Free++ = NIL; Init_Prog = Make_Pointer(TC_COMBINATION, Free); *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 1); diff --git a/v7/src/microcode/primutl.c b/v7/src/microcode/primutl.c index 2c2bdf86b..53cc25159 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.42 1987/11/18 00:08:54 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/primutl.c,v 9.43 1987/11/18 19:30:52 jinx Exp $ * * This file contains the support routines for mapping primitive names * to numbers within the microcode. Primitives are written in C @@ -163,7 +163,7 @@ primitive_code_to_arity(code, table, size) return ((long) table[code]); } } - + /* Externally visible utilities */ extern Pointer make_primitive(); @@ -172,14 +172,24 @@ Pointer make_primitive(name) char *name; { - long i; + Pointer search_for_primitive(); - i = primitive_name_to_code(name, - &Primitive_Name_Table[0], - MAX_PRIMITIVE); - return ((i == ((long) -1)) ? - NIL : - Make_Non_Pointer(TC_PRIMITIVE, i)); + return (search_for_primitive(NIL, name, true, true, + UNKNOWN_PRIMITIVE_ARITY)); +} + +extern Pointer find_primitive(); + +Pointer +find_primitive(name, intern_p, allow_p, arity) + Pointer name; + Boolean intern_p, allow_p; + int arity; +{ + Pointer search_for_primitive(); + + return (search_for_primitive(name, Scheme_String_To_C_String(name), + intern_p, allow_p, arity)); } extern long primitive_to_arity(); @@ -288,19 +298,23 @@ primitive_name(code) return (string_to_symbol(scheme_string)); } -extern Pointer find_primitive(); +/* + scheme_name can be NIL, meaning cons up from c_name as needed. + c_name must always be provided. + */ Pointer -find_primitive(Name, intern_p, allow_p, arity) - Pointer Name; +search_for_primitive(scheme_name, c_name, intern_p, allow_p, arity) + Pointer scheme_name; + char *c_name; Boolean intern_p, allow_p; int arity; { - extern Boolean string_equal(); + extern int strcmp(); long i, Max, old_arity; Pointer *Next; - i = primitive_name_to_code(Scheme_String_To_C_String(Name), + i = primitive_name_to_code(c_name, &Primitive_Name_Table[0], MAX_PRIMITIVE); if (i != -1) @@ -315,14 +329,13 @@ find_primitive(Name, intern_p, allow_p, arity) return (MAKE_SIGNED_FIXNUM(old_arity)); } } - /* 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,7 +347,8 @@ find_primitive(Name, intern_p, allow_p, arity) { Pointer temp; - if (string_equal(Name, *Next++)) + temp = *Next++; + if (strcmp(c_name, Scheme_String_To_C_String(temp)) == 0) { if (arity != UNKNOWN_PRIMITIVE_ARITY) { @@ -358,7 +372,7 @@ find_primitive(Name, intern_p, allow_p, arity) } } } - + /* Intern the primitive name by adding it to the vector of undefined primitives, if interning is allowed. @@ -369,6 +383,11 @@ find_primitive(Name, intern_p, allow_p, arity) return (NIL); } + if (scheme_name == NIL) + { + scheme_name = C_String_To_Scheme_String(c_name); + } + if ((Max % CHUNK_SIZE) == 0) { Primitive_GC_If_Needed(2 * (Max + CHUNK_SIZE + 2)); @@ -383,7 +402,7 @@ find_primitive(Name, intern_p, allow_p, arity) { *Free++ = Fetch(*Next++); } - *Free++ = Name; + *Free++ = scheme_name; for (i = 1; i < CHUNK_SIZE; i++) { *Free++ = NIL; @@ -411,7 +430,7 @@ find_primitive(Name, intern_p, allow_p, arity) else { Max += 1; - User_Vector_Set(Undefined_Primitives, Max, Name); + User_Vector_Set(Undefined_Primitives, Max, scheme_name); if (arity != UNKNOWN_PRIMITIVE_ARITY) { User_Vector_Set(Undefined_Primitives_Arity, @@ -566,8 +585,9 @@ install_primitive_table(table, length, flush_p) Sign_Extend(*table, arity); table += 1; result = - find_primitive(Make_Pointer(TC_CHARACTER_STRING, table), - true, true, arity); + search_for_primitive(Make_Pointer(TC_CHARACTER_STRING, table), + ((char *) (&table[STRING_CHARS])), + true, true, arity); if (OBJECT_TYPE(result) != TC_PRIMITIVE) { Primitive_Error(ERR_WRONG_ARITY_PRIMITIVES); diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 79bdfbee9..ef9a38ec4 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 10.3 1987/11/17 08:21:22 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.4 1987/11/18 19:30:26 jinx Exp $ This file contains version information for the microcode. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 10 #endif #ifndef SUBVERSION -#define SUBVERSION 5 +#define SUBVERSION 6 #endif #ifndef UCODE_TABLES_FILENAME diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index 230eeb17c..041b1f2ef 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 10.3 1987/11/17 08:21:22 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.4 1987/11/18 19:30:26 jinx Exp $ This file contains version information for the microcode. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 10 #endif #ifndef SUBVERSION -#define SUBVERSION 5 +#define SUBVERSION 6 #endif #ifndef UCODE_TABLES_FILENAME -- 2.25.1