From: Chris Hanson Date: Sat, 1 Jan 2005 05:44:12 +0000 (+0000) Subject: Add symbol-creating procedures to extern.h. X-Git-Tag: 20090517-FFI~1403 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2f731ac6c39d8cf545786d1cc96d6f9b9fdfe1c6;p=mit-scheme.git Add symbol-creating procedures to extern.h. --- diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index 83c2d7152..c9e521d35 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,10 +1,10 @@ /* -*-C-*- -$Id: boot.c,v 9.117 2004/03/09 03:46:42 cph Exp $ +$Id: boot.c,v 9.118 2005/01/01 05:43:57 cph Exp $ Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology Copyright 1992,1993,1994,1995,1996,1997 Massachusetts Institute of Technology -Copyright 2000,2001,2002,2003,2004 Massachusetts Institute of Technology +Copyright 2000,2001,2002,2003,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -44,7 +44,6 @@ extern void EXFUN (Setup_Memory, (int, int, int)); extern void EXFUN (compiler_initialize, (long fasl_p)); extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int)); extern void EXFUN (OS_announcement, (void)); -extern SCHEME_OBJECT EXFUN (char_pointer_to_symbol, (unsigned char *)); static void EXFUN (Start_Scheme, (int, CONST char *)); static void EXFUN (Enter_Interpreter, (void)); diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h index 58e225aa4..d51c0e55a 100644 --- a/v7/src/microcode/extern.h +++ b/v7/src/microcode/extern.h @@ -1,8 +1,10 @@ /* -*-C-*- -$Id: extern.h,v 9.64 2003/02/14 18:28:18 cph Exp $ +$Id: extern.h,v 9.65 2005/01/01 05:44:05 cph Exp $ -Copyright (c) 1987-2002 Massachusetts Institute of Technology +Copyright 1986,1987,1988,1989,1990,1991 Massachusetts Institute of Technology +Copyright 1992,1993,1995,1996,1997,2000 Massachusetts Institute of Technology +Copyright 2001,2002,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -217,6 +219,13 @@ extern SCHEME_OBJECT EXFUN extern SCHEME_OBJECT EXFUN (char_pointer_to_string, (CONST unsigned char *)); extern SCHEME_OBJECT EXFUN (char_pointer_to_string_no_gc, (CONST unsigned char *)); +extern CONST char * EXFUN (arg_symbol, (int)); +extern CONST char * EXFUN (arg_interned_symbol, (int)); +extern SCHEME_OBJECT EXFUN (string_to_symbol, (SCHEME_OBJECT)); +extern SCHEME_OBJECT EXFUN (char_pointer_to_symbol, (CONST char *)); +extern SCHEME_OBJECT EXFUN (memory_to_symbol, (unsigned long, CONST char *)); +extern SCHEME_OBJECT EXFUN (find_symbol, (unsigned long, CONST char *)); + /* Random and OS utilities */ extern Boolean EXFUN (Restore_History, (SCHEME_OBJECT)); diff --git a/v7/src/microcode/intern.c b/v7/src/microcode/intern.c index b4771a9ee..283e908f5 100644 --- a/v7/src/microcode/intern.c +++ b/v7/src/microcode/intern.c @@ -1,8 +1,9 @@ /* -*-C-*- -$Id: intern.c,v 9.60 2004/11/21 04:18:14 cph Exp $ +$Id: intern.c,v 9.61 2005/01/01 05:44:12 cph Exp $ -Copyright (c) 1987-2000 Massachusetts Institute of Technology +Copyright 1987,1988,1989,1992,1994,1996 Massachusetts Institute of Technology +Copyright 2000,2004,2005 Massachusetts Institute of Technology This file is part of MIT/GNU Scheme. @@ -34,13 +35,6 @@ USA. #else extern int EXFUN (strlen, (const char *)); #endif - -/* These are exported to other parts of the system. */ - -extern SCHEME_OBJECT EXFUN (string_to_symbol, (SCHEME_OBJECT)); -extern SCHEME_OBJECT EXFUN (char_pointer_to_symbol, (unsigned char *)); -extern SCHEME_OBJECT EXFUN (memory_to_symbol, (long, unsigned char *)); -extern SCHEME_OBJECT EXFUN (find_symbol, (long, unsigned char *)); /* Hashing strings */ @@ -48,87 +42,63 @@ extern SCHEME_OBJECT EXFUN (find_symbol, (long, unsigned char *)); static unsigned int DEFUN (string_hash, (length, string), - long length AND unsigned char * string) + unsigned long length AND + CONST char * string) { - fast unsigned char * scan = string; - fast unsigned char * end = (scan + length); - fast unsigned int result = 0; + CONST char * scan = string; + CONST char * end = (scan + length); + unsigned int result = 0; while (scan < end) - { - result <<= 1; - result |= (result >> STRING_HASH_BITS); - result ^= (*scan++); - result &= ((1 << STRING_HASH_BITS) - 1); - } + { + result <<= 1; + result |= (result >> STRING_HASH_BITS); + result ^= (*scan++); + result &= ((1 << STRING_HASH_BITS) - 1); + } return (result); } -static Boolean -DEFUN (string_equal, (length1, string1, length2, string2), - long length1 AND unsigned char * string1 - AND long length2 AND unsigned char * string2) -{ - fast unsigned char * scan1 = string1; - fast unsigned char * scan2 = string2; - fast long length = length1; - fast unsigned char * end1 = (scan1 + length); - if (scan1 == scan2) - return (true); - if (length != length2) - return (false); - while (scan1 < end1) - if ((*scan1++) != (*scan2++)) - return (false); - return (true); -} - static SCHEME_OBJECT * DEFUN (find_symbol_internal, (length, string), - long length AND unsigned char * string) + unsigned long length AND + CONST char * string) { - fast SCHEME_OBJECT * bucket; - { - fast SCHEME_OBJECT obarray = (Get_Fixed_Obj_Slot (OBArray)); - bucket = - (MEMORY_LOC (obarray, + SCHEME_OBJECT obarray = (Get_Fixed_Obj_Slot (OBArray)); + SCHEME_OBJECT * bucket + = (MEMORY_LOC (obarray, (((string_hash (length, string)) % (VECTOR_LENGTH (obarray))) + 1))); - } while (!EMPTY_LIST_P (*bucket)) { - fast SCHEME_OBJECT symbol = (PAIR_CAR (*bucket)); - fast SCHEME_OBJECT name = (FAST_MEMORY_REF (symbol, SYMBOL_NAME)); - if (string_equal (length, string, - (STRING_LENGTH (name)), (STRING_LOC (name, 0)))) + SCHEME_OBJECT symbol = (PAIR_CAR (*bucket)); + SCHEME_OBJECT name = (FAST_MEMORY_REF (symbol, SYMBOL_NAME)); + if (((STRING_LENGTH (name)) == length) + && ((memcmp ((STRING_LOC (name, 0)), string, length)) == 0)) return (PAIR_CAR_LOC (*bucket)); bucket = (PAIR_CDR_LOC (*bucket)); } return (bucket); } + +CONST char * +DEFUN (arg_symbol, (n), int n) +{ + CHECK_ARG (n, SYMBOL_P); + return (STRING_LOC ((FAST_MEMORY_REF ((ARG_REF (n)), SYMBOL_NAME)), 0)); +} -/* Set this to be informed of symbols as they are interned. */ -void EXFUN ((*intern_symbol_hook), (SCHEME_OBJECT)) = 0; - -static SCHEME_OBJECT -DEFUN (link_new_symbol, (symbol, cell), - SCHEME_OBJECT symbol - AND SCHEME_OBJECT * cell) +CONST char * +DEFUN (arg_interned_symbol, (n), int n) { - /* `symbol' does not exist yet in obarray. `cell' points to the - cell containing the final '() in the list. Replace this - with a cons of the new symbol and '() (i.e. extend the - list in the bucket by 1 new element). */ - - fast SCHEME_OBJECT result = (OBJECT_NEW_TYPE (TC_INTERNED_SYMBOL, symbol)); - (*cell) = (cons (result, EMPTY_LIST)); - if (intern_symbol_hook != ((void (*) ()) 0)) - (*intern_symbol_hook) (result); - return (result); + CHECK_ARG (n, SYMBOL_P); + return (STRING_LOC ((FAST_MEMORY_REF ((ARG_REF (n)), SYMBOL_NAME)), 0)); } - + SCHEME_OBJECT -DEFUN (find_symbol, (length, string), long length AND unsigned char * string) +DEFUN (find_symbol, (length, string), + unsigned long length AND + CONST char * string) { SCHEME_OBJECT result = (* (find_symbol_internal (length, string))); return ((EMPTY_LIST_P (result)) ? SHARP_F : result); @@ -139,20 +109,21 @@ DEFUN (make_symbol, (string, cell), SCHEME_OBJECT string AND SCHEME_OBJECT * cell) { - Primitive_GC_If_Needed (2); + Primitive_GC_If_Needed (4); { - SCHEME_OBJECT symbol = (MAKE_POINTER_OBJECT (TC_UNINTERNED_SYMBOL, Free)); - (Free [SYMBOL_NAME]) = string; - (Free [SYMBOL_GLOBAL_VALUE]) = UNBOUND_OBJECT; + SCHEME_OBJECT symbol = (MAKE_POINTER_OBJECT (TC_INTERNED_SYMBOL, Free)); + (Free[SYMBOL_NAME]) = string; + (Free[SYMBOL_GLOBAL_VALUE]) = UNBOUND_OBJECT; Free += 2; - return (link_new_symbol (symbol, cell)); + (*cell) = (cons (symbol, EMPTY_LIST)); + return (symbol); } } SCHEME_OBJECT DEFUN (memory_to_symbol, (length, string), - long length AND - unsigned char * string) + unsigned long length AND + CONST char * string) { SCHEME_OBJECT * cell = (find_symbol_internal (length, string)); return @@ -162,7 +133,7 @@ DEFUN (memory_to_symbol, (length, string), } SCHEME_OBJECT -DEFUN (char_pointer_to_symbol, (string), unsigned char * string) +DEFUN (char_pointer_to_symbol, (string), CONST char * string) { return (memory_to_symbol ((strlen (string)), string)); } @@ -170,9 +141,9 @@ DEFUN (char_pointer_to_symbol, (string), unsigned char * string) SCHEME_OBJECT DEFUN (string_to_symbol, (string), SCHEME_OBJECT string) { - SCHEME_OBJECT * cell = - (find_symbol_internal ((STRING_LENGTH (string)), - (STRING_LOC (string, 0)))); + SCHEME_OBJECT * cell + = (find_symbol_internal ((STRING_LENGTH (string)), + (STRING_LOC (string, 0)))); return ((EMPTY_LIST_P (*cell)) ? (make_symbol (string, cell)) : (*cell)); } @@ -180,24 +151,29 @@ SCHEME_OBJECT DEFUN (intern_symbol, (symbol), SCHEME_OBJECT symbol) { SCHEME_OBJECT name = (FAST_MEMORY_REF (symbol, SYMBOL_NAME)); - SCHEME_OBJECT * cell = - (find_symbol_internal ((STRING_LENGTH (name)), (STRING_LOC (name, 0)))); - return ((EMPTY_LIST_P (*cell)) - ? (link_new_symbol (symbol, cell)) - : (*cell)); + SCHEME_OBJECT * cell + = (find_symbol_internal ((STRING_LENGTH (name)), (STRING_LOC (name, 0)))); + if (!EMPTY_LIST_P (*cell)) + return (*cell); + else + { + SCHEME_OBJECT result = (OBJECT_NEW_TYPE (TC_INTERNED_SYMBOL, symbol)); + (*cell) = (cons (result, EMPTY_LIST)); + return (result); + } } DEFINE_PRIMITIVE ("FIND-SYMBOL", Prim_find_symbol, 1, 1, "(FIND-SYMBOL STRING)\n\ Returns the symbol whose name is STRING, or #F if no such symbol exists.") { - SCHEME_OBJECT string; PRIMITIVE_HEADER (1); - CHECK_ARG (1, STRING_P); - string = (ARG_REF (1)); - PRIMITIVE_RETURN - (find_symbol ((STRING_LENGTH (string)), (STRING_LOC (string, 0)))); + { + SCHEME_OBJECT string = (ARG_REF (1)); + PRIMITIVE_RETURN + (find_symbol ((STRING_LENGTH (string)), (STRING_LOC (string, 0)))); + } } DEFINE_PRIMITIVE ("STRING->SYMBOL", Prim_string_to_symbol, 1, 1, @@ -205,7 +181,6 @@ DEFINE_PRIMITIVE ("STRING->SYMBOL", Prim_string_to_symbol, 1, 1, Returns the symbol whose name is STRING, constructing a new symbol if needed.") { PRIMITIVE_HEADER (1); - CHECK_ARG (1, STRING_P); PRIMITIVE_RETURN (string_to_symbol (ARG_REF (1))); } @@ -213,32 +188,32 @@ Returns the symbol whose name is STRING, constructing a new symbol if needed.") DEFINE_PRIMITIVE ("STRING-HASH", Prim_string_hash, 1, 1, "(STRING-HASH STRING)\n\ Return a hash value for a string. This uses the hashing\n\ -algorithm used for interning symbols. It is intended for use by\n\ +algorithm for interning symbols. It is intended for use by\n\ the reader in creating interned symbols.") { - SCHEME_OBJECT string; PRIMITIVE_HEADER (1); - CHECK_ARG (1, STRING_P); - string = (ARG_REF (1)); - PRIMITIVE_RETURN - (LONG_TO_UNSIGNED_FIXNUM (string_hash ((STRING_LENGTH (string)), - (STRING_LOC (string, 0))))); + { + SCHEME_OBJECT string = (ARG_REF (1)); + PRIMITIVE_RETURN + (LONG_TO_UNSIGNED_FIXNUM (string_hash ((STRING_LENGTH (string)), + (STRING_LOC (string, 0))))); + } } DEFINE_PRIMITIVE ("STRING-HASH-MOD", Prim_string_hash_mod, 2, 2, "(STRING-HASH-MOD STRING DENOMINATOR)\n\ DENOMINATOR must be a nonnegative integer.\n\ -Equivalent to (MOD (STRING-HASH STRING) DENOMINATOR).") +Equivalent to (MODULO (STRING-HASH STRING) DENOMINATOR).") { - SCHEME_OBJECT string; PRIMITIVE_HEADER (2); - CHECK_ARG (1, STRING_P); - string = (ARG_REF (1)); - PRIMITIVE_RETURN - (LONG_TO_UNSIGNED_FIXNUM - ((string_hash ((STRING_LENGTH (string)), - (STRING_LOC (string, 0)))) - % (arg_nonnegative_integer (2)))); + { + SCHEME_OBJECT string = (ARG_REF (1)); + PRIMITIVE_RETURN + (LONG_TO_UNSIGNED_FIXNUM + ((string_hash ((STRING_LENGTH (string)), + (STRING_LOC (string, 0)))) + % (arg_ulong_integer (2)))); + } }