From 536f9bfa90c711b46405f9c7adb2e4c659821f66 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 16 Jul 2014 23:09:59 +0900
Subject: [PATCH] Constant-folding symbol->keyword* in chibi.

---
 lib/chibi/optional.scm | 12 +++++++-----
 lib/chibi/optional.sld | 22 ++++++++++++++++++++--
 2 files changed, 27 insertions(+), 7 deletions(-)

diff --git a/lib/chibi/optional.scm b/lib/chibi/optional.scm
index fb5081e2..a6f6ac2e 100644
--- a/lib/chibi/optional.scm
+++ b/lib/chibi/optional.scm
@@ -101,11 +101,6 @@
 (define (symbol->keyword sym)
   (string->symbol (string-append (symbol->string sym) ":")))
 
-(define-syntax symbol->keyword*
-  (syntax-rules ()
-    ((symbol->keyword* sym)
-     (string->symbol (string-append (symbol->string sym) ":")))))
-
 (define-syntax let-key*-to-let
   (syntax-rules ()
     ((let-key*-to-let ls (vars ...) ((v d) . rest) . body)
@@ -182,6 +177,13 @@
 ;;> \scheme{let*} equivalent to \scheme{let-keywords*}.  Any required
 ;;> \var{default} values are evaluated in left-to-right order, with
 ;;> all preceding \var{var}s in scope.
+;;>
+;;> \emph{Example:}
+;;> \example{
+;;> (let-keywords* '(b: 5)
+;;>     ((a 1) (b (* a 2)) (c (* b 3)))
+;;>   (list a b c))
+;;> }
 
 (define-syntax let-keywords*
   (syntax-rules ()
diff --git a/lib/chibi/optional.sld b/lib/chibi/optional.sld
index 27f53a8c..02084635 100644
--- a/lib/chibi/optional.sld
+++ b/lib/chibi/optional.sld
@@ -4,7 +4,20 @@
           let-keywords let-keywords* keyword-ref keyword-ref*)
   (cond-expand
    (chibi
-    (import (chibi)))
+    (import (chibi))
+    (begin
+      (define-syntax symbol->keyword*
+        (er-macro-transformer
+         (lambda (expr rename compare)
+           (if (and (pair? (cdr expr)) (pair? (cadr expr))
+                    (compare 'quote (car (cadr expr))))
+               `(,(rename 'quote)
+                 ,(string->symbol
+                   (string-append
+                    (symbol->string
+                     (identifier->symbol (cadr (cadr expr)))) ":")))
+               `(string->symbol
+                 (string-append (symbol->string ,(cadr expr)) ":"))))))))
    (else
     (import (scheme base))
     (begin
@@ -20,5 +33,10 @@
                  (tmp2 (if (pair? tmp) (cdr tmp) '())))
              (let-optionals* tmp2 rest . body)))
           ((let-optionals* tmp tail . body)
-           (let ((tail tmp)) . body)))))))
+           (let ((tail tmp)) . body))))
+      (define-syntax symbol->keyword*
+        (syntax-rules ()
+          ((symbol->keyword* sym)
+           (string->symbol (string-append (symbol->string sym) ":")))
+          )))))
   (include "optional.scm"))