* src/data.c (Qspecial_operator): New variable.
(CHECK_SUBR, Ftype_of, Fsubrp, Fsubr_arity, Finteractive_form):
Update for new subr representation.
* src/emacs.c (main2): Call `syms_of_data' early.
* src/lisp.h (XSUBR, SUBRP): Remove. All callers changed.
(DEFUN): Define subrs as Guile procedures.
(functionp): Update for new subr representation.
* src/lread.c (defsubr): Update for new subr representation. Take
relevant subr properties as direct arguments instead of accepting a
`Lisp_Subr' struct; all callers changed.
* src/doc.c (Fdocumentation, store_function_docstring):
* src/eval.c (Fcommandp, eval_sub_1, Fapply, Ffuncall1):
* src/print.c (print_object):
* src/xmenu.c: Update for new subr representation.
Lisp_Object Qfont_spec, Qfont_entity, Qfont_object;
static Lisp_Object Qdefun;
+Lisp_Object Qspecial_operator;
Lisp_Object Qinteractive_form;
static Lisp_Object Qdefalias_fset_function;
static void
CHECK_SUBR (Lisp_Object x)
{
- CHECK_TYPE (SUBRP (x), Qsubrp, x);
+ CHECK_TYPE (! NILP (Fsubrp (x)), Qsubrp, x);
}
static void
return Qprocess;
if (WINDOWP (object))
return Qwindow;
- if (SUBRP (object))
- return Qsubr;
if (COMPILEDP (object))
return Qcompiled_function;
if (BUFFERP (object))
}
else if (FLOATP (object))
return Qfloat;
+ else if (! NILP (Fsubrp (object)))
+ return Qsubr;
else
return Qt;
}
doc: /* Return t if OBJECT is a built-in function. */)
(Lisp_Object object)
{
- if (SUBRP (object))
+ if (CONSP (object) && EQ (XCAR (object), Qspecial_operator))
+ object = XCDR (object);
+ if (SCM_PRIMITIVE_P (object))
return Qt;
return Qnil;
}
function with `&rest' args, or `unevalled' for a special form. */)
(Lisp_Object subr)
{
- short minargs, maxargs;
+ Lisp_Object min, max;
+ Lisp_Object arity;
+ bool special = false;
+
CHECK_SUBR (subr);
- minargs = XSUBR (subr)->min_args;
- maxargs = XSUBR (subr)->max_args;
- return Fcons (make_number (minargs),
- maxargs == MANY ? Qmany
- : maxargs == UNEVALLED ? Qunevalled
- : make_number (maxargs));
+ if (CONSP (subr) && EQ (XCAR (subr), Qspecial_operator))
+ {
+ subr = XCDR (subr);
+ special = true;
+ }
+ arity = scm_procedure_minimum_arity (subr);
+ if (scm_is_false (arity))
+ return Qnil;
+ min = XCAR (arity);
+ if (special)
+ max = Qunevalled;
+ else if (scm_is_true (XCAR (XCDR (XCDR (arity)))))
+ max = Qmany;
+ else
+ max = scm_sum (min, XCAR (XCDR (arity)));
+ return Fcons (min, max);
}
DEFUN ("subr-name", Fsubr_name, Ssubr_name, 1, 1, 0,
SUBR must be a built-in function. */)
(Lisp_Object subr)
{
- const char *name;
CHECK_SUBR (subr);
- name = XSUBR (subr)->symbol_name;
- return build_string (name);
+ if (CONSP (subr) && EQ (XCAR (subr), Qspecial_operator))
+ subr = XCDR (subr);
+ return Fsymbol_name (SCM_SUBR_NAME (subr));
}
DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
fun = Fsymbol_function (fun);
}
- if (SUBRP (fun))
+ if (scm_is_true (scm_procedure_p (fun)))
{
- const char *spec = XSUBR (fun)->intspec;
- if (spec)
- return list2 (Qinteractive,
- (*spec != '(') ? build_string (spec) :
- Fcar (Fread_from_string (build_string (spec), Qnil, Qnil)));
+ Lisp_Object tem = scm_procedure_property (fun, Qinteractive_form);
+ if (scm_is_true (tem))
+ return list2 (Qinteractive, tem);
}
else if (COMPILEDP (fun))
{
{
Lisp_Object error_tail, arith_tail;
+ /* Used by defsubr. */
+ DEFSYM (Qspecial_operator, "special-operator");
+ DEFSYM (Qinteractive_form, "interactive-form");
+
#include "data.x"
DEFSYM (Qquote, "quote");
DEFSYM (Qfont_entity, "font-entity");
DEFSYM (Qfont_object, "font-object");
- DEFSYM (Qinteractive_form, "interactive-form");
DEFSYM (Qdefalias_fset_function, "defalias-fset-function");
set_symbol_function (Qwholenump, SYMBOL_FUNCTION (Qnatnump));
}
fun = Findirect_function (function, Qnil);
- if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
+ if (CONSP (fun)
+ && (EQ (XCAR (fun), Qmacro)
+ || EQ (XCAR (fun), Qspecial_operator)))
fun = XCDR (fun);
- if (SUBRP (fun))
+ if (scm_is_true (scm_procedure_p (fun)))
{
- if (XSUBR (fun)->doc == 0)
- return Qnil;
- /* FIXME: This is not portable, as it assumes that string
- pointers have the top bit clear. */
- else if ((intptr_t) XSUBR (fun)->doc >= 0)
- doc = build_string (XSUBR (fun)->doc);
+ Lisp_Object tem = scm_procedure_property (fun, intern ("emacs-documentation"));
+ if (scm_is_true (tem))
+ doc = tem;
else
- doc = make_number ((intptr_t) XSUBR (fun)->doc);
+ return Qnil;
}
else if (COMPILEDP (fun))
{
/* The type determines where the docstring is stored. */
- /* Lisp_Subrs have a slot for it. */
- if (SUBRP (fun))
+
+ if (scm_is_true (scm_procedure_p (fun)))
{
- intptr_t negative_offset = - offset;
- XSUBR (fun)->doc = (char *) negative_offset;
+ scm_set_procedure_property_x (fun,
+ intern ("emacs-documentation"),
+ make_number (offset));
}
/* If it's a lisp form, stick it in the form. */
correctness is quite delicate. */
XSETCAR (tem, make_number (offset));
}
- else if (EQ (tem, Qmacro))
+ else if (EQ (tem, Qmacro) || EQ (tem, Qspecial_operator))
store_function_docstring (XCDR (fun), offset);
}
init_minibuf_once (); /* Create list of minibuffers. */
/* Must precede init_window_once. */
+ /* Called before syms_of_fileio, because it sets up
+ Qerror_condition. Called before other symbol-initialization
+ functions because it sets up symbols used by defsubr. */
+ syms_of_data ();
+
/* Call syms_of_xfaces before init_window_once because that
function creates Vterminal_frame. Termcap frames now use
faces, and the face implementation uses some symbols as
CANNOT_DUMP is defined. */
syms_of_keyboard ();
- /* Called before syms_of_fileio, because it sets up Qerror_condition. */
- syms_of_data ();
syms_of_fns (); /* Before syms_of_charset which uses hashtables. */
syms_of_fileio ();
/* Before syms_of_coding to initialize Vgc_cons_threshold. */
fun = Fsymbol_function (fun);
}
- /* Emacs primitives are interactive if their DEFUN specifies an
- interactive spec. */
- if (SUBRP (fun))
- return XSUBR (fun)->intspec ? Qt : if_prop;
-
+ if (scm_is_true (scm_procedure_p (fun)))
+ return (scm_is_true (scm_procedure_property (fun, Qinteractive_form))
+ ? Qt : if_prop);
/* Bytecode objects are interactive if they are long enough to
have an element whose index is COMPILED_INTERACTIVE, which is
where the interactive spec is stored. */
args[argnum++] = eval_sub (Fcar (args_left));
args_left = Fcdr (args_left);
}
+ set_backtrace_args (specpdl_ptr - 1, args);
+ set_backtrace_nargs (specpdl_ptr - 1, argnum);
val = scm_call_n (fun, args, argnum);
}
- else if (SUBRP (fun))
+ else if (CONSP (fun) && EQ (XCAR (fun), Qspecial_operator))
{
- Lisp_Object numargs;
- Lisp_Object argvals[8];
- Lisp_Object args_left;
- register int i, maxargs;
-
- args_left = original_args;
- numargs = Flength (args_left);
-
- if (XINT (numargs) < XSUBR (fun)->min_args
- || (XSUBR (fun)->max_args >= 0
- && XSUBR (fun)->max_args < XINT (numargs)))
- xsignal2 (Qwrong_number_of_arguments, original_fun, numargs);
-
- else if (XSUBR (fun)->max_args == UNEVALLED)
- val = (XSUBR (fun)->function.aUNEVALLED) (args_left);
- else if (XSUBR (fun)->max_args == MANY)
- {
- /* Pass a vector of evaluated arguments. */
- Lisp_Object *vals;
- ptrdiff_t argnum = 0;
- USE_SAFE_ALLOCA;
-
- SAFE_ALLOCA_LISP (vals, XINT (numargs));
-
- GCPRO3 (args_left, fun, fun);
- gcpro3.var = vals;
- gcpro3.nvars = 0;
-
- while (!NILP (args_left))
- {
- vals[argnum++] = eval_sub (Fcar (args_left));
- args_left = Fcdr (args_left);
- gcpro3.nvars = argnum;
- }
-
- set_backtrace_args (specpdl_ptr - 1, vals);
- set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
-
- val = (XSUBR (fun)->function.aMANY) (XINT (numargs), vals);
- UNGCPRO;
- SAFE_FREE ();
- }
- else
- {
- GCPRO3 (args_left, fun, fun);
- gcpro3.var = argvals;
- gcpro3.nvars = 0;
-
- maxargs = XSUBR (fun)->max_args;
- for (i = 0; i < maxargs; args_left = Fcdr (args_left))
- {
- argvals[i] = eval_sub (Fcar (args_left));
- gcpro3.nvars = ++i;
- }
-
- UNGCPRO;
-
- set_backtrace_args (specpdl_ptr - 1, argvals);
- set_backtrace_nargs (specpdl_ptr - 1, XINT (numargs));
-
- switch (i)
- {
- case 0:
- val = (XSUBR (fun)->function.a0 ());
- break;
- case 1:
- val = (XSUBR (fun)->function.a1 (argvals[0]));
- break;
- case 2:
- val = (XSUBR (fun)->function.a2 (argvals[0], argvals[1]));
- break;
- case 3:
- val = (XSUBR (fun)->function.a3
- (argvals[0], argvals[1], argvals[2]));
- break;
- case 4:
- val = (XSUBR (fun)->function.a4
- (argvals[0], argvals[1], argvals[2], argvals[3]));
- break;
- case 5:
- val = (XSUBR (fun)->function.a5
- (argvals[0], argvals[1], argvals[2], argvals[3],
- argvals[4]));
- break;
- case 6:
- val = (XSUBR (fun)->function.a6
- (argvals[0], argvals[1], argvals[2], argvals[3],
- argvals[4], argvals[5]));
- break;
- case 7:
- val = (XSUBR (fun)->function.a7
- (argvals[0], argvals[1], argvals[2], argvals[3],
- argvals[4], argvals[5], argvals[6]));
- break;
-
- case 8:
- val = (XSUBR (fun)->function.a8
- (argvals[0], argvals[1], argvals[2], argvals[3],
- argvals[4], argvals[5], argvals[6], argvals[7]));
- break;
-
- default:
- /* Someone has created a subr that takes more arguments than
- is supported by this code. We need to either rewrite the
- subr to use a different argument protocol, or add more
- cases to this switch. */
- emacs_abort ();
- }
- }
+ val = scm_apply_0 (XCDR (fun), original_args);
}
else if (COMPILEDP (fun))
val = apply_lambda (fun, original_args);
{
/* Let funcall get the error. */
fun = args[0];
- goto funcall;
}
- if (SUBRP (fun))
- {
- if (numargs < XSUBR (fun)->min_args
- || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
- goto funcall; /* Let funcall get the error. */
- else if (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args > numargs)
- {
- /* Avoid making funcall cons up a yet another new vector of arguments
- by explicitly supplying nil's for optional values. */
- SAFE_ALLOCA_LISP (funcall_args, 1 + XSUBR (fun)->max_args);
- for (i = numargs; i < XSUBR (fun)->max_args;)
- funcall_args[++i] = Qnil;
- GCPRO1 (*funcall_args);
- gcpro1.nvars = 1 + XSUBR (fun)->max_args;
- }
- }
- funcall:
/* We add 1 to numargs because funcall_args includes the
function itself as well as its arguments. */
if (!funcall_args)
{
val = scm_call_n (fun, args + 1, numargs);
}
- else if (SUBRP (fun))
- {
- if (numargs < XSUBR (fun)->min_args
- || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
- {
- XSETFASTINT (lisp_numargs, numargs);
- xsignal2 (Qwrong_number_of_arguments, original_fun, lisp_numargs);
- }
-
- else if (XSUBR (fun)->max_args == UNEVALLED)
- xsignal1 (Qinvalid_function, original_fun);
-
- else if (XSUBR (fun)->max_args == MANY)
- val = (XSUBR (fun)->function.aMANY) (numargs, args + 1);
- else
- {
- if (XSUBR (fun)->max_args > numargs)
- {
- internal_args = alloca (XSUBR (fun)->max_args
- * sizeof *internal_args);
- memcpy (internal_args, args + 1, numargs * word_size);
- for (i = numargs; i < XSUBR (fun)->max_args; i++)
- internal_args[i] = Qnil;
- }
- else
- internal_args = args + 1;
- switch (XSUBR (fun)->max_args)
- {
- case 0:
- val = (XSUBR (fun)->function.a0 ());
- break;
- case 1:
- val = (XSUBR (fun)->function.a1 (internal_args[0]));
- break;
- case 2:
- val = (XSUBR (fun)->function.a2
- (internal_args[0], internal_args[1]));
- break;
- case 3:
- val = (XSUBR (fun)->function.a3
- (internal_args[0], internal_args[1], internal_args[2]));
- break;
- case 4:
- val = (XSUBR (fun)->function.a4
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3]));
- break;
- case 5:
- val = (XSUBR (fun)->function.a5
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3], internal_args[4]));
- break;
- case 6:
- val = (XSUBR (fun)->function.a6
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3], internal_args[4], internal_args[5]));
- break;
- case 7:
- val = (XSUBR (fun)->function.a7
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3], internal_args[4], internal_args[5],
- internal_args[6]));
- break;
-
- case 8:
- val = (XSUBR (fun)->function.a8
- (internal_args[0], internal_args[1], internal_args[2],
- internal_args[3], internal_args[4], internal_args[5],
- internal_args[6], internal_args[7]));
- break;
-
- default:
-
- /* If a subr takes more than 8 arguments without using MANY
- or UNEVALLED, we need to extend this function to support it.
- Until this is done, there is no way to call the function. */
- emacs_abort ();
- }
- }
- }
else if (COMPILEDP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
PVEC_HASH_TABLE,
PVEC_TERMINAL,
PVEC_WINDOW_CONFIGURATION,
- PVEC_SUBR,
PVEC_OTHER,
/* These should be last, check internal_equal to see why. */
PVEC_COMPILED,
Lisp_Object);
INLINE bool STRINGP (Lisp_Object);
INLINE bool SUB_CHAR_TABLE_P (Lisp_Object);
-INLINE bool SUBRP (Lisp_Object);
INLINE bool (SYMBOLP) (Lisp_Object);
INLINE bool (VECTORLIKEP) (Lisp_Object);
INLINE bool WINDOWP (Lisp_Object);
return SMOB_PTR (a);
}
-INLINE struct Lisp_Subr *
-XSUBR (Lisp_Object a)
-{
- eassert (SUBRP (a));
- return SMOB_PTR (a);
-}
-
INLINE struct buffer *
XBUFFER (Lisp_Object a)
{
char_table_set (ct, idx, val);
}
-/* This structure describes a built-in function.
- It is generated by the DEFUN macro only.
- defsubr makes it into a Lisp object. */
-
-struct Lisp_Subr
- {
- struct vectorlike_header header;
- union {
- Lisp_Object (*a0) (void);
- Lisp_Object (*a1) (Lisp_Object);
- Lisp_Object (*a2) (Lisp_Object, Lisp_Object);
- Lisp_Object (*a3) (Lisp_Object, Lisp_Object, Lisp_Object);
- Lisp_Object (*a4) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
- Lisp_Object (*a5) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
- Lisp_Object (*a6) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
- Lisp_Object (*a7) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
- Lisp_Object (*a8) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object);
- Lisp_Object (*aUNEVALLED) (Lisp_Object args);
- Lisp_Object (*aMANY) (ptrdiff_t, Lisp_Object *);
- } function;
- short min_args, max_args;
- const char *symbol_name;
- const char *intspec;
- const char *doc;
- };
-
/* This is the number of slots that every char table must have. This
counts the ordinary slots and the top, defalt, parent, and purpose
slots. */
return PSEUDOVECTORP (a, PVEC_TERMINAL);
}
-INLINE bool
-SUBRP (Lisp_Object a)
-{
- return PSEUDOVECTORP (a, PVEC_SUBR);
-}
-
INLINE bool
COMPILEDP (Lisp_Object a)
{
/* This version of DEFUN declares a function prototype with the right
arguments, so we can catch errors with maxargs at compile-time. */
-#ifdef _MSC_VER
-#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \
- SCM_SNARF_INIT (defsubr (&sname);) \
- Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \
- static struct Lisp_Subr alignas (GCALIGNMENT) sname = \
- { { NULL, \
- (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) \
- | (sizeof (struct Lisp_Subr) / sizeof (EMACS_INT)) }, \
- { (Lisp_Object (__cdecl *)(void))fnname }, \
- minargs, maxargs, lname, intspec, 0}; \
- Lisp_Object fnname
-#else /* not _MSC_VER */
#define DEFUN(lname, fnname, sname, minargs, maxargs, intspec, doc) \
- SCM_SNARF_INIT (defsubr (&sname);) \
+ SCM_SNARF_INIT (defsubr (lname, gsubr_ ## fnname, minargs, maxargs, intspec)) \
Lisp_Object fnname DEFUN_ARGS_ ## maxargs ; \
- static struct Lisp_Subr alignas (GCALIGNMENT) sname = \
- { { .self = NULL, \
- .size = PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \
- { .a ## maxargs = fnname }, \
- minargs, maxargs, lname, intspec, 0}; \
+ DEFUN_GSUBR_ ## maxargs (lname, fnname, minargs, maxargs) \
Lisp_Object fnname
-#endif
+
+#define GSUBR_ARGS_1(f) f (arg1)
+#define GSUBR_ARGS_2(f) GSUBR_ARGS_1 (f), f (arg2)
+#define GSUBR_ARGS_3(f) GSUBR_ARGS_2 (f), f (arg3)
+#define GSUBR_ARGS_4(f) GSUBR_ARGS_3 (f), f (arg4)
+#define GSUBR_ARGS_5(f) GSUBR_ARGS_4 (f), f (arg5)
+#define GSUBR_ARGS_6(f) GSUBR_ARGS_5 (f), f (arg6)
+#define GSUBR_ARGS_7(f) GSUBR_ARGS_6 (f), f (arg7)
+#define GSUBR_ARGS_8(f) GSUBR_ARGS_7 (f), f (arg8)
+
+#define GSUBR_ARGS(n) GSUBR_ARGS_PASTE (GSUBR_ARGS_, n)
+#define GSUBR_ARGS_PASTE(a, b) a ## b
+
+#define DEFUN_GSUBR_N(fn, maxargs) \
+ Lisp_Object \
+ gsubr_ ## fn \
+ (GSUBR_ARGS (maxargs) (Lisp_Object)) \
+ { \
+ return fn (GSUBR_ARGS (maxargs) (GSUBR_ARG)); \
+ }
+#define GSUBR_ARG(x) (SCM_UNBNDP (x) ? Qnil : x)
+
+#define DEFUN_GSUBR_0(lname, fn, minargs, maxargs) \
+ Lisp_Object gsubr_ ## fn (void) { return fn (); }
+#define DEFUN_GSUBR_1(lname, fn, min, max) DEFUN_GSUBR_N(fn, max)
+#define DEFUN_GSUBR_2(lname, fn, min, max) DEFUN_GSUBR_N(fn, max)
+#define DEFUN_GSUBR_3(lname, fn, min, max) DEFUN_GSUBR_N(fn, max)
+#define DEFUN_GSUBR_4(lname, fn, min, max) DEFUN_GSUBR_N(fn, max)
+#define DEFUN_GSUBR_5(lname, fn, min, max) DEFUN_GSUBR_N(fn, max)
+#define DEFUN_GSUBR_6(lname, fn, min, max) DEFUN_GSUBR_N(fn, max)
+#define DEFUN_GSUBR_7(lname, fn, min, max) DEFUN_GSUBR_N(fn, max)
+#define DEFUN_GSUBR_8(lname, fn, min, max) DEFUN_GSUBR_N(fn, max)
+
+#define DEFUN_GSUBR_UNEVALLED(lname, fn, minargs, maxargs) \
+ Lisp_Object \
+ gsubr_ ## fn (Lisp_Object rest) \
+ { \
+ Lisp_Object len = Flength (rest); \
+ if (XINT (len) < minargs) \
+ xsignal2 (Qwrong_number_of_arguments, \
+ intern (lname), len); \
+ return fn (rest); \
+ }
+#define DEFUN_GSUBR_MANY(lname, fn, minargs, maxargs) \
+ Lisp_Object \
+ gsubr_ ## fn (Lisp_Object rest) \
+ { \
+ int len = scm_to_int (scm_length (rest)); \
+ Lisp_Object *args; \
+ SAFE_ALLOCA_LISP (args, len); \
+ int i; \
+ for (i = 0; \
+ i < len && scm_is_pair (rest); \
+ i++, rest = SCM_CDR (rest)) \
+ args[i] = SCM_CAR (rest); \
+ if (i < minargs) \
+ xsignal2 (Qwrong_number_of_arguments, \
+ intern (lname), make_number (i)); \
+ return fn (i, args); \
+ }
/* Note that the weird token-substitution semantics of ANSI C makes
this work for MANY and UNEVALLED. */
/* defsubr (Sname);
is how we define the symbol for function `name' at start-up time. */
-extern void defsubr (struct Lisp_Subr *);
+extern void defsubr (const char *, scm_t_subr, short, short, const char *);
enum maxargs
{
extern Lisp_Object Qsequencep;
extern Lisp_Object Qchar_or_string_p, Qinteger_or_marker_p;
extern Lisp_Object Qfboundp;
+extern Lisp_Object Qspecial_operator;
extern Lisp_Object Qcdr;
}
}
- if (SUBRP (object))
- return XSUBR (object)->max_args != UNEVALLED;
+ if (scm_is_true (scm_procedure_p (object)))
+ return 1;
else if (COMPILEDP (object))
return true;
else if (CONSP (object))
Lisp_Object car = XCAR (object);
return EQ (car, Qlambda) || EQ (car, Qclosure);
}
- else
- return scm_is_true (scm_procedure_p (object));
}
INLINE_HEADER_END
}
\f
void
-defsubr (struct Lisp_Subr *sname)
+defsubr (const char *lname, scm_t_subr gsubr_fn, short min_args, short max_args, const char *intspec)
{
- Lisp_Object sym, tem;
- sym = intern_c_string (sname->symbol_name);
- SCM_NEWSMOB (sname->header.self, lisp_vectorlike_tag, sname);
- XSETPVECTYPE (sname, PVEC_SUBR);
- XSETSUBR (tem, sname);
- set_symbol_function (sym, tem);
+ Lisp_Object sym = intern_c_string (lname);
+ Lisp_Object fn;
+ switch (max_args)
+ {
+ case MANY:
+ fn = scm_c_make_gsubr (lname, 0, 0, 1, gsubr_fn);
+ break;
+ case UNEVALLED:
+ fn = Fcons (Qspecial_operator,
+ scm_c_make_gsubr (lname, 0, 0, 1, gsubr_fn));
+ break;
+ default:
+ fn = scm_c_make_gsubr (lname, min_args, max_args - min_args, 0, gsubr_fn);
+ break;
+ }
+ set_symbol_function (sym, fn);
+ if (intspec)
+ {
+ Lisp_Object tem = ((*intspec != '(')
+ ? build_string (intspec)
+ : Fcar (Fread_from_string (build_string (intspec),
+ Qnil, Qnil)));
+ scm_set_procedure_property_x (fn, Qinteractive_form, tem);
+ }
}
/* Define an "integer variable"; a symbol whose value is forwarded to a
UNGCPRO;
}
- else if (SUBRP (obj))
- {
- strout ("#<subr ", -1, -1, printcharfun);
- strout (XSUBR (obj)->symbol_name, -1, -1, printcharfun);
- PRINTCHAR ('>');
- }
else if (WINDOWP (obj))
{
int len;
init_print_once (void)
{
DEFSYM (Qexternal_debugging_output, "external-debugging-output");
- defsubr (&Sexternal_debugging_output);
+ defsubr ("external-debugging-output", gsubr_Fexternal_debugging_output, 1, 1, 0);
}
void
#if defined (USE_GTK) || defined (USE_X_TOOLKIT)
Ffset (intern_c_string ("accelerate-menu"),
- intern_c_string (Sx_menu_bar_open_internal.symbol_name));
+ intern_c_string ("x-menu-bar-open-internal"));
#endif
}
HCoop / bpt / emacs.git / commitdiff