From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!.POSTED.blaine.gmane.org!not-for-mail From: Alex Gramiak Newsgroups: gmane.emacs.devel Subject: [RFC] Some new vector procedures (vector-{memq, apply, to-string, ...}) Date: Fri, 19 Apr 2019 14:49:39 -0600 Message-ID: <8736md90v0.fsf@gmail.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Injection-Info: blaine.gmane.org; posting-host="blaine.gmane.org:195.159.176.226"; logging-data="259883"; mail-complaints-to="usenet@blaine.gmane.org" User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) To: emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Fri Apr 19 22:56:55 2019 Return-path: Envelope-to: ged-emacs-devel@m.gmane.org Original-Received: from lists.gnu.org ([209.51.188.17]) by blaine.gmane.org with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:256) (Exim 4.89) (envelope-from ) id 1hHaZ3-0015RT-QL for ged-emacs-devel@m.gmane.org; Fri, 19 Apr 2019 22:56:54 +0200 Original-Received: from localhost ([127.0.0.1]:33077 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hHaZ2-0000Em-Of for ged-emacs-devel@m.gmane.org; Fri, 19 Apr 2019 16:56:52 -0400 Original-Received: from eggs.gnu.org ([209.51.188.92]:48424) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hHaYL-00085H-2S for emacs-devel@gnu.org; Fri, 19 Apr 2019 16:56:10 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hHaS3-0006jz-JQ for emacs-devel@gnu.org; Fri, 19 Apr 2019 16:49:41 -0400 Original-Received: from mail-pf1-x434.google.com ([2607:f8b0:4864:20::434]:36313) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hHaS3-0006jH-86 for emacs-devel@gnu.org; Fri, 19 Apr 2019 16:49:39 -0400 Original-Received: by mail-pf1-x434.google.com with SMTP id z5so3014797pfn.3 for ; Fri, 19 Apr 2019 13:49:39 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:subject:date:message-id:user-agent:mime-version; bh=rEF6pLVdO3QlLPaUxJPQlz2f/HrvYgLfvWEn2RDGuJI=; b=tWAYNRstO/3xytr2Sr7caS3TjSGs4YS6EVuKhcgXsdwL1KVl2t6Xh00q28qhMlyppv CdJM7zBRiV2hrh0bwo0TkMAulCE56qh4+BF7qRb7jxqe61Uejfc2nTVwSzsx8bLykt9l 4Nd9sX1B0IFGBr+fquVBrM2GuLU7AU/R18jr5ny9OVWWjGfGVACtinoo9Kclc1aC2Rro n/7DOVNOjgdzN1RuJZTRkl8KqwmlSS+c9khwq9ylf7bUXu+HwrxYOI5mmLWZLD/rtisN oGDiC9/O5AAe3A+/1fejkbEDLsTQCWLxXRg3L8BuHgLHTs2WM7+K31mWTq+PWjd71YsD lcxg== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:subject:date:message-id:user-agent :mime-version; bh=rEF6pLVdO3QlLPaUxJPQlz2f/HrvYgLfvWEn2RDGuJI=; b=O6/QDD7RlEeSGfebHzUSQ69bUCnoYdXlbnt+BRx/Sw2NqE1JfmJYg2LvtnQudNK+1t FCjqrK8zeyK8x5PubCtXz4TAWFl0UavuwvghM9x50VKAdBgmElLToSYUktSMIadOUyx2 v7EbL8+pRFKjfNPDJ65xjSvsdoOF6m0WL8IjSdgXCVA2XsSJI3gLDu7PiKM6vZ1cMvXG dmGIE4MuteSKnGHmIAhXxRyw+Auzm6uw1ZN3zRxuhQL6JyOOQxEV5tPi0jc+gWBDnTVX ZNiW9ctkyZBourYXXUHC85iUJaMCbBsSL1afWv1G6NyhhlZZPqVbsKAryfJMYRIfn9EK RGkg== X-Gm-Message-State: APjAAAXvFC7LB8ZgH+O7p4Hn0E+tO9qtAFtQ8TpvyJzuMmwI5spkTnX6 uefXOZ7eE5k1Kmj3+DbJVWiq/XJb X-Google-Smtp-Source: APXvYqws3keQUPnnCs3PX1BMBc/JpeLCNLKNLag+2A6eybDTyyV8NrNL0T7UeoLMgPNk92AlJVGIwQ== X-Received: by 2002:a62:b418:: with SMTP id h24mr5929322pfn.145.1555706977726; Fri, 19 Apr 2019 13:49:37 -0700 (PDT) Original-Received: from lylat ([2604:3d09:e37f:1500:1a72:4878:e793:7302]) by smtp.gmail.com with ESMTPSA id g10sm6312102pgq.54.2019.04.19.13.49.36 for (version=TLS1_2 cipher=ECDHE-RSA-CHACHA20-POLY1305 bits=256/256); Fri, 19 Apr 2019 13:49:36 -0700 (PDT) X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-Received-From: 2607:f8b0:4864:20::434 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.21 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.org gmane.emacs.devel:235679 Archived-At: --=-=-= Content-Type: text/plain 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 --=-=-= Content-Type: text/x-patch Content-Disposition: attachment; filename=0001-Add-some-new-vector-procedures.patch Content-Description: vectors >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 --=-=-=--