Added loop/recur macro for tail-call optimization

docs/contrib/index.rst

@@ -8,3 +8,4 @@ Contents:
    :maxdepth: 3
 
    anaphoric
+   loop

docs/contrib/loop.rst

@@ -0,0 +1,56 @@
+==========
+loop/recur
+==========
+
+.. versionadded:: 0.9.13
+
+The loop/recur macro gives programmers a simple way to use tail-call
+optimization (TCO) in their Hy code.
+
+    A tail call is a subroutine call that happens inside another
+    procedure as its final action; it may produce a return value which
+    is then immediately returned by the calling procedure. If any call
+    that a subroutine performs, such that it might eventually lead to
+    this same subroutine being called again down the call chain, is in
+    tail position, such a subroutine is said to be tail-recursive,
+    which is a special case of recursion. Tail calls are significant
+    because they can be implemented without adding a new stack frame
+    to the call stack. Most of the frame of the current procedure is
+    not needed any more, and it can be replaced by the frame of the
+    tail call. The program can then jump to the called
+    subroutine. Producing such code instead of a standard call
+    sequence is called tail call elimination, or tail call
+    optimization. Tail call elimination allows procedure calls in tail
+    position to be implemented as efficiently as goto statements, thus
+    allowing efficient structured programming.
+
+    -- Wikipedia (http://en.wikipedia.org/wiki/Tail_call)
+                  
+Macros
+======
+
+.. _loop:
+
+loop
+-----
+
+``loop`` establishes a recursion point. With ``loop``, ``recur``
+rebinds the variables set in the recursion point and sends code
+execution back to that recursion point. If ``recur`` is used in a
+non-tail position, an exception is thrown.
+
+Usage: `(loop bindings &rest body)`
+
+Example:
+
+.. code-block:: clojure
+
+    (require hy.contrib.loop)
+
+    (defn factorial [n]
+      (loop [[i n] [acc 1]]
+        (if (zero? i)
+          acc
+          (recur (dec i) (* acc i)))))
+
+    (factorial 1000)

hy/contrib/loop.hy

@@ -0,0 +1,79 @@
+;;; Hy tail-call optimization
+;;
+;; Copyright (c) 2014 Clinton Dreisbach <clinton@dreisbach.us>
+;;
+;; Permission is hereby granted, free of charge, to any person obtaining a
+;; copy of this software and associated documentation files (the "Software"),
+;; to deal in the Software without restriction, including without limitation
+;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;; and/or sell copies of the Software, and to permit persons to whom the
+;; Software is furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be included in
+;; all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
+;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;; DEALINGS IN THE SOFTWARE.
+;;
+;;; The loop/recur macro allows you to construct functions that use tail-call
+;;; optimization to allow arbitrary levels of recursion.
+
+(defn --trampoline-- [f]
+  "Wrap f function and make it tail-call optimized."
+  ;; Takes the function "f" and returns a wrapper that may be used for tail-
+  ;; recursive algorithms. Note that the returned function is not side-effect
+  ;; free and should not be called from anywhere else during tail recursion.
+
+  (setv result None)
+  ;; We have to put this in a list because of Python's
+  ;; weirdness around local variables.
+  ;; Assigning directly to it later would cause it to
+  ;; shadow in a new scope.
+  (setv active [False])
+  (setv accumulated [])
+
+  (fn [&rest args]
+    (.append accumulated args)
+    (when (not (first active))
+      (assoc active 0 True)
+      (while (> (len accumulated) 0)
+        (setv result (apply f (.pop accumulated))))
+      (assoc active 0 False)
+      result)))
+
+(defn recursive-replace [old-term new-term body]
+  "Recurses through lists of lists looking for old-term and replacing it with new-term."
+  ((type body)
+   (list-comp (cond
+               [(= term old-term) new-term]
+               [(instance? hy.HyList term)
+                (recursive-replace old-term new-term term)]
+               [True term]) [term body])))
+
+(defmacro loop [bindings &rest body]
+  ;; Use inside functions like so:
+  ;; (defun factorial [n]
+  ;;   (loop [[i n]
+  ;;          [acc 1]]
+  ;;         (if (= i 0)
+  ;;           acc
+  ;;           (recur (dec i) (* acc i)))))
+  ;;
+  ;; If recur is used in a non-tail-call position, None is returned, which
+  ;; causes chaos. Fixing this to detect if recur is in a tail-call position
+  ;; and erroring if not is a giant TODO.
+  (with-gensyms [recur-fn]
+    (let [[fnargs (map (fn [x] (first x)) bindings)]
+          [initargs (map second bindings)]
+          [new-body (recursive-replace 'recur recur-fn body)]]
+      `(do
+        (import [hy.contrib.loop [--trampoline--]])
+        (def ~recur-fn
+          (--trampoline-- (fn [~@fnargs]
+                            ~@new-body)))
+        (~recur-fn ~@initargs)))))

tests/__init__.py

@@ -14,4 +14,5 @@ from .native_tests.core import *  # noqa
 from .native_tests.reader_macros import *  # noqa
 from .native_tests.with_test import *  # noqa
 from .native_tests.contrib.anaphoric import *  # noqa
+from .native_tests.contrib.loop import *  # noqa
 from .contrib.test_meth import *  # noqa

tests/native_tests/contrib/loop.hy

@@ -0,0 +1,46 @@
+(require hy.contrib.loop)
+(import sys)
+
+(defn tco-sum [x y]
+  (loop [[x x] [y y]]
+        (cond
+         [(> y 0) (recur (inc x) (dec y))]
+         [(< y 0) (recur (dec x) (inc y))]
+         [True x])))
+
+(defn non-tco-sum [x y]
+  (cond
+   [(> y 0) (inc (non-tco-sum x (dec y)))]
+   [(< y 0) (dec (non-tco-sum x (inc y)))]
+   [True x]))
+
+(defn test-loop []
+  ;; non-tco-sum should fail
+  (try
+   (setv n (non-tco-sum 100 10000))
+   (catch [e RuntimeError]
+     (assert true))
+   (else
+    (assert false)))
+
+  ;; tco-sum should not fail
+  (try
+   (setv n (tco-sum 100 10000))
+   (catch [e RuntimeError]
+     (assert false))
+   (else
+    (assert (= n 10100)))))
+
+(defn test-recur-in-wrong-loc []
+  (defn bad-recur [n]
+    (loop [[i n]]
+          (if (= i 0)
+            0
+            (inc (recur (dec i))))))
+
+  (try
+   (bad-recur 3)
+   (catch [e TypeError]
+     (assert true))
+   (else
+    (assert false))))