From 1c2f9636dcd6a4fde0a8df989f09cd82704d09af Mon Sep 17 00:00:00 2001
From: BT Templeton <bpt@hcoop.net>
Date: Mon, 8 Aug 2011 18:50:04 -0400
Subject: [PATCH] elisp `labels'

* module/language/elisp/compile-tree-il.scm (compile-labels): New
  special operator.

* module/language/elisp/runtime/function-slot.scm: Update module
  definition.
---
 module/language/elisp/compile-tree-il.scm     | 21 +++++++++++++++++++
 .../language/elisp/runtime/function-slot.scm  |  2 ++
 2 files changed, 23 insertions(+)

diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 9537f20d5..a53d5752d 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -39,6 +39,7 @@
             compile-let
             compile-lexical-let
             compile-flet
+            compile-labels
             compile-let*
             compile-lexical-let*
             compile-guile-ref
@@ -637,6 +638,26 @@
                    (map (cut parse-flet-binding loc <>) bindings)
                    body))))
 
+(defspecial labels (loc args)
+  (pmatch args
+    ((,bindings . ,body)
+     (let ((names+vals (map (cut parse-flet-binding loc <>) bindings)))
+       (receive (decls forms) (parse-body body)
+         (let ((names (map car names+vals))
+               (vals (map cdr names+vals))
+               (gensyms (map (lambda (x) (gensym)) names+vals)))
+           (with-lexical-bindings
+            (fluid-ref bindings-data)
+            names
+            gensyms
+            (lambda ()
+              (make-letrec #f
+                           loc
+                           names
+                           gensyms
+                           (map compile-expr vals)
+                           (compile-expr `(progn ,@forms)))))))))))
+
 (defspecial let* (loc args)
   (pmatch args
     ((,bindings . ,body)
diff --git a/module/language/elisp/runtime/function-slot.scm b/module/language/elisp/runtime/function-slot.scm
index 5e1f3355e..34098ae7e 100644
--- a/module/language/elisp/runtime/function-slot.scm
+++ b/module/language/elisp/runtime/function-slot.scm
@@ -28,6 +28,7 @@
                  (compile-let . let)
                  (compile-lexical-let . lexical-let)
                  (compile-flet . flet)
+                 (compile-labels . labels)
                  (compile-let* . let*)
                  (compile-lexical-let* . lexical-let*)
                  (compile-guile-ref . guile-ref)
@@ -52,6 +53,7 @@
                let
                lexical-let
                flet
+               labels
                let*
                lexical-let*
                guile-ref
-- 
2.20.1