From: Alex Gramiak <agrambot@gmail.com>
To: emacs-devel@gnu.org
Subject: [RFC] Some new vector procedures (vector-{memq, apply, to-string, ...})
Date: Fri, 19 Apr 2019 14:49:39 -0600 [thread overview]
Message-ID: <8736md90v0.fsf@gmail.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 381 bytes --]
Here are a few procedures that should make using vectors in Elisp a bit
nicer. They are in C since all the Elisp versions I've tried were too
slow for such simple procedures.
I started with just vector-memq, but the other ones should have some
application as well. I took vector-index and vector-partition from SRFI
133 [1].
[1] https://srfi.schemers.org/srfi-133/srfi-133.html
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: vectors --]
[-- Type: text/x-patch, Size: 9007 bytes --]
From 353dd712d8dc94b17d5382f571c81cb9693887d9 Mon Sep 17 00:00:00 2001
From: Alexander Gramiak <agrambot@gmail.com>
Date: Fri, 19 Apr 2019 13:58:39 -0600
Subject: [PATCH] Add some new vector procedures
* src/eval.c (apply_helper): New helper procedure.
(apply): Move most of body to apply_helper.
(vector-apply): New procedure.
* src/fns.c (vector-memq, vector-member, vector-assq, vector-assoc)
(vector-index, vector-partition, vector-to-string): New procedures.
---
src/eval.c | 93 +++++++++++++++++++++++++++-----------
src/fns.c | 130 +++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 198 insertions(+), 25 deletions(-)
diff --git a/src/eval.c b/src/eval.c
index c2e996a947..bf8de51bf8 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2375,32 +2375,16 @@ eval_sub (Lisp_Object form)
return val;
}
+
\f
-DEFUN ("apply", Fapply, Sapply, 1, MANY, 0,
- doc: /* Call FUNCTION with our remaining args, using our last arg as list of args.
-Then return the value FUNCTION returns.
-Thus, (apply \\='+ 1 2 \\='(3 4)) returns 10.
-usage: (apply FUNCTION &rest ARGUMENTS) */)
- (ptrdiff_t nargs, Lisp_Object *args)
+static Lisp_Object
+apply_helper (ptrdiff_t nargs, ptrdiff_t numargs, Lisp_Object fun,
+ Lisp_Object spread_arg, Lisp_Object *args)
{
- ptrdiff_t i, funcall_nargs;
+ ptrdiff_t funcall_nargs;
Lisp_Object *funcall_args = NULL;
- Lisp_Object spread_arg = args[nargs - 1];
- Lisp_Object fun = args[0];
USE_SAFE_ALLOCA;
- ptrdiff_t numargs = list_length (spread_arg);
-
- if (numargs == 0)
- return Ffuncall (nargs - 1, args);
- else if (numargs == 1)
- {
- args [nargs - 1] = XCAR (spread_arg);
- return Ffuncall (nargs, args);
- }
-
- numargs += nargs - 2;
-
/* Optimize for no indirection. */
if (SYMBOLP (fun) && !NILP (fun)
&& (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
@@ -2432,11 +2416,20 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
memcpy (funcall_args, args, nargs * word_size);
/* Spread the last arg we got. Its first element goes in
the slot that it used to occupy, hence this value of I. */
- i = nargs - 1;
- while (!NILP (spread_arg))
+ if (CONSP (spread_arg))
+ {
+ ptrdiff_t i = nargs - 1;
+ while (!NILP (spread_arg))
+ {
+ funcall_args [i++] = XCAR (spread_arg);
+ spread_arg = XCDR (spread_arg);
+ }
+ }
+ else
{
- funcall_args [i++] = XCAR (spread_arg);
- spread_arg = XCDR (spread_arg);
+ memcpy (funcall_args + nargs - 1,
+ XVECTOR (spread_arg)->contents,
+ ASIZE (spread_arg) * word_size);
}
Lisp_Object retval = Ffuncall (funcall_nargs, funcall_args);
@@ -2444,6 +2437,55 @@ usage: (apply FUNCTION &rest ARGUMENTS) */)
SAFE_FREE ();
return retval;
}
+
+DEFUN ("apply", Fapply, Sapply, 1, MANY, 0,
+ doc: /* Call FUNCTION with our remaining args, using our last arg as list of args.
+Then return the value FUNCTION returns.
+Thus, (apply #\\='+ 1 2 \\='(3 4)) returns 10.
+usage: (apply FUNCTION &rest ARGUMENTS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ Lisp_Object spread_arg = args[nargs - 1];
+ Lisp_Object fun = args[0];
+
+ ptrdiff_t numargs = list_length (spread_arg);
+
+ if (numargs == 0)
+ return Ffuncall (nargs - 1, args);
+ else if (numargs == 1)
+ {
+ args [nargs - 1] = XCAR (spread_arg);
+ return Ffuncall (nargs, args);
+ }
+
+ return apply_helper (nargs, numargs + nargs - 2, fun, spread_arg, args);
+}
+
+DEFUN ("vector-apply", Fvector_apply, Svector_apply, 1, MANY, 0,
+ doc: /* Call FUNCTION with our remaining args, using our last arg as a vector of args.
+Then return the value FUNCTION returns.
+Thus, (vector-apply #\\='+ 1 2 [3 4]) returns 10.
+usage: (vector-apply FUNCTION &rest ARGUMENTS) */)
+ (ptrdiff_t nargs, Lisp_Object *args)
+{
+ Lisp_Object spread_arg = args[nargs - 1];
+ Lisp_Object fun = args[0];
+
+ CHECK_VECTOR (spread_arg);
+
+ ptrdiff_t numargs = ASIZE (spread_arg);
+
+ if (!numargs)
+ return Ffuncall (nargs - 1, args);
+ else if (numargs == 1)
+ {
+ args [nargs - 1] = AREF (spread_arg, 0);
+ return Ffuncall (nargs, args);
+ }
+
+ return apply_helper (nargs, numargs + nargs - 2, fun, spread_arg, args);
+}
+
\f
/* Run hook variables in various ways. */
@@ -4236,6 +4278,7 @@ alist of active lexical bindings. */);
defsubr (&Sautoload_do_load);
defsubr (&Seval);
defsubr (&Sapply);
+ defsubr (&Svector_apply);
defsubr (&Sfuncall);
defsubr (&Sfunc_arity);
defsubr (&Srun_hooks);
diff --git a/src/fns.c b/src/fns.c
index c3202495da..de37240aaa 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2134,6 +2134,129 @@ merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred)
}
\f
+DEFUN ("vector-memq", Fvector_memq, Svector_memq, 2, 2, 0,
+ doc: /* Return index of ELT in VECTOR. Comparison done with `eq'.
+The value is nil if ELT is not found in VECTOR. */)
+ (Lisp_Object elt, Lisp_Object vector)
+{
+ CHECK_VECTOR (vector);
+ const ptrdiff_t len = ASIZE (vector);
+
+ for (ptrdiff_t i = 0; i < len; ++i)
+ if (EQ (elt, AREF (vector, i)))
+ return make_fixnum (i);
+
+ return Qnil;
+}
+
+DEFUN ("vector-member", Fvector_member, Svector_member, 2, 2, 0,
+ doc: /* Return index of ELT in VECTOR. Comparison done with `equal'.
+The value is nil if ELT is not found in VECTOR. */)
+ (Lisp_Object elt, Lisp_Object vector)
+{
+ CHECK_VECTOR (vector);
+ const ptrdiff_t len = ASIZE (vector);
+
+ for (ptrdiff_t i = 0; i < len; ++i)
+ if (Fequal (elt, AREF (vector, i)))
+ return make_fixnum (i);
+
+ return Qnil;
+}
+
+DEFUN ("vector-assq", Fvector_assq, Svector_assq, 2, 2, 0,
+ doc: /* Return the index of KEY in the association vector VECTOR.
+Elements of VECTOR that are not vectors are ignored. */)
+ (Lisp_Object key, Lisp_Object vector)
+{
+ CHECK_VECTOR (vector);
+ const ptrdiff_t len = ASIZE (vector);
+
+ for (ptrdiff_t i = 0; i < len; ++i)
+ if (VECTORP (AREF (vector, i))
+ && EQ (key, AREF (AREF (vector, i), 0)))
+ return make_fixnum (i);
+
+ return Qnil;
+}
+
+DEFUN ("vector-assoc", Fvector_assoc, Svector_assoc, 2, 2, 0,
+ doc: /* Return the index of KEY in the association vector VECTOR.
+Elements of VECTOR that are not vectors are ignored. */)
+ (Lisp_Object key, Lisp_Object vector)
+{
+ CHECK_VECTOR (vector);
+ const ptrdiff_t len = ASIZE (vector);
+
+ for (ptrdiff_t i = 0; i < len; ++i)
+ if (VECTORP (AREF (vector, i))
+ && Fequal (key, AREF (AREF (vector, i), 0)))
+ return make_fixnum (i);
+
+ return Qnil;
+}
+
+DEFUN ("vector-index", Fvector_index, Svector_index, 2, 2, 0,
+ doc: /* Return the index of the first KEY satisfying (PRED KEY) in the vector VECTOR. */)
+ (Lisp_Object pred, Lisp_Object vector)
+{
+ CHECK_VECTOR (vector);
+ const ptrdiff_t len = ASIZE (vector);
+
+ for (ptrdiff_t i = 0; i < len; ++i)
+ if (!NILP (call1 (pred, AREF (vector, i))))
+ return make_fixnum (i);
+
+ return Qnil;
+}
+
+DEFUN ("vector-partition", Fvector_partition, Svector_partition, 2, 2, 0,
+ doc: /* Return a vector that partitions the elements of VECTOR by PRED.
+
+The vector contains two vectors that contain elements that satisfy and
+do not satisfy PRED respectively.
+For example: (vector-partition #'fixnump [1 2 3.0 4 5.0])
+ => [[1 2 4] [3.0 5.0]] */)
+ (Lisp_Object pred, Lisp_Object vector)
+{
+ CHECK_VECTOR (vector);
+ const ptrdiff_t len = ASIZE (vector);
+ Lisp_Object *satisfying = NULL;
+ Lisp_Object *failing = NULL;
+ ptrdiff_t s_count = 0;
+ ptrdiff_t f_count = 0;
+ USE_SAFE_ALLOCA;
+
+ SAFE_ALLOCA_LISP (satisfying, len);
+ SAFE_ALLOCA_LISP (failing, len);
+
+ for (ptrdiff_t i = 0; i < len; ++i)
+ {
+ register Lisp_Object tem = AREF (vector, i);
+ if (!NILP (call1 (pred, tem)))
+ satisfying[s_count++] = tem;
+ else
+ failing[f_count++] = tem;
+ }
+
+ Lisp_Object partitions[2] =
+ { Fvector (s_count, satisfying),
+ Fvector (f_count, failing) };
+ Lisp_Object result = Fvector (2, partitions);
+ SAFE_FREE ();
+ return result;
+}
+
+DEFUN ("vector-to-string", Fvector_to_string, Svector_to_string, 1, 1, 0,
+ doc: /* Return a string containing the elements of VECTOR. */)
+ (Lisp_Object vector)
+{
+ CHECK_VECTOR (vector);
+
+ return Fstring (ASIZE (vector), XVECTOR (vector)->contents);
+}
+
+\f
/* This does not check for quits. That is safe since it must terminate. */
DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0,
@@ -5417,6 +5540,13 @@ this variable. */);
defsubr (&Sdelete);
defsubr (&Snreverse);
defsubr (&Sreverse);
+ defsubr (&Svector_memq);
+ defsubr (&Svector_member);
+ defsubr (&Svector_assq);
+ defsubr (&Svector_assoc);
+ defsubr (&Svector_index);
+ defsubr (&Svector_partition);
+ defsubr (&Svector_to_string);
defsubr (&Ssort);
defsubr (&Splist_get);
defsubr (&Sget);
--
2.21.0
next reply other threads:[~2019-04-19 20:49 UTC|newest]
Thread overview: 15+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-04-19 20:49 Alex Gramiak [this message]
2019-04-20 7:04 ` [RFC] Some new vector procedures (vector-{memq, apply, to-string, ...}) Eli Zaretskii
2019-04-20 16:50 ` Alex Gramiak
2019-04-20 17:16 ` Eli Zaretskii
2019-04-20 18:18 ` Alex Gramiak
2019-04-20 19:11 ` Eli Zaretskii
2019-04-20 19:54 ` Alan Mackenzie
2019-04-20 20:09 ` Óscar Fuentes
2019-04-20 22:54 ` Paul Eggert
2019-04-21 3:01 ` Using SMALL_LIST_LEN_MAX for memq and list_length (was: [RFC] Some new vector procedures (vector-{memq, apply, to-string, ...})) Alex Gramiak
2019-04-21 1:52 ` [RFC] Some new vector procedures (vector-{memq, apply, to-string, ...}) Alex Gramiak
2019-04-21 5:50 ` Eli Zaretskii
2019-04-21 4:05 ` Stefan Monnier
2019-04-21 20:34 ` Alex Gramiak
2019-04-21 21:01 ` Stefan Monnier
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=8736md90v0.fsf@gmail.com \
--to=agrambot@gmail.com \
--cc=emacs-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/emacs.git
https://git.savannah.gnu.org/cgit/emacs/org-mode.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.