Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Cleanup #7

Merged
merged 14 commits into from

2 participants

@brandonbloom
Collaborator

Hi David,

I'm studying delimc & the cited references for my aforementioned async/await project. Part of my personal strategy for learning about a code base is to just dive right in and change something. I usually start with small cosmetic changes and in this case, I just kinda got on a roll.

Not sure if you'd even want any/all of these commits, but I figured that I'd share. Happy to adjust the pull request as you like. The changes should be much less scary commit-by-commit. All tests pass.

Cheers,
Brandon

@swannodette swannodette merged commit b09f846 into swannodette:master
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
This page is out of date. Refresh to see the latest.
View
1  .gitignore
@@ -2,3 +2,4 @@ pom.xml
*jar
lib
classes
+.lein-*
View
2  README.md
@@ -1,7 +1,7 @@
delimc
----
-A delimited continuations library for Clojure 1.2.0 (and 1.3.0). Portions based on cl-cont by Slava Akhmechet (http://defmacro.org).
+A delimited continuations library for Clojure 1.4.0 (and 1.3.0). Portions based on cl-cont by Slava Akhmechet (http://defmacro.org).
```clj
(def cont1 (atom nil))
View
6 project.clj
@@ -1,5 +1,3 @@
-(defproject delimc "0.1.0"
+(defproject delimc "0.2.0"
:description "Delimited Continuations for Clojure"
- :dependencies [[org.clojure/clojure "1.2.0"]]
- :dev-dependencies [[swank-clojure "1.3.0"]
- [lein-clojars "0.6.0"]])
+ :dependencies [[org.clojure/clojure "1.4.0"]])
View
244 src/delimc/core.clj
@@ -1,120 +1,40 @@
-(ns delimc.core
- (:import [clojure.lang Reflector]))
+(ns delimc.core)
-;; ================================================================================
-;; Utilities
-;; ================================================================================
-
-(def ^:dynamic ctx nil)
-
-(def not-seq? (comp not seq?))
+(def ^:dynamic *ctx* nil)
-(defn sym-to-key [sym]
- (keyword (str sym)))
+(defrecord Context [local-functions])
;; ================================================================================
;; CPS Transformer
;; ================================================================================
-(def special-form-transformers (ref {}))
-
-(defmacro defcpstransformer [name lambda-list & body]
- `(dosync
- (commute special-form-transformers assoc ~(keyword (str name))
- (fn [~@lambda-list] ~@body))))
-
-(defn cpstransformer [name]
- (name @special-form-transformers))
-
-(defstruct call-cc-context :local-functions)
-
-(defn make-call-cc-context []
- (struct call-cc-context nil))
-
-;; ================================================================================
-;; Helper Transformers
-;; ================================================================================
-
-(declare expr-sequence->cps
- apply->cps)
-
-(defcpstransformer reset [cons k-expr]
- (expr-sequence->cps (rest cons) k-expr))
-
-(defmacro unreset [& body]
- `(do
- ~@body))
-
-(defcpstransformer unreset [cons k-expr]
- `(~k-expr (do ~@(rest cons))))
-
-(declare lambda-expr->cps)
-
-(defcpstransformer defn [[_ name args & body] k-expr]
- `(do
- (def ~name
- ~(lambda-expr->cps `(fn [~@args]
- ~@body)
- nil))
- (~k-expr ~name)))
-
-(defcpstransformer apply [cons k-expr]
- (apply->cps (rest cons) k-expr nil))
-
-;; ================================================================================
-;; Walker
-;; ================================================================================
-
-(declare expr->cps
- atom->cps
- cons->cps
- application->cps
- apply->cps
- funcall->cps
- expr-sequence->cps)
+(defmulti transform (fn [[op & forms] k-expr] (keyword op)))
-;; Gives access to call-cc by transforming body to continuation passing style."
-(defmacro reset [& body]
- (binding [ctx (make-call-cc-context)]
- (expr-sequence->cps body identity)))
+(defn is-fn? [fdesignator]
+ (#{'fn 'clojure.core/fn 'clojure.core/fn* 'fn*} fdesignator))
-(defn expr->cps [expr k-expr]
- (if (not-seq? expr)
- (atom->cps expr k-expr)
- (cons->cps expr k-expr)))
+(defn check-for-fn [form]
+ (let [sym (first form)]
+ (if (is-fn? sym)
+ `(~'function ~form)
+ form)))
(defn atom->cps [atom k-expr]
`(~k-expr ~atom))
-(defn funcall->cps [acons k-expr args]
- (application->cps 'funcall-cc acons k-expr args))
+(defn cons->cps [acons k-expr]
+ (transform (check-for-fn acons) k-expr))
+
+(defn expr->cps [expr k-expr]
+ (if (seq? expr)
+ (cons->cps expr k-expr)
+ (atom->cps expr k-expr)))
;; we need to mark functions for transformation
(def function identity)
(defn expanded? [original expansion]
- (not (= original expansion)))
-
-(defn check-for-fn [form]
- (let [sym (first form)]
- (if (and (not (= sym 'fn))
- (not (= sym 'clojure.core/fn))
- (not (= sym 'clojure.core/fn*))
- (not (= sym 'fn*)))
- form
- `(~'function ~form))))
-
-(defn cons->cps [acons k-expr]
- (let [acons (check-for-fn acons)
- transformer ((sym-to-key (first acons)) @special-form-transformers)]
- (if transformer
- (transformer acons k-expr)
- (let [expansion (macroexpand-1 acons)
- expanded-p (expanded? acons expansion)]
- (if expanded-p
- (expr->cps expansion k-expr)
- (funcall->cps
- (cons `(~'function ~(first expansion)) (rest expansion)) k-expr nil))))))
+ (not= original expansion))
(defn application->cps [app-sym acons k-expr args]
(if (seq acons)
@@ -127,6 +47,17 @@
(let [r-args (reverse args)]
`(~app-sym ~(first r-args) ~k-expr ~@(rest r-args)))))
+(defn funcall->cps [acons k-expr args]
+ (application->cps 'funcall-cc acons k-expr args))
+
+(defmethod transform :default [acons k-expr]
+ (let [expansion (macroexpand-1 acons)
+ expanded-p (expanded? acons expansion)]
+ (if expanded-p
+ (expr->cps expansion k-expr)
+ (funcall->cps
+ (cons `(~'function ~(first expansion)) (rest expansion)) k-expr nil))))
+
(defn apply->cps [acons k-expr args]
(application->cps 'apply-cc acons k-expr args))
@@ -140,14 +71,14 @@
(defmacro shift [k & body]
`(~'shift* (fn [~k] ~@body)))
-(defcpstransformer shift* [cons k-expr]
- (if (not (= (count cons) 2))
+(defmethod transform :shift* [cons k-expr]
+ (when-not (= (count cons) 2)
(throw (Exception. "Please ensure shift has one argument.")))
`(~(first (rest cons)) ~k-expr))
;; quote
;; --------------------------------------------------------------------------------
-(defcpstransformer quote
+(defmethod transform :quote
[acons k-expr]
`(~k-expr ~acons))
@@ -160,7 +91,7 @@
`(fn [r# ~'& rest-args#]
~(expr-sequence->cps (rest expr-list) k-expr)))))
-(defcpstransformer do [acons k-expr]
+(defmethod transform :do [acons k-expr]
(expr-sequence->cps (rest acons) k-expr))
;; let
@@ -175,15 +106,20 @@
~(let-varlist->cps (rest varlist) let-body k-expr)))
(expr-sequence->cps let-body k-expr))))
-(defcpstransformer let [[_ varlist & forms] k-expr]
+(defmethod transform :let [[_ varlist & forms] k-expr]
(let-varlist->cps (partition 2 varlist) forms k-expr))
-(dosync
- (commute special-form-transformers assoc :let* (:let @special-form-transformers)))
+(defmethod transform :let* [[_ & forms] k-expr]
+ (transform (cons :let forms) k-expr))
;; function
;; --------------------------------------------------------------------------------
-(declare fdesignator-to-function-cc)
+
+(defn fdesignator-to-function-cc [afn]
+ (if (:funcallable (meta afn))
+ (:fn (meta afn))
+ (fn [k & args]
+ (k (apply afn args)))))
(defn funcall-cc [afn k & args]
(apply (fdesignator-to-function-cc afn) k args))
@@ -200,79 +136,93 @@
(defn make-funcallable [afn]
(with-meta (fn [& args] (apply afn identity args)) {:funcallable true, :fn afn}))
-(defn fdesignator-to-function-cc [afn]
- (if (:funcallable (meta afn))
- (:fn (meta afn))
- (fn [k & args]
- (k (apply afn args)))))
-
-;; refactor
-(defn is-fn? [fdesignator]
- (or (= fdesignator 'clojure.core/fn)
- (= fdesignator 'clojure.core/fn*)
- (= fdesignator 'fn)
- (= fdesignator 'fn*)))
-
-(defcpstransformer function [[_ fdesignator :as acons] k-expr]
+(defmethod transform :function [[_ fdesignator :as acons] k-expr]
(cond
- (not-seq? fdesignator) (if (some #{fdesignator} (:local-functions ctx))
- `(~k-expr (make-funcallable ~acons))
- `(~k-expr ~acons))
+ (not (seq? fdesignator)) (if (some #{fdesignator} (:local-functions *ctx*))
+ `(~k-expr (make-funcallable ~acons))
+ `(~k-expr ~acons))
(and (seq? (seq fdesignator))
(is-fn? (first fdesignator))) `(~k-expr ~(lambda-expr->cps fdesignator k-expr))))
-(defmacro fn-cc [args-list & body]
- `(reset
- (fn [~@args-list]
- ~@body)))
-
;; if
;; --------------------------------------------------------------------------------
-(defcpstransformer if [[_ pred-expr pred-true-expr pred-false-expr] k-expr]
+(defmethod transform :if [[_ pred-expr pred-true-expr pred-false-expr] k-expr]
(expr->cps pred-expr
`(fn [pred# ~'& rest-args#]
(if pred#
~(expr->cps pred-true-expr k-expr)
~(expr->cps pred-false-expr k-expr)))))
-(dosync
- (commute special-form-transformers assoc :if* (:if @special-form-transformers)))
+
+(defmethod transform :if* [[_ & forms] k-expr]
+ (transform (cons :if forms) k-expr))
;; letfn
;; --------------------------------------------------------------------------------
(defmacro transform-forms-in-env [forms k-expr transf-env]
- (binding [ctx transf-env]
+ (binding [*ctx* transf-env]
(expr-sequence->cps forms k-expr)))
(defn transform-local-function [[fn-name fn-args & fn-forms :as afn]]
- (if (and fn-name (symbol? fn-name))
- nil
+ (when-not (and fn-name (symbol? fn-name))
(throw (Exception. "Function name must be non-nil symbol")))
- (if (>= (count afn) 2)
- nil
+ (when (< (count afn) 2)
(throw (Exception. "Function arguments not specified")))
`(~fn-name [k# ~@fn-args]
- (transform-forms-in-env ~fn-forms k# ~ctx)))
+ (transform-forms-in-env ~fn-forms k# ~*ctx*)))
(defn declare-function-names-local [fnames]
- (loop [result (:local-functions ctx) names fnames]
- (if (= (seq names) nil)
+ (loop [result (:local-functions *ctx*) names fnames]
+ (if (nil? (seq names))
result
(recur (conj result (first names)) (rest names)))))
(defmacro with-local-function-names [names & body]
`(let [fn-list# ~names]
(do
- (binding [ctx (assoc ctx :local-functions
- (declare-function-names-local fn-list#))]
+ (binding [*ctx* (assoc *ctx* :local-functions
+ (declare-function-names-local fn-list#))]
~@body))))
-(defcpstransformer letfn [[_ fn-list & forms :as acons] k-expr]
- (if (>= (count acons) 2)
- nil
+(defmethod transform :letfn [[_ fn-list & forms :as acons] k-expr]
+ (when (< (count acons) 2)
(throw (Exception. "Too few parameters to letfn")))
- (with-local-function-names
+ (with-local-function-names
(map first fn-list)
`(letfn [~@(map (fn [afn]
(transform-local-function afn))
fn-list)]
- (transform-forms-in-env ~forms ~k-expr ~ctx))))
+ (transform-forms-in-env ~forms ~k-expr ~*ctx*))))
+
+;; ================================================================================
+;; Helper Transformers
+;; ================================================================================
+
+(defmethod transform :reset [cons k-expr]
+ (expr-sequence->cps (rest cons) k-expr))
+
+(defmacro unreset [& body]
+ `(do ~@body))
+
+(defmethod transform :unreset [cons k-expr]
+ `(~k-expr (do ~@(rest cons))))
+
+(defmethod transform :defn [[_ name args & body] k-expr]
+ `(do
+ (def ~name
+ ~(lambda-expr->cps `(fn [~@args]
+ ~@body)
+ nil))
+ (~k-expr ~name)))
+
+(defmethod transform :apply [cons k-expr]
+ (apply->cps (rest cons) k-expr nil))
+
+;; Gives access to call-cc by transforming body to continuation passing style."
+(defmacro reset [& body]
+ (binding [*ctx* (Context. nil)]
+ (expr-sequence->cps body identity)))
+
+(defmacro fn-cc [args-list & body]
+ `(reset
+ (fn [~@args-list]
+ ~@body)))
View
22 test/delimc/test/core.clj
@@ -8,7 +8,7 @@
(deftest not-seq-2
(is (= (let [cc (atom nil)]
- [(reset
+ [(reset
(shift k
(reset! cc k)
(@cc 1)))
@@ -16,8 +16,8 @@
[1 2])))
;; funcall
-(deftest funcall-1
- (is (= (reset (+ 1 2))
+(deftest funcall-1
+ (is (= (reset (+ 1 2))
3)))
(deftest funcall-2
@@ -86,7 +86,7 @@
[42 84])))
;; quote
-(deftest quote-1
+(deftest quote-1
(is (= (reset 'a) 'a)))
(deftest quote-2
@@ -94,7 +94,7 @@
(deftest quote-3
(is (= (let [cc (atom nil)]
- [(reset
+ [(reset
(concat '(a b)
(shift k
(reset! cc k)
@@ -148,7 +148,7 @@
(deftest if-3
(is (= (let [cc (atom nil)]
[(reset
- (if true
+ (if true
(shift k
(reset! cc k)
(k 1))
@@ -159,10 +159,10 @@
(deftest if-4
(is (= (let [cc (atom nil)]
(reset
- (if nil
+ (if nil
(shift k
(reset! cc k)
- (k 1))
+ (k 1))
2))
@cc)
nil)))
@@ -386,7 +386,7 @@
(if-let [a nil]
(shift k
(reset! cc k)
- (k 1))
+ (k 1))
2))
@cc)
nil)))
@@ -439,7 +439,7 @@
(deftest letfn-3
(is (= (let [cc (atom nil)]
- [(reset
+ [(reset
(letfn [(a [i] (+ i (shift k
(reset! cc k)
(k 2))))
@@ -563,4 +563,4 @@
(deftest ref-1
(is (= @(reset (ref {}))
- @(ref {}))))
+ @(ref {}))))
Something went wrong with that request. Please try again.