From 54e0af41949694191b5ef6c3a1f04efe206dc433 Mon Sep 17 00:00:00 2001 From: Thuna Date: Sun, 17 Nov 2024 18:28:38 +0100 Subject: [PATCH] Unify closure allocators --- lisp/emacs-lisp/bytecomp.el | 2 +- lisp/emacs-lisp/oclosure.el | 2 +- src/alloc.c | 115 +++++++++++++++++++++++++++++++++++- src/data.c | 1 + src/eval.c | 36 ----------- 5 files changed, 117 insertions(+), 39 deletions(-) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f058fc48cc7..187955f92db 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -4202,7 +4202,7 @@ byte-compile-make-closure ; have been stripped in ; `byte-compile-lambda'. opt-args)))) - `(make-closure ,proto-fun ,@env)) + `(copy-closure ,proto-fun ,@env)) ;; Nontrivial doc string expression: create a bytecode object ;; from small pieces at run time. `(make-byte-code diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 165d7c4b6e8..4c6b848227e 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -441,7 +441,7 @@ oclosure--fix-type (defun oclosure--copy (oclosure mutlist &rest args) (cl-assert (closurep oclosure)) (if (byte-code-function-p oclosure) - (apply #'make-closure oclosure + (apply #'copy-closure oclosure (if (null mutlist) args (mapcar (lambda (arg) (if (pop mutlist) (list arg) arg)) args))) diff --git a/src/alloc.c b/src/alloc.c index 4fab0d54248..2ab2d96af40 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3848,7 +3848,116 @@ and (optional) INTERACTIVE-SPEC. return val; } -DEFUN ("make-closure", Fmake_closure, Smake_closure, 1, MANY, 0, +Lisp_Object +make_closure (Lisp_Object argdesc, Lisp_Object code, Lisp_Object env, + Lisp_Object depth, Lisp_Object docstring, Lisp_Object iform) +{ + ptrdiff_t nargs; + Lisp_Object value, slots[6]; + + slots[CLOSURE_ARGLIST] = argdesc; + slots[CLOSURE_CODE] = code; + slots[CLOSURE_CONSTANTS] = env; + slots[CLOSURE_STACK_DEPTH] = depth; + slots[CLOSURE_DOC_STRING] = docstring; + slots[CLOSURE_INTERACTIVE] = iform; + + nargs = !NILP (iform) ? 6 + : !NILP (docstring) ? 5 + : !NILP (depth) ? 4 + : 3; + value = Fvector (nargs, slots); + XSETPVECTYPE (XVECTOR (value), PVEC_CLOSURE); + return value; +} + +DEFUN ("make-interpreted-closure", Fmake_interpreted_closure, + Smake_interpreted_closure, 3, 5, 0, + doc: /* Make an interpreted closure. +ARGS should be the list of formal arguments. +BODY should be a non-empty list of forms. +ENV should be a lexical environment, like the second argument of `eval'. +IFORM if non-nil should be of the form (interactive ...). */) + (Lisp_Object args, Lisp_Object body, Lisp_Object env, + Lisp_Object docstring, Lisp_Object iform) +{ + CHECK_LIST (args); + CHECK_CONS (body); + CHECK_LIST (iform); + + Lisp_Object ifcdr = CDR (iform); + if (NILP (CDR (ifcdr))) + iform = CAR (ifcdr); + else + iform = CALLN (Fvector, XCAR (ifcdr), XCDR (ifcdr)); + + return make_closure (args, body, env, Qnil, docstring, iform); +} + +DEFUN ("make-compiled-closure", Fmake_compiled_closure, + Smake_compiled_closure, 4, 6, 0, + doc: /* Create and return a byte-compiled closure. + +See `make-closure' for the meaning of the arguments. */) + (Lisp_Object argdesc, Lisp_Object bytecode, Lisp_Object constants, + Lisp_Object depth, Lisp_Object docstring, Lisp_Object iform) +{ + CHECK_TYPE (NILP (argdesc) || CONSP (argdesc) || FIXNUMP (argdesc), + list3 (Qor, Qlistp, Qfixnump), + argdesc); + CHECK_STRING (bytecode); + if (STRING_MULTIBYTE (bytecode)) + error ("Multibyte byte-code"); + CHECK_VECTOR (constants); + CHECK_FIXNAT (depth); + + /* Bytecode must be immovable. */ + pin_string (bytecode); + + return make_closure (argdesc, bytecode, constants, depth, docstring, iform); +} + +DEFUN ("make-closure", Fmake_closure, Smake_closure, 2, 6, 0, + doc: /* Create and return a closure object. + +ARGDESC is either be a lambda list that is recognized by `lambda', or a +fixnum of the form NNNNNNNRMMMMMMM where the 7bit MMMMMMM specifies the +minimum number of arguments, the 7-bit NNNNNNN specifies the maximum +number of arguments (ignoring &rest) and the R bit specifies whether +there is a &rest argument to catch the left-over arguments. ARGDESC can +only be an integer for byte compiled closures. + +For interpreted closures, CODE is a non-empty list of elisp forms which +make up the closure's body. For byte compiled closures, CODE is a +unibyte string containing the byte code instructions. + +For byte compiled closures, ENV holds the vector of elisp objects +referenced by the byte code. For interpreted closures, if the closure +uses dynamic scoping, ENV is nil, otherwise it is the lexical +environment, like the second argument of `eval'. + +For byte compiled closures, DEPTH is the maximum stack size needed. +DEPTH should be nil for interpreted closures. + +DOCSTRING, if non-nil, should be a string containing the documentation, +or a number or a list, in case the documentation is stored in a file. + +IFORM, if non-nil, should be a string or an elisp form. If nil, +the closure is non-interactive. */) + (Lisp_Object argdesc, Lisp_Object code, Lisp_Object env, + Lisp_Object depth, Lisp_Object docstring, Lisp_Object iform) +{ + if (CONSP (code)) + return Fmake_interpreted_closure + (argdesc, code, env, docstring, + NILP (iform) ? Qnil : list2 (Qinteractive, iform)); + else if (STRINGP (code)) + return Fmake_compiled_closure (argdesc, code, env, depth, docstring, iform); + else + wrong_type_argument (list3 (Qor, Qconsp, Qstringp), code); +} + +DEFUN ("copy-closure", Fcopy_closure, Scopy_closure, 1, MANY, 0, doc: /* Create a byte-code closure from PROTOTYPE and CLOSURE-VARS. Return a copy of PROTOTYPE, a byte-code object, with CLOSURE-VARS replacing the elements in the beginning of the constant-vector. @@ -8232,6 +8341,7 @@ syms_of_alloc (void) DEFSYM (Qvector_slots, "vector-slots"); DEFSYM (Qheap, "heap"); DEFSYM (QAutomatic_GC, "Automatic GC"); + DEFSYM (Qvalid_docstring_p, "valid-docstring-p"); DEFSYM (Qgc_cons_percentage, "gc-cons-percentage"); DEFSYM (Qgc_cons_threshold, "gc-cons-threshold"); @@ -8254,7 +8364,10 @@ syms_of_alloc (void) defsubr (&Srecord); defsubr (&Sbool_vector); defsubr (&Smake_byte_code); + defsubr (&Smake_interpreted_closure); + defsubr (&Smake_compiled_closure); defsubr (&Smake_closure); + defsubr (&Scopy_closure); defsubr (&Smake_list); defsubr (&Smake_vector); defsubr (&Smake_record); diff --git a/src/data.c b/src/data.c index 66cf34c1e60..83ecd040dca 100644 --- a/src/data.c +++ b/src/data.c @@ -4067,6 +4067,7 @@ syms_of_data (void) DEFSYM (Qoclosure_interactive_form, "oclosure-interactive-form"); DEFSYM (Qsubrp, "subrp"); + DEFSYM (Qclosurep, "closurep"); DEFSYM (Qunevalled, "unevalled"); DEFSYM (Qmany, "many"); diff --git a/src/eval.c b/src/eval.c index d0a2abf0089..836930259b0 100644 --- a/src/eval.c +++ b/src/eval.c @@ -517,41 +517,6 @@ DEFUN ("quote", Fquote, Squote, 1, UNEVALLED, 0, return XCAR (args); } -DEFUN ("make-interpreted-closure", Fmake_interpreted_closure, - Smake_interpreted_closure, 3, 5, 0, - doc: /* Make an interpreted closure. -ARGS should be the list of formal arguments. -BODY should be a non-empty list of forms. -ENV should be a lexical environment, like the second argument of `eval'. -IFORM if non-nil should be of the form (interactive ...). */) - (Lisp_Object args, Lisp_Object body, Lisp_Object env, - Lisp_Object docstring, Lisp_Object iform) -{ - Lisp_Object ifcdr, value, slots[6]; - - CHECK_CONS (body); /* Make sure it's not confused with byte-code! */ - CHECK_LIST (args); - CHECK_LIST (iform); - ifcdr = CDR (iform); - if (NILP (CDR (ifcdr))) - value = CAR (ifcdr); - else - value = CALLN (Fvector, XCAR (ifcdr), XCDR (ifcdr)); - slots[0] = args; - slots[1] = body; - slots[2] = env; - slots[3] = Qnil; - slots[4] = docstring; - slots[5] = value; - /* Adjusting the size is indispensable since, as for byte-code objects, - we distinguish interactive functions by the presence or absence of the - iform slot. */ - Lisp_Object val - = Fvector (!NILP (iform) ? 6 : !NILP (docstring) ? 5 : 3, slots); - XSETPVECTYPE (XVECTOR (val), PVEC_CLOSURE); - return val; -} - DEFUN ("function", Ffunction, Sfunction, 1, UNEVALLED, 0, doc: /* Like `quote', but preferred for objects which are functions. In byte compilation, `function' causes its argument to be handled by @@ -4491,7 +4456,6 @@ syms_of_eval (void) defsubr (&Ssetq); defsubr (&Squote); defsubr (&Sfunction); - defsubr (&Smake_interpreted_closure); defsubr (&Sdefault_toplevel_value); defsubr (&Sset_default_toplevel_value); defsubr (&Sdefvar); -- 2.44.2