From d670d4fbe0abc3bb16d9f4c67e19e4b265882ee9 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola <nikodemus@random-state.net> Date: Tue, 7 Nov 2006 12:49:44 +0200 Subject: [PATCH] IF-LET, IF-LET*, WHEN-LET, and WHEN-LET* --- alexandria.asd | 1 + binding.lisp | 120 +++++++++++++++++++++++++++++++++++++++++++++++++ package.lisp | 6 +++ tests.lisp | 75 +++++++++++++++++++++++++++++++ 4 files changed, 202 insertions(+) create mode 100644 binding.lisp diff --git a/alexandria.asd b/alexandria.asd index 09fd989..675f62c 100644 --- a/alexandria.asd +++ b/alexandria.asd @@ -10,6 +10,7 @@ (:file "symbols" :depends-on ("package")) (:file "arrays" :depends-on ("package")) (:file "types" :depends-on ("package")) + (:file "binding" :depends-on ("package")) (:file "functions" :depends-on ("package" "symbols")) (:file "lists" :depends-on ("package" "functions")) (:file "sequences" :depends-on ("package" "lists")) diff --git a/binding.lisp b/binding.lisp new file mode 100644 index 0000000..6dbbcec --- /dev/null +++ b/binding.lisp @@ -0,0 +1,120 @@ +(in-package :alexandria) + +(defmacro if-let (bindings then-form &optional else-form) + "Creates new variable bindings, and conditionally executes either +THEN-FORM or ELSE-FORM (defaulting to NIL). + +BINDINGS must be either single binding of the form: + + (variable initial-form) + +or a list of bindings of the form: + + ((variable-1 initial-form-1) + (variable-2 initial-form-2) + ... + (variable-n initial-form-n)) + +All initial-forms are executed sequentially in the specified order. Then all +the variables are bound to the corresponding values. + +If all variables were bound to true values, the THEN-FORM is executed with the +bindings in effect, otherwise the ELSE-FORM is executed with the bindings in +effect." + (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) + (list bindings) + bindings)) + (variables (mapcar #'car binding-list))) + `(let ,binding-list + (if (and ,@variables) + ,then-form + ,else-form)))) + +(defmacro if-let* (bindings then-form &optional else-form) + "Creates new variable bindings, and conditionally executes either THEN-FORM +or ELSE-FORM (defaulting to NIL). + +BINDINGS must be either single binding of the form: + + (variable initial-form) + +or a list of bindings of the form: + + ((variable-1 initial-form-1) + (variable-2 initial-form-2) + ... + (variable-n initial-form-n)) + +Each initial-form is executed in turn, and the variable bound to the +corresponding value. Initial-form expressions can refer to variables +previously bound by the IF-LET*. + +If all variables are true after the bindings are complete, the THEN-FORM is +executed with the bindings in effect, otherwise the ELSE-FORM is executed with +the bindings in effect." + (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) + (list bindings) + bindings)) + (variables (mapcar #'car binding-list))) + `(let* ,binding-list + (if (and ,@variables) + ,then-form + ,else-form)))) + +(defmacro when-let (bindings &body forms) + "Creates new variable bindings, and conditionally executes either +THEN-FORM or ELSE-FORM (defaulting to NIL). + +BINDINGS must be either single binding of the form: + + (variable initial-form) + +or a list of bindings of the form: + + ((variable-1 initial-form-1) + (variable-2 initial-form-2) + ... + (variable-n initial-form-n)) + +All initial-forms are executed sequentially in the specified order. Then all +the variables are bound to the corresponding values. + +If all variables were bound to true values, then FORMS are executed as an +implicit PROGN." + (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) + (list bindings) + bindings)) + (variables (mapcar #'car binding-list))) + `(let ,binding-list + (when (and ,@variables) + ,@forms)))) + +(defmacro when-let* (bindings &body forms) + "Creates new variable bindings, and conditionally executes either THEN-FORM +or ELSE-FORM (defaulting to NIL). + +BINDINGS must be either single binding of the form: + + (variable initial-form) + +or a list of bindings of the form: + + ((variable-1 initial-form-1) + (variable-2 initial-form-2) + ... + (variable-n initial-form-n)) + +Each initial-form is executed in turn, and the variable bound to the +corresponding value. Initial-form expressions can refer to variables +previously bound by the IF-LET*. + +If all variables are true after the bindings are complete, then FORMS are +executed as an implicit PROGN." + (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) + (list bindings) + bindings)) + (variables (mapcar #'car binding-list))) + `(let* ,binding-list + (when (and ,@variables) + ,@forms)))) + diff --git a/package.lisp b/package.lisp index 6dc750a..a1fc674 100644 --- a/package.lisp +++ b/package.lisp @@ -2,6 +2,11 @@ (:nicknames :alexandria) (:use :cl) (:export + ;; Binding constructs + #:if-let + #:if-let* + #:when-let + #:when-let* ;; Hash tables #:copy-hash-table #:hash-table-keys @@ -65,6 +70,7 @@ #:suffle ;; Macros #:with-unique-names + #:with-gensyms #:once-only #:parse-body ;; Symbols diff --git a/tests.lisp b/tests.lisp index 26ff24f..496878f 100644 --- a/tests.lisp +++ b/tests.lisp @@ -962,3 +962,78 @@ (type= 'string 'list) nil t) + +;;;; Bindings + +(declaim (notinline opaque)) +(defun opaque (x) + x) + +(deftest if-let.1 + (if-let (x (opaque :ok)) + x + :bad) + :ok) + +(deftest if-let.2 + (if-let (x (opaque nil)) + :bad + (and (not x) :ok)) + :ok) + +(deftest if-let.3 + (let ((x 1)) + (if-let ((x 2) + (y x)) + (+ x y) + :oops)) + 3) + +(deftest if-let.4 + (if-let ((x 1) + (y nil)) + :oops + (and (not y) x)) + 1) + +(deftest if-let*.1 + (let ((x 1)) + (if-let* ((x 2) + (y x)) + (+ x y) + :oops)) + 4) + +(deftest if-let*.2 + (if-let* ((x 2) + (y (prog1 x (setf x nil)))) + :oops + (and (not x) y)) + 2) + +(deftest when-let.1 + (when-let (x (opaque :ok)) + (setf x (cons x x)) + x) + (:ok . :ok)) + +(deftest when-let.2 + (when-let ((x 1) + (y nil) + (z 3)) + :oops) + nil) + +(deftest when-let.3 + (let ((x 1)) + (when-let ((x 2) + (y x)) + (+ x y))) + 3) + +(deftest when-let*.1 + (let ((x 1)) + (when-let* ((x 2) + (y x)) + (+ x y))) + 4) -- GitLab