Merge pull request #170 from kilianmh/feat/ccase-let,ctypecase-let

Feat: Add ccase-let, ctypecase-let

control-flow.lisp

@@ -515,6 +515,12 @@ Burson."
      (case ,var
        ,@cases)))
 
+(defmacro ccase-let ((var expr) &body cases)
+  "Like (let ((VAR EXPR)) (ccase VAR ...)), with VAR correctable."
+  `(let ((,var ,expr))
+     (ccase ,var
+       ,@cases)))
+
 (defmacro ecase-let ((var expr) &body cases)
   "Like (let ((VAR EXPR)) (ecase VAR ...)), with VAR read-only."
   `(let1 ,var ,expr
@@ -527,6 +533,12 @@ Burson."
      (typecase ,var
        ,@cases)))
 
+(defmacro ctypecase-let ((var expr) &body cases)
+  "Like (let ((VAR EXPR)) (ctypecase VAR ...)), with VAR correctable."
+  `(let ((,var ,expr))
+     (ctypecase ,var
+       ,@cases)))
+
 (defmacro etypecase-let ((var expr) &body cases)
   "Like (let ((VAR EXPR)) (etypecase VAR ...)), with VAR read-only."
   `(let1 ,var ,expr

package.lisp

@@ -145,7 +145,9 @@
    #:ecase-let
    #:cond-let
    #:case-let
+   #:ccase-let
    #:typecase-let
+   #:ctypecase-let
    #:etypecase-let
    #:bcond
    #:comment

tests/control-flow.lisp

@@ -189,6 +189,14 @@
            (case-let (x 16)
              (0 3) (1 (1+ x)) (t 5)))))
 
+(test ccase-let
+  (is (eql 2
+           (ccase-let (x 1)
+             (0 3) (1 (1+ x)) (t 5))))
+  (signals type-error
+    (ccase-let (x 17)
+      (0 x) (1 (1+ x)))))
+
 (test ecase-let
   (is (eql 2
            (ecase-let (x 1)
@@ -207,6 +215,17 @@
 		 (integer "not")
 		 (string (concatenate 'string y "-here"))))))
 
+(test ctypecase-let
+  (is (eql 'asdf
+	   (ctypecase-let (x 'asdf)
+	     (string 20)
+	     (integer :sdf)
+	     (symbol x))))
+  (signals type-error
+    (ctypecase-let (y 'test-symbol)
+      (integer "not")
+      (string (concatenate 'string y "-here")))))
+
 (test etypecase-let
   (is (eql 2
 	   (etypecase-let (x 'asdf)