diff options
author | Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> | 2000-12-08 17:08:34 +0000 |
---|---|---|
committer | Dirk Herrmann <dirk@dirk-herrmanns-seiten.de> | 2000-12-08 17:08:34 +0000 |
commit | 38ae064c6e462bafc7e188b4586fb3e6eedec876 (patch) | |
tree | dc568f0be7bea98151cba817ca7b65cf8ad31eb0 | |
parent | 23ade5e759a010813491085ee63e0f9219715ba8 (diff) | |
download | guile-38ae064c6e462bafc7e188b4586fb3e6eedec876.tar.gz |
* Use scm_mem2symbol or scm_str2symbol to create symbol objects.
-rw-r--r-- | libguile/ChangeLog | 35 | ||||
-rw-r--r-- | libguile/feature.c | 2 | ||||
-rw-r--r-- | libguile/gh_data.c | 2 | ||||
-rw-r--r-- | libguile/goops.c | 143 | ||||
-rw-r--r-- | libguile/load.c | 2 | ||||
-rw-r--r-- | libguile/print.c | 2 | ||||
-rw-r--r-- | libguile/ramap.c | 2 | ||||
-rw-r--r-- | libguile/read.c | 14 | ||||
-rw-r--r-- | libguile/snarf.h | 4 | ||||
-rw-r--r-- | libguile/stacks.c | 3 | ||||
-rw-r--r-- | libguile/struct.c | 2 | ||||
-rw-r--r-- | libguile/symbols.c | 15 | ||||
-rw-r--r-- | libguile/throw.c | 2 | ||||
-rw-r--r-- | libguile/unif.c | 4 |
14 files changed, 127 insertions, 105 deletions
diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 13ef22727..94f730661 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,40 @@ 2000-12-08 Dirk Herrmann <D.Herrmann@tu-bs.de> + * feature.c (scm_add_feature), gh_data.c (gh_symbol2scm), goops.c + (scm_sys_prep_layout_x, scm_make_class, scm_add_slot, + scm_init_goops), load.c (init_build_info), print.c + (scm_init_print), read.c (scm_lreadr), snarf.h (SCM_SYMBOL, + SCM_GLOBAL_SYMBOL), stacks.c (scm_init_stacks), struct.c + (scm_make_struct_layout), symbols.c (scm_sysintern0, + scm_string_to_symbol, scm_gensym), throw.c + (scm_handle_by_message): Use scm_mem2symbol or scm_str2symbol + instead of scm_intern_* to create a symbol object. + + * goops.c (Intern): Removed. + + (CALL_GF1, CALL_GF2, CALL_GF3, CALL_GF4, build_class_class_slots, + create_basic_classes, scm_class_name, scm_class_direct_supers, + scm_class_direct_slots, scm_class_direct_subclasses, + scm_class_direct_methods, scm_class_precedence_list, + scm_class_slots, scm_class_environment, + scm_generic_function_methods, scm_method_generic_function, + scm_method_specializers, scm_method_procedure, + scm_accessor_method_slot_definition, purgatory, scm_make, + make_stdcls, create_standard_classes, make_class_from_template, + scm_make_class): Replaced calls to Intern with calls to + scm_str2symbol. + + * ramap.c (init_raprocs): Use scm_symbol_binding instead of + scm_intern. + + * symbols.c (scm_sym2vcell): Add a bogus return to avoid compiler + warnings. + + * unif.c (scm_array_prototype): Fix prototype return value for + svects and llvects. + +2000-12-08 Dirk Herrmann <D.Herrmann@tu-bs.de> + * symbols.[ch] (scm_mem2symbol, scm_str2symbol): New functions. These shall replace all those calls to scm_intern... which are only required to create a scheme symbol from a C string or a field diff --git a/libguile/feature.c b/libguile/feature.c index bd9c94aed..4b4320901 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -65,7 +65,7 @@ void scm_add_feature (const char *str) { SCM old = SCM_CDR (features); - SCM new = scm_cons (SCM_CAR (scm_intern (str, strlen (str))), old); + SCM new = scm_cons (scm_str2symbol (str), old); SCM_SETCDR (features, new); } diff --git a/libguile/gh_data.c b/libguile/gh_data.c index a65f75efa..f7e74e5af 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -129,7 +129,7 @@ gh_set_substr (char *src, SCM dst, int start, int len) SCM gh_symbol2scm (const char *symbol_str) { - return SCM_CAR (scm_intern (symbol_str, strlen (symbol_str))); + return scm_str2symbol(symbol_str); } SCM diff --git a/libguile/goops.c b/libguile/goops.c index 470d14616..18db4aebf 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -89,20 +89,15 @@ #define GETVAR(v) (SCM_CDDR (scm_apply (scm_goops_lookup_closure, \ SCM_LIST2 ((v), SCM_BOOL_F), \ SCM_EOL))) -static SCM -Intern (const char *s) -{ - return SCM_CAR (scm_intern (s, strlen (s))); -} /* Fixme: Should use already interned symbols */ -#define CALL_GF1(name,a) (scm_apply (GETVAR (Intern(name)), \ +#define CALL_GF1(name,a) (scm_apply (GETVAR (scm_str2symbol (name)), \ SCM_LIST1 (a), SCM_EOL)) -#define CALL_GF2(name,a,b) (scm_apply (GETVAR (Intern(name)), \ +#define CALL_GF2(name,a,b) (scm_apply (GETVAR (scm_str2symbol (name)), \ SCM_LIST2 (a, b), SCM_EOL)) -#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (Intern(name)), \ +#define CALL_GF3(name,a,b,c) (scm_apply (GETVAR (scm_str2symbol (name)), \ SCM_LIST3 (a, b, c), SCM_EOL)) -#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (Intern(name)), \ +#define CALL_GF4(name,a,b,c,d) (scm_apply (GETVAR (scm_str2symbol (name)), \ SCM_LIST4 (a, b, c, d), SCM_EOL)) /* Class redefinition protocol: @@ -548,7 +543,7 @@ scm_sys_prep_layout_x (SCM class) s[i + 1] = a; slots = SCM_CDR (slots); } - SCM_SLOT (class, scm_si_layout) = SCM_CAR (scm_intern (s, n)); + SCM_SLOT (class, scm_si_layout) = scm_mem2symbol (s, n); if (s) scm_must_free (s); return SCM_UNSPECIFIED; @@ -685,59 +680,59 @@ static SCM build_class_class_slots () { return maplist ( - scm_cons (SCM_LIST3 (Intern ("layout"), + scm_cons (SCM_LIST3 (scm_str2symbol ("layout"), k_class, scm_class_protected_read_only), - scm_cons (SCM_LIST3 (Intern ("vcell"), + scm_cons (SCM_LIST3 (scm_str2symbol ("vcell"), k_class, scm_class_opaque), - scm_cons (SCM_LIST3 (Intern ("vtable"), + scm_cons (SCM_LIST3 (scm_str2symbol ("vtable"), k_class, scm_class_self), - scm_cons (Intern ("print"), - scm_cons (SCM_LIST3 (Intern ("procedure"), + scm_cons (scm_str2symbol ("print"), + scm_cons (SCM_LIST3 (scm_str2symbol ("procedure"), k_class, scm_class_protected_opaque), - scm_cons (SCM_LIST3 (Intern ("setter"), + scm_cons (SCM_LIST3 (scm_str2symbol ("setter"), k_class, scm_class_protected_opaque), - scm_cons (Intern ("redefined"), - scm_cons (SCM_LIST3 (Intern ("h0"), + scm_cons (scm_str2symbol ("redefined"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h0"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h1"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h1"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h2"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h2"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h3"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h3"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h4"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h4"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h5"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h5"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h6"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h6"), k_class, scm_class_int), - scm_cons (SCM_LIST3 (Intern ("h7"), + scm_cons (SCM_LIST3 (scm_str2symbol ("h7"), k_class, scm_class_int), - scm_cons (Intern ("name"), - scm_cons (Intern ("direct-supers"), - scm_cons (Intern ("direct-slots"), - scm_cons (Intern ("direct-subclasses"), - scm_cons (Intern ("direct-methods"), - scm_cons (Intern ("cpl"), - scm_cons (Intern ("default-slot-definition-class"), - scm_cons (Intern ("slots"), - scm_cons (Intern ("getters-n-setters"), /* name-access */ - scm_cons (Intern ("keyword-access"), - scm_cons (Intern ("nfields"), - scm_cons (Intern ("environment"), + scm_cons (scm_str2symbol ("name"), + scm_cons (scm_str2symbol ("direct-supers"), + scm_cons (scm_str2symbol ("direct-slots"), + scm_cons (scm_str2symbol ("direct-subclasses"), + scm_cons (scm_str2symbol ("direct-methods"), + scm_cons (scm_str2symbol ("cpl"), + scm_cons (scm_str2symbol ("default-slot-definition-class"), + scm_cons (scm_str2symbol ("slots"), + scm_cons (scm_str2symbol ("getters-n-setters"), /* name-access */ + scm_cons (scm_str2symbol ("keyword-access"), + scm_cons (scm_str2symbol ("nfields"), + scm_cons (scm_str2symbol ("environment"), SCM_EOL)))))))))))))))))))))))))))); } @@ -749,7 +744,7 @@ create_basic_classes (void) /**** <scm_class_class> ****/ SCM cs = scm_makfrom0str (SCM_CLASS_CLASS_LAYOUT + 2 * scm_vtable_offset_user); - SCM name = Intern ("<class>"); + SCM name = scm_str2symbol ("<class>"); scm_class_class = scm_permanent_object (scm_make_vtable_vtable (cs, SCM_INUM0, SCM_EOL)); @@ -775,7 +770,7 @@ create_basic_classes (void) DEFVAR(name, scm_class_class); /**** <scm_class_top> ****/ - name = Intern ("<top>"); + name = scm_str2symbol ("<top>"); scm_class_top = scm_permanent_object (scm_basic_make_class (scm_class_class, name, SCM_EOL, @@ -784,7 +779,7 @@ create_basic_classes (void) DEFVAR(name, scm_class_top); /**** <scm_class_object> ****/ - name = Intern("<object>"); + name = scm_str2symbol ("<object>"); scm_class_object = scm_permanent_object (scm_basic_make_class (scm_class_class, name, SCM_LIST1 (scm_class_top), @@ -823,7 +818,7 @@ SCM scm_class_name (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_name); - return scm_slot_ref (obj, Intern ("name")); + return scm_slot_ref (obj, scm_str2symbol ("name")); } SCM_PROC (s_class_direct_supers, "class-direct-supers", 1, 0, 0, scm_class_direct_supers); @@ -832,7 +827,7 @@ SCM scm_class_direct_supers (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_supers); - return scm_slot_ref (obj, Intern("direct-supers")); + return scm_slot_ref (obj, scm_str2symbol ("direct-supers")); } SCM_PROC (s_class_direct_slots, "class-direct-slots", 1, 0, 0, scm_class_direct_slots); @@ -842,7 +837,7 @@ scm_class_direct_slots (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_slots); - return scm_slot_ref (obj, Intern ("direct-slots")); + return scm_slot_ref (obj, scm_str2symbol ("direct-slots")); } SCM_PROC (s_class_direct_subclasses, "class-direct-subclasses", 1, 0, 0, scm_class_direct_subclasses); @@ -852,7 +847,7 @@ scm_class_direct_subclasses (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_subclasses); - return scm_slot_ref(obj, Intern ("direct-subclasses")); + return scm_slot_ref(obj, scm_str2symbol ("direct-subclasses")); } SCM_PROC (s_class_direct_methods, "class-direct-methods", 1, 0, 0, scm_class_direct_methods); @@ -862,7 +857,7 @@ scm_class_direct_methods (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_methods); - return scm_slot_ref (obj, Intern("direct-methods")); + return scm_slot_ref (obj, scm_str2symbol ("direct-methods")); } SCM_PROC (s_class_direct_precedence_list, "class-precedence-list", 1, 0, 0, scm_class_precedence_list); @@ -872,7 +867,7 @@ scm_class_precedence_list (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_direct_precedence_list); - return scm_slot_ref (obj, Intern ("cpl")); + return scm_slot_ref (obj, scm_str2symbol ("cpl")); } SCM_PROC (s_class_slots, "class-slots", 1, 0, 0, scm_class_slots); @@ -882,7 +877,7 @@ scm_class_slots (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_slots); - return scm_slot_ref (obj, Intern ("slots")); + return scm_slot_ref (obj, scm_str2symbol ("slots")); } SCM_PROC (s_class_environment, "class-environment", 1, 0, 0, scm_class_environment); @@ -892,7 +887,7 @@ scm_class_environment (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && CLASSP (obj), obj, SCM_ARG1, s_class_environment); - return scm_slot_ref(obj, Intern ("environment")); + return scm_slot_ref(obj, scm_str2symbol ("environment")); } @@ -913,7 +908,7 @@ scm_generic_function_methods (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && GENERICP (obj), obj, SCM_ARG1, s_generic_function_methods); - return scm_slot_ref (obj, Intern ("methods")); + return scm_slot_ref (obj, scm_str2symbol ("methods")); } @@ -924,7 +919,7 @@ scm_method_generic_function (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), obj, SCM_ARG1, s_method_generic_function); - return scm_slot_ref (obj, Intern ("generic-function")); + return scm_slot_ref (obj, scm_str2symbol ("generic-function")); } SCM_PROC (s_method_specializers, "method-specializers", 1, 0, 0, scm_method_specializers); @@ -934,7 +929,7 @@ scm_method_specializers (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), obj, SCM_ARG1, s_method_specializers); - return scm_slot_ref (obj, Intern ("specializers")); + return scm_slot_ref (obj, scm_str2symbol ("specializers")); } SCM_PROC (s_method_procedure, "method-procedure", 1, 0, 0, scm_method_procedure); @@ -944,7 +939,7 @@ scm_method_procedure (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && METHODP (obj), obj, SCM_ARG1, s_method_procedure); - return scm_slot_ref (obj, Intern ("procedure")); + return scm_slot_ref (obj, scm_str2symbol ("procedure")); } SCM_PROC (s_accessor_method_slot_definition, "accessor-method-slot-definition", 1, 0, 0, scm_accessor_method_slot_definition); @@ -954,7 +949,7 @@ scm_accessor_method_slot_definition (SCM obj) { SCM_ASSERT (SCM_NIMP (obj) && SCM_ACCESSORP (obj), obj, SCM_ARG1, s_method_procedure); - return scm_slot_ref (obj, Intern ("slot-definition")); + return scm_slot_ref (obj, scm_str2symbol ("slot-definition")); } @@ -1529,7 +1524,7 @@ go_to_heaven (void *o) static SCM purgatory (void *args) { - return scm_apply (GETVAR (Intern ("change-class")), (SCM) args, SCM_EOL); + return scm_apply (GETVAR (scm_str2symbol ("change-class")), (SCM) args, SCM_EOL); } void @@ -2064,7 +2059,7 @@ scm_make (SCM args) scm_i_get_keyword (k_name, args, len - 1, - Intern ("???"), + scm_str2symbol ("???"), s_make); SCM_SLOT (z, scm_si_direct_supers) = scm_i_get_keyword (k_dsupers, @@ -2142,7 +2137,7 @@ scm_sys_method_more_specific_p (SCM m1, SCM m2, SCM targs) static void make_stdcls (SCM *var, char *name, SCM meta, SCM super, SCM slots) { - SCM tmp = Intern(name); + SCM tmp = scm_str2symbol (name); *var = scm_permanent_object (scm_basic_make_class (meta, tmp, @@ -2160,26 +2155,26 @@ static void create_standard_classes (void) { SCM slots; - SCM method_slots = SCM_LIST4 (Intern ("generic-function"), - Intern ("specializers"), - Intern ("procedure"), - Intern ("code-table")); - SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (Intern ("slot-definition"), + SCM method_slots = SCM_LIST4 (scm_str2symbol ("generic-function"), + scm_str2symbol ("specializers"), + scm_str2symbol ("procedure"), + scm_str2symbol ("code-table")); + SCM amethod_slots = SCM_LIST1 (SCM_LIST3 (scm_str2symbol ("slot-definition"), k_init_keyword, k_slot_definition)); #ifdef USE_THREADS - SCM mutex_slot = SCM_LIST1 (Intern ("make-mutex")); + SCM mutex_slot = SCM_LIST1 (scm_str2symbol ("make-mutex")); #else SCM mutex_slot = SCM_BOOL_F; #endif - SCM gf_slots = SCM_LIST4 (Intern ("methods"), - SCM_LIST3 (Intern ("n-specialized"), + SCM gf_slots = SCM_LIST4 (scm_str2symbol ("methods"), + SCM_LIST3 (scm_str2symbol ("n-specialized"), k_init_value, SCM_INUM0), - SCM_LIST3 (Intern ("used-by"), + SCM_LIST3 (scm_str2symbol ("used-by"), k_init_value, SCM_BOOL_F), - SCM_LIST3 (Intern ("cache-mutex"), + SCM_LIST3 (scm_str2symbol ("cache-mutex"), k_init_thunk, scm_closure (SCM_LIST2 (SCM_EOL, mutex_slot), @@ -2225,10 +2220,10 @@ create_standard_classes (void) make_stdcls (&scm_class_foreign_class, "<foreign-class>", scm_class_class, scm_class_class, - SCM_LIST2 (SCM_LIST3 (Intern ("constructor"), + SCM_LIST2 (SCM_LIST3 (scm_str2symbol ("constructor"), k_class, scm_class_opaque), - SCM_LIST3 (Intern ("destructor"), + SCM_LIST3 (scm_str2symbol ("destructor"), k_class, scm_class_opaque))); make_stdcls (&scm_class_foreign_object, "<foreign-object>", @@ -2336,7 +2331,7 @@ make_class_from_template (char *template, char *type_name, SCM supers) { char buffer[100]; sprintf (buffer, template, type_name); - name = Intern (buffer); + name = scm_str2symbol (buffer); } else name = SCM_GOOPS_UNBOUND; @@ -2481,7 +2476,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, size_t (*destructor) (void *)) { SCM name, class; - name = Intern (s_name); + name = scm_str2symbol (s_name); if (SCM_IMP (supers)) supers = SCM_LIST1 (scm_class_foreign_object); class = scm_basic_basic_make_class (meta, name, supers, SCM_EOL); @@ -2498,7 +2493,7 @@ scm_make_class (SCM meta, char *s_name, SCM supers, size_t size, SCM_SET_CLASS_INSTANCE_SIZE (class, size); } - SCM_SLOT (class, scm_si_layout) = SCM_CAR (scm_intern ("", 0)); + SCM_SLOT (class, scm_si_layout) = scm_str2symbol (""); SCM_SLOT (class, scm_si_constructor) = (SCM) constructor; return class; @@ -2534,8 +2529,8 @@ scm_add_slot (SCM class, char *slot_name, SCM slot_class, SCM_LIST3 (set, sym_o, sym_x)), SCM_EOL); { - SCM name = SCM_CAR (scm_intern0 (slot_name)); - SCM aname = SCM_CAR (scm_intern0 (accessor_name)); + SCM name = scm_str2symbol (slot_name); + SCM aname = scm_str2symbol (accessor_name); SCM gf = scm_ensure_accessor (aname); SCM slot = SCM_LIST5 (name, k_class, slot_class, @@ -2692,7 +2687,7 @@ scm_init_goops (void) create_port_classes (); { - SCM name = SCM_CAR (scm_intern0 ("no-applicable-method")); + SCM name = scm_str2symbol ("no-applicable-method"); scm_no_applicable_method = scm_permanent_object (scm_make (SCM_LIST3 (scm_class_generic, k_name, diff --git a/libguile/load.c b/libguile/load.c index 162d338d4..fee5e1893 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -496,7 +496,7 @@ init_build_info () unsigned int i; for (i = 0; i < (sizeof (info) / sizeof (info[0])); i++) - *loc = scm_acons (SCM_CAR (scm_intern0 (info[i].name)), + *loc = scm_acons (scm_str2symbol (info[i].name), scm_makfrom0str (info[i].value), *loc); } diff --git a/libguile/print.c b/libguile/print.c index 6ec1f11d7..64dc6657e 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1138,7 +1138,7 @@ scm_init_print () vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL); layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT)); type = scm_make_struct (vtable, SCM_INUM0, SCM_LIST1 (layout)); - scm_set_struct_vtable_name_x (type, SCM_CAR (scm_intern0 ("print-state"))); + scm_set_struct_vtable_name_x (type, scm_str2symbol ("print-state")); print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL)); scm_print_state_vtable = type; diff --git a/libguile/ramap.c b/libguile/ramap.c index b360dee29..1db100b0d 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -2038,7 +2038,7 @@ static void init_raprocs (ra_iproc *subra) { for (; subra->name; subra++) - subra->sproc = SCM_CDR (scm_intern (subra->name, strlen (subra->name))); + subra->sproc = scm_symbol_binding (SCM_BOOL_F, scm_str2symbol (subra->name)); } diff --git a/libguile/read.c b/libguile/read.c index 8b23fb4bd..d3babdcca 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -381,8 +381,7 @@ tryagain_no_flush_ws: case '{': j = scm_read_token (c, tok_buf, port, 1); - p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); - return SCM_CAR (p); + return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); case '\\': c = scm_getc (port); @@ -404,8 +403,8 @@ tryagain_no_flush_ws: /* #:SYMBOL is a syntax for keywords supported in all contexts. */ case ':': j = scm_read_token ('-', tok_buf, port, 0); - p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); - return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); + p = scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); + return scm_make_keyword_from_dash_symbol (p); default: callshrp: @@ -509,8 +508,8 @@ tryagain_no_flush_ws: if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) { j = scm_read_token ('-', tok_buf, port, 0); - p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); - return scm_make_keyword_from_dash_symbol (SCM_CAR (p)); + p = scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); + return scm_make_keyword_from_dash_symbol (p); } /* fallthrough */ default: @@ -518,8 +517,7 @@ tryagain_no_flush_ws: /* fallthrough */ tok: - p = scm_intern (SCM_STRING_CHARS (*tok_buf), j); - return SCM_CAR (p); + return scm_mem2symbol (SCM_STRING_CHARS (*tok_buf), j); } } diff --git a/libguile/snarf.h b/libguile/snarf.h index 95371244f..e3d2d331d 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -153,11 +153,11 @@ SCM_SNARF_INIT(scm_make_synt (RANAME, TYPE, CFN)) #define SCM_SYMBOL(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (SCM_CAR (scm_intern0 (scheme_name)))) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_str2symbol (scheme_name))) #define SCM_GLOBAL_SYMBOL(c_name, scheme_name) \ SCM_SNARF_HERE(SCM c_name) \ -SCM_SNARF_INIT(c_name = scm_permanent_object (SCM_CAR (scm_intern0 (scheme_name)))) +SCM_SNARF_INIT(c_name = scm_permanent_object (scm_str2symbol (scheme_name))) #define SCM_KEYWORD(c_name, scheme_name) \ SCM_SNARF_HERE(static SCM c_name) \ diff --git a/libguile/stacks.c b/libguile/stacks.c index e3de7eb23..5cfa4ca90 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -741,8 +741,7 @@ scm_init_stacks () = scm_permanent_object (scm_make_struct (vtable, SCM_INUM0, scm_cons (stack_layout, SCM_EOL))); - scm_set_struct_vtable_name_x (scm_stack_type, - SCM_CAR (scm_intern0 ("stack"))); + scm_set_struct_vtable_name_x (scm_stack_type, scm_str2symbol ("stack")); #ifndef SCM_MAGIC_SNARFER #include "libguile/stacks.x" #endif diff --git a/libguile/struct.c b/libguile/struct.c index 56de9c5c0..5c533f172 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -138,7 +138,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, } #endif } - new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F)); + new_sym = scm_mem2symbol (field_desc, len); } return scm_return_first (new_sym, fields); } diff --git a/libguile/symbols.c b/libguile/symbols.c index 42e4d2900..a50c57367 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -125,7 +125,7 @@ scm_sym2vcell (SCM sym, SCM thunk, SCM definep) else if (SCM_VARIABLEP (var)) return SCM_VARVCELL (var); else - scm_wta (sym, "strangely interned symbol? ", ""); + return scm_wta (sym, "strangely interned symbol? ", ""); } else { @@ -402,7 +402,7 @@ scm_sysintern0 (const char *name) if (scm_module_system_booted_p && SCM_NIMP (lookup_proc = SCM_TOP_LEVEL_LOOKUP_CLOSURE)) { - SCM sym = SCM_CAR (scm_intern0 (name)); + SCM sym = scm_str2symbol (name); SCM vcell = scm_sym2vcell (sym, lookup_proc, SCM_BOOL_T); if (SCM_FALSEP (vcell)) scm_misc_error ("sysintern0", "can't define variable", sym); @@ -499,13 +499,8 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, "@end format") #define FUNC_NAME s_scm_string_to_symbol { - SCM vcell; - SCM answer; - - SCM_VALIDATE_STRING (1,s); - vcell = scm_intern (SCM_STRING_CHARS (s), SCM_STRING_LENGTH (s)); - answer = SCM_CAR (vcell); - return answer; + SCM_VALIDATE_STRING (1, s); + return scm_mem2symbol (SCM_STRING_CHARS (s), SCM_STRING_LENGTH (s)); } #undef FUNC_NAME @@ -846,7 +841,7 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, } { int n_digits = scm_iint2str (gensym_counter++, 10, &name[len]); - SCM res = SCM_CAR (scm_intern (name, len + n_digits)); + SCM res = scm_mem2symbol (name, len + n_digits); if (name != buf) scm_must_free (name); return res; diff --git a/libguile/throw.c b/libguile/throw.c index d0abcb8a0..ebd2a2bfe 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -479,7 +479,7 @@ handler_message (void *handler_data, SCM tag, SCM args) SCM scm_handle_by_message (void *handler_data, SCM tag, SCM args) { - if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit"))))) + if (SCM_NFALSEP (scm_eq_p (tag, scm_str2symbol ("quit")))) { exit (scm_exit_status (args)); } diff --git a/libguile/unif.c b/libguile/unif.c index 4eccbc338..0d13c46e4 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -2523,10 +2523,10 @@ loop: case scm_tc7_ivect: return SCM_MAKINUM (-1L); case scm_tc7_svect: - return SCM_CDR (scm_intern ("s", 1)); + return scm_str2symbol ("s"); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: - return SCM_CDR (scm_intern ("l", 1)); + return scm_str2symbol ("l"); #endif case scm_tc7_fvect: return scm_make_real (1.0); |