From d669d48aa76357b2b23e8dfed4aca9d02677da3f Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Tue, 5 Aug 2014 12:53:33 +0900
Subject: [PATCH] add destructuring lambda

---
 piclib/CMakeLists.txt                 |  4 +++
 piclib/picrin/experimental/lambda.scm | 41 +++++++++++++++++++++++++++
 2 files changed, 45 insertions(+)
 create mode 100644 piclib/picrin/experimental/lambda.scm

diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt
index 2b676ab7..7da6043b 100644
--- a/piclib/CMakeLists.txt
+++ b/piclib/CMakeLists.txt
@@ -1,9 +1,12 @@
 list(APPEND PICLIB_SCHEME_LIBS
   ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm
+
   ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm
   ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm
+  ${PROJECT_SOURCE_DIR}/piclib/picrin/experimental/lambda.scm
+
   ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/file.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm
@@ -11,6 +14,7 @@ list(APPEND PICLIB_SCHEME_LIBS
   ${PROJECT_SOURCE_DIR}/piclib/scheme/eval.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/r5rs.scm
   ${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm
+
   ${PROJECT_SOURCE_DIR}/piclib/srfi/1.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/8.scm
   ${PROJECT_SOURCE_DIR}/piclib/srfi/26.scm
diff --git a/piclib/picrin/experimental/lambda.scm b/piclib/picrin/experimental/lambda.scm
new file mode 100644
index 00000000..f728adfe
--- /dev/null
+++ b/piclib/picrin/experimental/lambda.scm
@@ -0,0 +1,41 @@
+(define-library (picrin experimental lambda)
+  (import (rename (scheme base)
+                  (lambda lambda%))
+          (picrin macro))
+
+  (define uniq
+    (let ((counter 0))
+      (lambda% ()
+        (let ((sym (string->symbol (string-append "lv$" (number->string counter)))))
+          (set! counter (+ counter 1))
+          sym))))
+
+  (define-syntax lambda
+    (ir-macro-transformer
+     (lambda% (form inject compare)
+
+       (define (bind val args)
+         (cond
+          ((symbol? args)
+           `(define ,args ,val))
+          ((pair? args)
+           (let ((a (uniq))
+                 (b (uniq)))
+             `(begin
+                (define ,a (car ,val))
+                (define ,b (cdr ,val))
+                ,(bind a (car args))
+                ,(bind b (cdr args)))))
+          ((vector? args)
+           ;; TODO
+           (error "fixme"))
+          (else
+           `(unless (equal? ,val ',args)
+              (error "match failure" ,val ',args)))))
+
+       (let ((args (car (cdr form)))
+             (body (cdr (cdr form))))
+         (let ((var (uniq)))
+          `(lambda% ,var ,(bind var args) ,@body))))))
+
+  (export lambda))