>From 353dd712d8dc94b17d5382f571c81cb9693887d9 Mon Sep 17 00:00:00 2001 From: Alexander Gramiak 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; } + -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); +} + /* 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) } +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); +} + + /* 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