xemacs-beta: src/symbols.c comparison

comparison src/symbols.c @ 5118:e0db3c197671 ben-lisp-object

merge up to latest default branch, doesn't compile yet

author	Ben Wing <ben@xemacs.org>
date	Sat, 26 Dec 2009 21:18:49 -0600
parents	3742ea8250b5 8f1ee2d15784
children	623d57b7fbe8

comparison

equal deleted inserted replaced

-:3742ea8250b5
+:e0db3c197671
 static Lisp_Object fetch_value_maybe_past_magic (Lisp_Object sym,
 						 Lisp_Object follow_past_lisp_magic);
 static Lisp_Object *value_slot_past_magic (Lisp_Object sym);
 static Lisp_Object follow_varalias_pointers (Lisp_Object symbol,
 					     Lisp_Object follow_past_lisp_magic);
+static Lisp_Object map_varalias_chain (Lisp_Object symbol,
+Lisp_Object follow_past_lisp_magic,
+Lisp_Object (*fn) (Lisp_Object arg));
 static Lisp_Object
 mark_symbol (Lisp_Object obj)
 {
 symbol_remprop (Lisp_Object symbol, Lisp_Object property)
 {
 return external_remprop (&XSYMBOL (symbol)->plist, property, 0, ERROR_ME);
 }
-DEFINE_BASIC_LISP_OBJECT_WITH_PROPS ("symbol", symbol,
+DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT_WITH_PROPS ("symbol", symbol,
 						mark_symbol, print_symbol,
 						0, 0, 0, symbol_description,
 						symbol_getprop,
 						symbol_putprop,
 						symbol_remprop,
 }
 return object;
 }
-DEFUN ("intern-soft", Fintern_soft, 1, 2, 0, /*
+DEFUN ("intern-soft", Fintern_soft, 1, 3, 0, /*
 Return the canonical symbol named NAME, or nil if none exists.
 NAME may be a string or a symbol.  If it is a symbol, that exact
 symbol is searched for.
 Optional second argument OBARRAY specifies the obarray to use;
 it defaults to the value of the variable `obarray'.
-*/
+Optional third argument DEFAULT says what Lisp object to return if there is
-(name, obarray))
+no canonical symbol named NAME, and defaults to nil.
-{
+*/
-/* #### Bug!  (intern-soft "nil") returns nil.  Perhaps we should
+(name, obarray, default_))
-add a DEFAULT-IF-NOT-FOUND arg, like in get.  */
+{
 Lisp_Object tem;
 Lisp_Object string;
 if (NILP (obarray)) obarray = Vobarray;
 obarray = check_obarray (obarray);
 else
 string = symbol_name (XSYMBOL (name));
 tem = oblookup (obarray, XSTRING_DATA (string), XSTRING_LENGTH (string));
 if (INTP (tem) || (SYMBOLP (name) && !EQ (name, tem)))
-return Qnil;
+return default_;
 else
 return tem;
 }
 DEFUN ("unintern", Funintern, 1, 2, 0, /*
 */
 (symbol, newdef))
 {
 /* This function can GC */
 Ffset (symbol, newdef);
-LOADHIST_ATTACH (symbol);
+LOADHIST_ATTACH (Fcons (Qdefun, symbol));
 return newdef;
 }
+DEFUN ("subr-name", Fsubr_name, 1, 1, 0, /*
+Return name of function SUBR.
+SUBR must be a built-in function.
+*/
+(subr))
+{
+const char *name;
+CHECK_SUBR (subr);
+name = XSUBR (subr)->name;
+return make_string ((const Ibyte *)name, strlen (name));
+}
+DEFUN ("special-form-p", Fspecial_form_p, 1, 1, 0, /*
+Return whether SUBR is a special form.
+A special form is a built-in function (a subr, that is a function
+implemented in C, not Lisp) which does not necessarily evaluate all its
+arguments.  Much of the basic XEmacs Lisp syntax is implemented by means of
+special forms; examples are `let', `condition-case', `defun', `setq' and so
+on.
+If you intend to write a Lisp function that does not necessarily evaluate
+all its arguments, the portable (across emacs variants, and across Lisp
+implementations) way to go about it is to write a macro instead.  See
+`defmacro' and `backquote'.
+*/
+(subr))
+{
+subr = indirect_function (subr, 0);
+return (SUBRP (subr) && XSUBR (subr)->max_args == UNEVALLED) ? Qt : Qnil;
+}
 DEFUN ("setplist", Fsetplist, 2, 2, 0, /*
 Set SYMBOL's property list to NEWPLIST, and return NEWPLIST.
 */
 (symbol, newplist))
 static const struct memory_description symbol_value_forward_description[] = {
 { XD_END }
 };
-DEFINE_LISP_OBJECT ("symbol-value-forward",
+DEFINE_DUMPABLE_LISP_OBJECT ("symbol-value-forward",
 			       symbol_value_forward,
 			       0,
 			       print_symbol_value_magic, 0, 0, 0,
 			       symbol_value_forward_description,
 			       struct symbol_value_forward);
-DEFINE_LISP_OBJECT ("symbol-value-buffer-local",
+DEFINE_DUMPABLE_LISP_OBJECT ("symbol-value-buffer-local",
 			       symbol_value_buffer_local,
 			       mark_symbol_value_buffer_local,
 			       print_symbol_value_magic, 0, 0, 0,
 			       symbol_value_buffer_local_description,
 			       struct symbol_value_buffer_local);
-DEFINE_LISP_OBJECT ("symbol-value-lisp-magic",
+DEFINE_DUMPABLE_LISP_OBJECT ("symbol-value-lisp-magic",
 			       symbol_value_lisp_magic,
 			       mark_symbol_value_lisp_magic,
 			       print_symbol_value_magic, 0, 0, 0,
 			       symbol_value_lisp_magic_description,
 			       struct symbol_value_lisp_magic);
-DEFINE_LISP_OBJECT ("symbol-value-varalias",
+DEFINE_DUMPABLE_LISP_OBJECT ("symbol-value-varalias",
 			       symbol_value_varalias,
 			       mark_symbol_value_varalias,
 			       print_symbol_value_magic, 0, 0, 0,
 			       symbol_value_varalias_description,
 			       struct symbol_value_varalias);
 Fsignal (Qwrong_number_of_arguments,
 	     list2 (Qsetq_default, make_int (nargs)));
 GC_PROPERTY_LIST_LOOP_3 (symbol, val, args)
 {
-val = Feval (val);
+val = IGNORE_MULTIPLE_VALUES (Feval (val));
 Fset_default (symbol, val);
 retval = val;
 }
 END_GC_PROPERTY_LIST_LOOP (symbol);
 if (NILP (after_set))
 return local_info > 0 ? Qt : Qnil;
 else
 return local_info != 0 ? Qt : Qnil;
 }
+DEFUN ("custom-variable-p", Fcustom_variable_p, 1, 1, 0, /*
+Return non-nil if SYMBOL names a custom variable.
+Does not follow the variable alias chain.
+*/
+(symbol))
+{
+return (!(NILP (Fget(symbol, intern ("standard-value"), Qnil)))
+|| !(NILP (Fget(symbol, intern ("custom-autoload"), Qnil)))) ?
+Qt: Qnil;
+}
+static Lisp_Object
+user_variable_alias_check_fun (Lisp_Object symbol)
+{
+Lisp_Object documentation = Fget (symbol, Qvariable_documentation, Qnil);
+if ((INTP (documentation) && XINT (documentation) < 0) ||
+(STRINGP (documentation) &&
+(string_byte (documentation, 0) == '*')) ||
+/* If (STRING . INTEGER), a negative integer means a user variable. */
+(CONSP (documentation)
+&& STRINGP (XCAR (documentation))
+&& INTP (XCDR (documentation))
+&& XINT (XCDR (documentation)) < 0) ||
+!NILP (Fcustom_variable_p (symbol)))
+{
+return make_int(1);
+}
+return Qzero;
+}
+DEFUN ("user-variable-p", Fuser_variable_p, 1, 1, 0, /*
+Return t if SYMBOL names a variable intended to be set and modified by users.
+\(The alternative is a variable used internally in a Lisp program.)
+A symbol names a user variable if
+\(1) the first character of its documentation is `*', or
+\(2) it is customizable (`custom-variable-p' gives t), or
+\(3) it names a variable alias that eventually resolves to another user variable.
+The GNU Emacs implementation of `user-variable-p' returns nil if there is a
+loop in the chain of symbols.  Since this is indistinguishable from the case
+where a symbol names a non-user variable, XEmacs signals a
+`cyclic-variable-indirection' error instead; use `condition-case' to catch
+this error if you really want to avoid this.
+*/
+(symbol))
+{
+Lisp_Object mapped;
+if (!SYMBOLP (symbol))
+{
+return Qnil;
+}
+/* Called for its side-effects, we want it to signal if there's a loop. */
+follow_varalias_pointers (symbol, Qt);
+/* Look through the various aliases. */
+mapped = map_varalias_chain (symbol, Qt, user_variable_alias_check_fun);
+if (EQ (Qzero, mapped))
+{
+return Qnil;
+}
+assert (EQ (make_int (1), mapped));
+return Qt;
+}
 /*
 I've gone ahead and partially implemented this because it's
 super-useful for dealing with the compatibility problems in supporting
 If you do, suffer the wrath of Ben, who is likely to rename
 this function (or change the semantics of its arguments) without
 pity, thereby invalidating your code.
 */
 (variable, handler_type, handler, harg,
-	UNUSED (keep_existing)))
+	UNUSED (keep_existing )))
 {
 Lisp_Object valcontents;
 struct symbol_value_lisp_magic *bfwd;
 enum lisp_magic_handler htype;
 int i;
 }
 return hare;
 }
-DEFUN ("defvaralias", Fdefvaralias, 2, 2, 0, /*
+/* Map FN over the chain of variable aliases for SYMBOL. If FN returns
+something other than Qzero for some link in the chain, return that
+immediately. Otherwise return Qzero (which is not a symbol).
+FN may be called twice on the same symbol if the varalias chain is
+cyclic. Prevent this by calling follow_varalias_pointers first for its
+side-effects.
+Signals a cyclic-variable-indirection error if a cyclic structure is
+detected. */
+static Lisp_Object
+map_varalias_chain (Lisp_Object symbol,
+Lisp_Object follow_past_lisp_magic,
+Lisp_Object (*fn) (Lisp_Object arg))
+{
+#define VARALIAS_INDIRECTION_SUSPICION_LENGTH 16
+Lisp_Object tortoise, hare, val, res;
+int count;
+assert (fn);
+/* quick out just in case */
+if (!SYMBOL_VALUE_MAGIC_P (XSYMBOL (symbol)->value))
+{
+return (fn)(symbol);
+}
+/* Compare implementation of indirect_function().  */
+for (hare = tortoise = symbol, count = 0;
+val = fetch_value_maybe_past_magic (hare, follow_past_lisp_magic),
+	 SYMBOL_VALUE_VARALIAS_P (val);
+hare = symbol_value_varalias_aliasee (XSYMBOL_VALUE_VARALIAS (val)),
+	 count++)
+{
+res = (fn) (hare);
+if (!EQ (Qzero, res))
+{
+return res;
+}
+if (count < VARALIAS_INDIRECTION_SUSPICION_LENGTH) continue;
+if (count & 1)
+	tortoise = symbol_value_varalias_aliasee
+	  (XSYMBOL_VALUE_VARALIAS (fetch_value_maybe_past_magic
+				   (tortoise, follow_past_lisp_magic)));
+if (EQ (hare, tortoise))
+return Fsignal (Qcyclic_variable_indirection, list1 (symbol));
+}
+return (fn) (hare);
+}
+/*
+OED entry, 2nd edition, IPA transliterated using Kirshenbaum:
+alias ('eIlI@s, '&lI@s), adv. and n.
+[...]
+B. n. (with pl. aliases.)
+1. Another name, an assumed name.
+1605 Camden Rem. (1614) 147 An Alias or double name cannot preiudice the honest.
+1831 Edin. Rev. LIII. 364 He has been assuming various aliases.
+1861 Macaulay Hist. Eng. V. 92 The monk who was sometimes called Harrison
+and sometimes went by the alias of Johnson.
+The alias is the fake name. Let's try to follow that usage in our
+documentation.
+*/
+DEFUN ("defvaralias", Fdefvaralias, 2, 3, 0, /*
 Define a variable as an alias for another variable.
 Thenceforth, any operations performed on VARIABLE will actually be
-performed on ALIAS.  Both VARIABLE and ALIAS should be symbols.
+performed on ALIASED.  Both VARIABLE and ALIASED should be symbols.
-If ALIAS is nil, remove any aliases for VARIABLE.
+If ALIASED is nil and VARIABLE is an existing alias, remove that alias.
-ALIAS can itself be aliased, and the chain of variable aliases
+ALIASED can itself be an alias, and the chain of variable aliases
 will be followed appropriately.
 If VARIABLE already has a value, this value will be shadowed
 until the alias is removed, at which point it will be restored.
 Currently VARIABLE cannot be a built-in variable, a variable that
 has a buffer-local value in any buffer, or the symbols nil or t.
-\(ALIAS, however, can be any type of variable.)
+\(ALIASED, however, can be any type of variable.)
-*/
-(variable, alias))
+Optional argument DOCSTRING is documentation for VARIABLE in its use as an
+alias for ALIASED.  The XEmacs help code ignores this documentation, using
+the documentation of ALIASED instead, and the docstring, if specified, is
+not shadowed in the same way that the value is.  Only use it if you know
+what you're doing.
+*/
+(variable, aliased, docstring))
 {
 struct symbol_value_varalias *bfwd;
 Lisp_Object valcontents;
 CHECK_SYMBOL (variable);
 reject_constant_symbols (variable, Qunbound, 0, Qt);
 valcontents = XSYMBOL (variable)->value;
-if (NILP (alias))
+if (NILP (aliased))
 {
 if (SYMBOL_VALUE_VARALIAS_P (valcontents))
 	{
 	  XSYMBOL (variable)->value =
 	    symbol_value_varalias_shadowed
 	      (XSYMBOL_VALUE_VARALIAS (valcontents));
 	}
 return Qnil;
 }
-CHECK_SYMBOL (alias);
+CHECK_SYMBOL (aliased);
+if (!NILP (docstring))
+Fput (variable, Qvariable_documentation, docstring);
 if (SYMBOL_VALUE_VARALIAS_P (valcontents))
 {
 /* transmogrify */
-XSYMBOL_VALUE_VARALIAS (valcontents)->aliasee = alias;
+XSYMBOL_VALUE_VARALIAS (valcontents)->aliasee = aliased;
 return Qnil;
 }
 if (SYMBOL_VALUE_MAGIC_P (valcontents)
 && !UNBOUNDP (valcontents))
 reject_constant_symbols (variable, Qunbound, 0, Qt);
 bfwd =
 XSYMBOL_VALUE_VARALIAS (ALLOC_LISP_OBJECT (symbol_value_varalias));
 bfwd->magic.type = SYMVAL_VARALIAS;
-bfwd->aliasee = alias;
+bfwd->aliasee = aliased;
 bfwd->shadowed = valcontents;
 valcontents = wrap_symbol_value_magic (bfwd);
 XSYMBOL (variable)->value = valcontents;
 return Qnil;
 }
 DEFUN ("variable-alias", Fvariable_alias, 1, 2, 0, /*
-If VARIABLE is aliased to another variable, return that variable.
+If VARIABLE is an alias of another variable, return that variable.
-VARIABLE should be a symbol.  If VARIABLE is not aliased, return nil.
+VARIABLE should be a symbol.  If VARIABLE is not an alias, return nil.
 Variable aliases are created with `defvaralias'.  See also
 `indirect-variable'.
 */
 (variable, follow_past_lisp_magic))
 {
 #endif
 #ifndef Qnull_pointer
 Lisp_Object Qnull_pointer;
 #endif
-#ifndef MC_ALLOC
+#ifndef NEW_GC
 /* some losing systems can't have static vars at function scope... */
 static const struct symbol_value_magic guts_of_unbound_marker =
 { /* struct symbol_value_magic */
 { /* struct old_lcrecord_header */
 { /* struct lrecord_header */
 0, /* free */
 },
 0, /* value */
 SYMVAL_UNBOUND_MARKER
 };
-#endif /* not MC_ALLOC */
+#endif /* not NEW_GC */
 void
 init_symbols_once_early (void)
 {
 INIT_LISP_OBJECT (symbol);
 }
 {
 /* Required to get around a GCC syntax error on certain
 architectures */
-#ifdef MC_ALLOC
+#ifdef NEW_GC
 struct symbol_value_magic *tem = (struct symbol_value_magic *)
 mc_alloc (sizeof (struct symbol_value_magic));
 MARK_LRECORD_AS_LISP_READONLY (tem);
 MARK_LRECORD_AS_NOT_FREE (tem);
 tem->header.type = lrecord_type_symbol_value_forward;
 tem->type = SYMVAL_UNBOUND_MARKER;
 #ifdef ALLOC_TYPE_STATS
 inc_lrecord_stats (sizeof (struct symbol_value_magic),
 		       (const struct lrecord_header *) tem);
 #endif /* ALLOC_TYPE_STATS */
-#else /* not MC_ALLOC */
+#else /* not NEW_GC */
 const struct symbol_value_magic *tem = &guts_of_unbound_marker;
-#endif /* not MC_ALLOC */
+#endif /* not NEW_GC */
 Qunbound = wrap_symbol_value_magic (tem);
 }
 XSYMBOL (Qnil)->function = Qunbound;
 #else
 #define check_sane_subr(subr, sym) /* nothing */
 #endif
 #ifdef HAVE_SHLIB
-#ifndef MC_ALLOC
+#ifndef NEW_GC
 /*
 * If we are not in a pure undumped Emacs, we need to make a duplicate of
 * the subr. This is because the only time this function will be called
 * in a running Emacs is when a dynamically loaded module is adding a
 * subr, and we need to make sure that the subr is in allocated, Lisp-
 memcpy (newsubr, subr, sizeof (Lisp_Subr));				      \
 subr->doc = (const char *)newsubr;					      \
 subr = newsubr;							      \
 }									      \
 } while (0)
-#else /* MC_ALLOC */
+#else /* NEW_GC */
 /*
 * If we have the new allocator enabled, we do not need to make a
 * duplicate of the subr.  The new allocator already does allocate all
 * subrs in Lisp-accessible memory rather than have it in the static
 * subr struct.
 f = XSYMBOL (sym)->function;					      \
 if (!UNBOUNDP (f) && (!CONSP (f) || !EQ (XCAR (f), Qautoload)))	      \
 signal_ferror (Qdll_error, "Attempt to redefine %s", subr_name (subr)); \
 }									      \
 } while (0)
-#endif /* MC_ALLOC */
+#endif /* NEW_GC */
 #else /* ! HAVE_SHLIB */
 #define check_module_subr(subr)
 #endif
 void
 DEFSUBR (Fglobally_boundp);
 DEFSUBR (Ffboundp);
 DEFSUBR (Ffset);
 DEFSUBR (Fdefine_function);
 Ffset (intern ("defalias"), intern ("define-function"));
+DEFSUBR (Fsubr_name);
+DEFSUBR (Fspecial_form_p);
 DEFSUBR (Fsetplist);
 DEFSUBR (Fsymbol_value_in_buffer);
 DEFSUBR (Fsymbol_value_in_console);
 DEFSUBR (Fbuilt_in_variable_type);
 DEFSUBR (Fsymbol_value);
 DEFSUBR (Fmake_variable_buffer_local);
 DEFSUBR (Fmake_local_variable);
 DEFSUBR (Fkill_local_variable);
 DEFSUBR (Fkill_console_local_variable);
 DEFSUBR (Flocal_variable_p);
+DEFSUBR (Fcustom_variable_p);
+DEFSUBR (Fuser_variable_p);
 DEFSUBR (Fdefvaralias);
 DEFSUBR (Fvariable_alias);
 DEFSUBR (Findirect_variable);
 DEFSUBR (Fvariable_binding_locus);
 DEFSUBR (Fdontusethis_set_symbol_value_handler);

Mercurial > hg > xemacs-beta

comparison src/symbols.c @ 5118:e0db3c197671 ben-lisp-object