all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: Mark Oteiza <mvoteiza@udel.edu>
To: 28254@debbugs.gnu.org
Subject: bug#28254: 26.0.50; SRFI-2 and-let*
Date: Sun, 27 Aug 2017 16:11:29 -0400	[thread overview]
Message-ID: <87a82kdb4e.fsf@holos> (raw)


Hi,

A while ago I aliased and-let* to when-let* in subr-x in be10c00d.
Some time later I implemented it and promptly forgot about it.  While
this could be cleaned up and dropped into subr-x, it could just as
well be in its own file--its behavior overlaps with when-let* but each
has things the other lacks.

 https://www.gnu.org/software/guile/manual/html_node/SRFI_002d2.html
 https://srfi.schemers.org/srfi-2/srfi-2.html

(defmacro and-let* (varlist &rest body)
  "Bind variables according to VARLIST and conditionally eval BODY.
Like `when-let*' except if BODY is empty and all the bindings are
non-nil, then the result is t.  Elements of VARLIST can
additionally be of the form (EXPR), which is evaluated and
checked for nil."
  (declare (indent 1)
           (debug ([&or (&rest &or symbolp atom (symbolp &optional form) (form))
                        (symbolp form)]
                   body)))
  (let (res (prev-var t) (i 0))
    (dolist (binding varlist)
      (push
       (cond
        ((symbolp binding)
         (prog1
             `(,binding (and ,prev-var ,binding))
           (setq prev-var binding)))
        ((atom binding) binding)
        ((and (listp binding) (null (cdr binding))
              (let ((form (car binding)))
                (or (listp form) (atom form))))
         (let ((new (cl-gensym)))
           (prog1 `(,new (and ,prev-var ,(car binding)))
             (setq prev-var new))))
        (t
         (prog1 `(,(car binding) (and ,prev-var ,(cadr binding)))
           (setq prev-var (car binding)))))
       res))
    `(let* ,(nreverse res)
       ,(if (null body) prev-var
          `(when ,prev-var ,@body)))))


(ert-deftest srfi-2-test-empty-varlist ()
  (should (equal 1 (and-let* () 1)))
  (should (equal 2 (and-let* () 1 2)))
  (should (equal t (and-let* ()))))

(ert-deftest srfi-2-test-group-1 ()
   (should (equal nil (let ((x nil)) (and-let* (x)))))
   (should (equal 1 (let ((x 1)) (and-let* (x)))))
   (should (equal nil (and-let* ((x nil)))))
   (should (equal 1 (and-let* ((x 1)))))
   (should-error (and-let* (nil (x 1))) :type 'setting-constant)
   (should (equal nil (and-let* ((nil) (x 1)))))
   (should-error (and-let* (2 (x 1))) :type 'wrong-type-argument)
   (should (equal 1 (and-let* ((2) (x 1)))))
   (should (equal 2 (and-let* ((x 1) (2)))))
   (should (equal nil (let ((x nil)) (and-let* (x) x))))
   (should (equal "" (let ((x "")) (and-let* (x) x))))
   (should (equal "" (let ((x "")) (and-let* (x)))))
   (should (equal 2 (let ((x 1)) (and-let* (x) (+ x 1)))))
   (should (equal nil (let ((x nil)) (and-let* (x) (+ x 1)))))
   (should (equal 2 (let ((x 1)) (and-let* (((> x 0))) (+ x 1)))))
   (should (equal t (let ((x 1)) (and-let* (((> x 0)))))))
   (should (equal nil (let ((x 0)) (and-let* (((> x 0))) (+ x 1)))))
   (should (equal 3
                  (let ((x 1)) (and-let* (((> x 0)) (x (+ x 1))) (+ x 1))))))

(ert-deftest srfi-2-test-rebind ()
   (should
    (equal 4
           (let ((x 1))
             (and-let* (((> x 0)) (x (+ x 1)) (x (+ x 1))) (+ x 1))))))

(ert-deftest srfi-2-test-group-2 ()
   (should
    (equal 2 (let ((x 1)) (and-let* (x ((> x 0))) (+ x 1)))))
   (should
    (equal 2 (let ((x 1)) (and-let* (((progn x)) ((> x 0))) (+ x 1)))))
   (should (equal nil (let ((x 0)) (and-let* (x ((> x 0))) (+ x 1)))))
   (should (equal nil (let ((x nil)) (and-let* (x ((> x 0))) (+ x 1)))))
   (should
    (equal nil (let ((x nil)) (and-let* (((progn x)) ((> x 0))) (+ x 1))))))

(ert-deftest srfi-2-test-group-3 ()
   (should
    (equal nil (let ((x 1)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))
   (should
    (equal nil (let ((x 0)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))
   (should
    (equal nil
           (let ((x nil)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y)))))
   (should
    (equal (/ 3.0 2)
           (let ((x 3.0)) (and-let* (x (y (- x 1)) ((> y 0))) (/ x y))))))





             reply	other threads:[~2017-08-27 20:11 UTC|newest]

Thread overview: 33+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2017-08-27 20:11 Mark Oteiza [this message]
2017-09-01  2:55 ` bug#28254: 26.0.50; SRFI-2 and-let* npostavs
2017-09-02  2:10   ` Mark Oteiza
2017-09-02  3:05     ` npostavs
2017-09-02  4:14       ` Mark Oteiza
2017-09-02  5:25         ` Michael Heerdegen
2017-09-02 13:36           ` Mark Oteiza
2017-09-02 18:41             ` Noam Postavsky
2017-09-03 17:48               ` Michael Heerdegen
2017-09-03 22:39                 ` Mark Oteiza
2017-09-04  0:48                   ` Mark Oteiza
2017-09-04 14:12                   ` Michael Heerdegen
2017-09-05  3:47                   ` Mark Oteiza
2017-09-05 15:04                     ` Michael Heerdegen
2017-09-06 12:12                     ` Michael Heerdegen
2017-09-06 13:06                       ` Mark Oteiza
2017-09-06 19:04                         ` Michael Heerdegen
2017-09-04  1:13               ` Mark Oteiza
2017-09-05  3:55                 ` Mark Oteiza
2017-09-09  0:33                   ` Mark Oteiza
2017-09-12 12:39                     ` Michael Heerdegen
2017-09-12 13:09                       ` Mark Oteiza
2017-09-12 18:44                         ` Michael Heerdegen
2017-09-12 20:21                           ` Mark Oteiza
2017-09-13 10:16                             ` Michael Heerdegen
2017-09-13 11:48                               ` Mark Oteiza
2017-09-13 16:46                                 ` Michael Heerdegen
2017-09-13 16:49                                   ` Mark Oteiza
2017-09-13 17:05                                     ` Michael Heerdegen
2017-09-13 17:28                                       ` Mark Oteiza
2017-09-13 17:49                                         ` Michael Heerdegen
2017-09-12 12:13                   ` Michael Heerdegen
2017-09-12 14:29                     ` Mark Oteiza

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=87a82kdb4e.fsf@holos \
    --to=mvoteiza@udel.edu \
    --cc=28254@debbugs.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.