From 62947569a1716052da3e63d93a8289dd103a51e3 Mon Sep 17 00:00:00 2001 From: BT Templeton Date: Thu, 22 Aug 2013 01:43:31 -0400 Subject: [PATCH] use guile subrs * 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. --- src/data.c | 59 +++++++++----- src/doc.c | 28 +++---- src/emacs.c | 7 +- src/eval.c | 220 ++-------------------------------------------------- src/lisp.h | 131 +++++++++++++++---------------- src/lread.c | 32 ++++++-- src/print.c | 8 +- src/xmenu.c | 2 +- 8 files changed, 157 insertions(+), 330 deletions(-) diff --git a/src/data.c b/src/data.c index 426bae133a..7422f4e8b8 100644 --- a/src/data.c +++ b/src/data.c @@ -87,6 +87,7 @@ static Lisp_Object Qmany, Qunevalled; 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; @@ -141,7 +142,7 @@ XOBJFWD (union Lisp_Fwd *a) static void CHECK_SUBR (Lisp_Object x) { - CHECK_TYPE (SUBRP (x), Qsubrp, x); + CHECK_TYPE (! NILP (Fsubrp (x)), Qsubrp, x); } static void @@ -274,8 +275,6 @@ for example, (type-of 1) returns `integer'. */) return Qprocess; if (WINDOWP (object)) return Qwindow; - if (SUBRP (object)) - return Qsubr; if (COMPILEDP (object)) return Qcompiled_function; if (BUFFERP (object)) @@ -298,6 +297,8 @@ for example, (type-of 1) returns `integer'. */) } else if (FLOATP (object)) return Qfloat; + else if (! NILP (Fsubrp (object))) + return Qsubr; else return Qt; } @@ -469,7 +470,9 @@ DEFUN ("subrp", Fsubrp, Ssubrp, 1, 1, 0, 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; } @@ -800,14 +803,27 @@ of args. MAX is the maximum number or the symbol `many', for a 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, @@ -815,10 +831,10 @@ 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, @@ -844,13 +860,11 @@ Value, if non-nil, is a list \(interactive SPEC). */) 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)) { @@ -3387,6 +3401,10 @@ syms_of_data (void) { 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"); @@ -3553,7 +3571,6 @@ syms_of_data (void) 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)); diff --git a/src/doc.c b/src/doc.c index 4d9434ce9f..a0d01c2b73 100644 --- a/src/doc.c +++ b/src/doc.c @@ -350,18 +350,17 @@ string is passed through `substitute-command-keys'. */) } 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)) { @@ -501,11 +500,12 @@ store_function_docstring (Lisp_Object obj, ptrdiff_t offset) /* 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. */ @@ -523,7 +523,7 @@ store_function_docstring (Lisp_Object obj, ptrdiff_t offset) 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); } diff --git a/src/emacs.c b/src/emacs.c index d4611f85ea..01b8368298 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -1198,6 +1198,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem 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 @@ -1212,8 +1217,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem 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. */ diff --git a/src/eval.c b/src/eval.c index e6b39a5064..d1397e0ab2 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1872,11 +1872,9 @@ then strings and vectors are not accepted. */) 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. */ @@ -2180,119 +2178,13 @@ eval_sub_1 (Lisp_Object form) 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); @@ -2413,26 +2305,8 @@ usage: (apply FUNCTION &rest ARGUMENTS) */) { /* 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) @@ -2889,86 +2763,6 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) { 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 diff --git a/src/lisp.h b/src/lisp.h index 0143506736..e0a4cdfee1 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -440,7 +440,6 @@ enum pvec_type PVEC_HASH_TABLE, PVEC_TERMINAL, PVEC_WINDOW_CONFIGURATION, - PVEC_SUBR, PVEC_OTHER, /* These should be last, check internal_equal to see why. */ PVEC_COMPILED, @@ -566,7 +565,6 @@ INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t, 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); @@ -685,13 +683,6 @@ XTERMINAL (Lisp_Object a) 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) { @@ -1240,32 +1231,6 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) 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. */ @@ -2134,12 +2099,6 @@ TERMINALP (Lisp_Object a) return PSEUDOVECTORP (a, PVEC_TERMINAL); } -INLINE bool -SUBRP (Lisp_Object a) -{ - return PSEUDOVECTORP (a, PVEC_SUBR); -} - INLINE bool COMPILEDP (Lisp_Object a) { @@ -2350,28 +2309,71 @@ CHECK_NUMBER_CDR (Lisp_Object x) /* 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. */ @@ -2400,7 +2402,7 @@ FUNCTIONP (Lisp_Object obj) /* 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 { @@ -2850,6 +2852,7 @@ extern Lisp_Object Qcircular_list; 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; @@ -3996,8 +3999,8 @@ functionp (Lisp_Object object) } } - 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)) @@ -4005,8 +4008,6 @@ functionp (Lisp_Object 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 diff --git a/src/lread.c b/src/lread.c index d883cda62f..a57cab6f79 100644 --- a/src/lread.c +++ b/src/lread.c @@ -4035,14 +4035,32 @@ init_obarray (void) } 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 diff --git a/src/print.c b/src/print.c index 672a780792..05a5dd70ae 100644 --- a/src/print.c +++ b/src/print.c @@ -1768,12 +1768,6 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) UNGCPRO; } - else if (SUBRP (obj)) - { - strout ("#symbol_name, -1, -1, printcharfun); - PRINTCHAR ('>'); - } else if (WINDOWP (obj)) { int len; @@ -2206,7 +2200,7 @@ void 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 diff --git a/src/xmenu.c b/src/xmenu.c index aa208f871a..0de8faaf36 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -2346,6 +2346,6 @@ syms_of_xmenu (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 } -- 2.20.1