Permalink
Browse files

fixed recur expansion in let-likes, made non-recursive fns more effic…

…ient.
  • Loading branch information...
VincentToups committed Apr 19, 2010
1 parent 61ac1b3 commit bb18ea684f22395680471484b8085edf5e7077ce
Showing with 274 additions and 86 deletions.
  1. +8 −0 README.md
  2. +92 −63 defn.el
  3. +55 −0 elab.el
  4. +22 −0 ellision.el
  5. +22 −0 guitar.el
  6. +75 −23 utils.el
View
@@ -131,6 +131,14 @@ can find moments of respite from writing my dissertation.
Updates:
--------
+Update 19 Apr 2010
+
+* fixed a bug in the expansion of recur wherein tail-calls inside
+ let-like forms (let, let*, lexical-let, lexical-let*, labels, flet)
+ would not expand.
+* Improved the fn and fn_ macros so that they do not compile to loops
+ if recur is not used in their bodies. This is a tradeoff between
+ compilation and execution speed.
Update 16 Mar 2010
View
155 defn.el
@@ -297,6 +297,7 @@
(vector (coerce binders 'vector) args-sym))
(defmacro* fn (&rest rest)
+ "Clojure-style destructuring lambda (funcall (fn [[x y & r]] (list x y r)) '(1 2 3 4 5 6)) -> (1 2 (3 4 5 6))."
(cond
((vectorp (car rest))
`(fn (,(car rest) ,@(cdr rest))))
@@ -307,18 +308,42 @@
(let ((,numargs (length ,args-sym)))
(cond
,@(suffix (loop for pair in rest append
- (let ((binders (car pair))
- (body (cdr pair)))
- (assert (vectorp binders) t (format "binder forms need to be vectors (error in %s)." currently-defining-defn))
- (assert (not (member :or (coerce binders 'list))) t (format "top-level defn binding forms can't contain an or clause because it conflicts with automatic arity dispatching (%s)." currently-defining-defn))
+ (let* ((binders (car pair))
+ (body (cdr pair))
+ (expanded-body (macroexpand-all body))
+ (uses-recur? ($ 'recur in (flatten expanded-body)))
+ (apropriate-body
+ (if uses-recur?
+ `(dloop-single-arg
+ ,(gen-fn-rec-binding binders args-sym)
+ ,@expanded-body)
+ `(lexical-let* ,(mapcar
+ (lambda (x) (coerce x 'list))
+ (handle-binding binders args-sym)) ,@body))))
+ (assert
+ (vectorp binders)
+ t
+ (format "binder forms need to be vectors (error in %s)." currently-defining-defn))
+ (assert
+ (not (member :or (coerce binders 'list)))
+ t
+ (format
+ "top-level defn binding forms can't contain an or clause because it conflicts with automatic arity dispatching (%s)."
+ currently-defining-defn))
`(((arity-match ,numargs ',(binder-arity binders))
- (dloop-single-arg
- ,(gen-fn-rec-binding binders args-sym)
- ,@body)))))
- `(t (error "Unable to find an arity match for %d args in fn %s." ,numargs ',currently-defining-defn))))))))
- (t (error "Can't parse defn %s. Defn needs a binder/body pair or a list of such pairs. Neither appears to have been passed in. " currently-defining-defn))))
+ ,apropriate-body))))
+ `(t
+ (error
+ "Unable to find an arity match for %d args in fn %s."
+ ,numargs
+ ',currently-defining-defn))))))))
+ (t
+ (error
+ "Can't parse defn %s. Defn needs a binder/body pair or a list of such pairs. Neither appears to have been passed in. "
+ currently-defining-defn))))
(defmacro* fn_ (&rest rest)
+ "Clojure-style destructuring lambda (funcall (fn [[x y & r]] (list x y r)) '(1 2 3 4 5 6)) -> (1 2 (3 4 5 6)). Non-lexical binding version."
(cond
((vectorp (car rest))
`(fn_ (,(car rest) ,@(cdr rest))))
@@ -329,61 +354,39 @@
(let ((,numargs (length ,args-sym)))
(cond
,@(suffix (loop for pair in rest append
- (let ((binders (car pair))
- (body (cdr pair)))
- (assert (vectorp binders) t (format "binder forms need to be vectors (error in %s)." currently-defining-defn))
- (assert (not (member :or (coerce binders 'list))) t (format "top-level defn binding forms can't contain an or clause because it conflicts with automatic arity dispatching (%s)." currently-defining-defn))
- `(((arity-match ,numargs ',(binder-arity binders))
- (dloop-single-arg_
- ,(gen-fn-rec-binding binders args-sym)
- ,@body)))))
- `(t (error "Unable to find an arity match for %d args in fn %s." ,numargs ',currently-defining-defn))))))))
- (t (error "Can't parse defn %s. Defn needs a binder/body pair or a list of such pairs. Neither appears to have been passed in. " currently-defining-defn))))
-
-(defmacro* fn-non-rec (&rest rest)
- (cond
- ((vectorp (car rest))
- `(fn (,(car rest) ,@(cdr rest))))
- ((listp (car rest)) ; set of different arity binders/bodies
- (let ((args-sym (gensym))
- (numargs (gensym)))
- `(lambda (&rest ,args-sym)
- (let ((,numargs (length ,args-sym)))
- (cond
- ,@(suffix (loop for pair in rest append
- (let ((binders (car pair))
- (body (cdr pair)))
- (assert (vectorp binders) t (format "binder forms need to be vectors (error in %s)." currently-defining-defn))
- (assert (not (member :or (coerce binders 'list))) t (format "top-level defn binding forms can't contain an or clause because it conflicts with automatic arity dispatching (%s)." currently-defining-defn))
- `(((arity-match ,numargs ',(binder-arity binders))
- (lexical-let* ,(mapcar
- (lambda (x) (coerce x 'list))
- (handle-binding binders args-sym)) ,@body)))))
- `(t (error "Unable to find an arity match for %d args in fn %s." ,numargs ',currently-defining-defn))))))))
- (t (error "Can't parse defn %s. Defn needs a binder/body pair or a list of such pairs. Neither appears to have been passed in. " currently-defining-defn))))
-
-
-(defmacro* fn-non-rec_ (&rest rest)
- (cond
- ((vectorp (car rest))
- `(fn (,(car rest) ,@(cdr rest))))
- ((listp (car rest)) ; set of different arity binders/bodies
- (let ((args-sym (gensym))
- (numargs (gensym)))
- `(lambda (&rest ,args-sym)
- (let ((,numargs (length ,args-sym)))
- (cond
- ,@(suffix (loop for pair in rest append
- (let ((binders (car pair))
- (body (cdr pair)))
- (assert (vectorp binders) t (format "binder forms need to be vectors (error in %s)." currently-defining-defn))
- (assert (not (member :or (coerce binders 'list))) t (format "top-level defn binding forms can't contain an or clause because it conflicts with automatic arity dispatching (%s)." currently-defining-defn))
+ (let* ((binders (car pair))
+ (body (cdr pair))
+ (expanded-body (macroexpand-all body))
+ (uses-recur? ($ 'recur in (flatten expanded-body)))
+ (apropriate-body
+ (if uses-recur?
+ `(dloop-single-arg_
+ ,(gen-fn-rec-binding binders args-sym)
+ ,@expanded-body)
+ `(let* ,(mapcar
+ (lambda (x) (coerce x 'list))
+ (handle-binding binders args-sym)) ,@body))))
+ (assert
+ (vectorp binders)
+ t
+ (format "binder forms need to be vectors (error in %s)." currently-defining-defn))
+ (assert
+ (not (member :or (coerce binders 'list)))
+ t
+ (format
+ "top-level defn binding forms can't contain an or clause because it conflicts with automatic arity dispatching (%s)."
+ currently-defining-defn))
`(((arity-match ,numargs ',(binder-arity binders))
- (let* ,(mapcar
- (lambda (x) (coerce x 'list))
- (handle-binding binders args-sym)) ,@body)))))
- `(t (error "Unable to find an arity match for %d args in fn %s." ,numargs ',currently-defining-defn))))))))
- (t (error "Can't parse defn %s. Defn needs a binder/body pair or a list of such pairs. Neither appears to have been passed in. " currently-defining-defn))))
+ ,apropriate-body))))
+ `(t
+ (error
+ "Unable to find an arity match for %d args in fn %s."
+ ,numargs
+ ',currently-defining-defn))))))))
+ (t
+ (error
+ "Can't parse defn %s. Defn needs a binder/body pair or a list of such pairs. Neither appears to have been passed in. "
+ currently-defining-defn))))
(defun extract-interactive-and-return (forms)
(loop with
@@ -398,7 +401,9 @@
finally
(return (list (reverse interactives) (reverse outforms)))))
+
(defmacro* defn (name &rest rest)
+ "Clojure-style function definition. Supports recur and destructuring bind."
(declare (indent defun))
(let-seq (interactives clean-rest) (extract-interactive-and-return rest)
(if ($ (length interactives) > 1) (error "Too many interactive forms in %s." name))
@@ -410,6 +415,7 @@
(apply ,undername ,args)))))))
(defmacro* defn_ (name &rest rest)
+ "Clojure-style function definition. Supports recur and destructuring bind. Non-lexical binding version."
(declare (indent defun))
(let-seq (interactives clean-rest) (extract-interactive-and-return rest)
(if ($ (length interactives) > 1) (error "Too many interactive forms in %s." name))
@@ -448,6 +454,18 @@
(dsetq ,@(loop for b in (coerce binding-forms 'list) and v in (cdr form)
collect b and collect v))))
+(defun let-likep (form)
+ (and (listp form)
+ form
+ (let ((f (car form)))
+ (or
+ (eq f 'let)
+ (eq f 'flet)
+ (eq f 'labels)
+ (eq f 'lexical-let)
+ (eq f 'lexical-let*)
+ (eq f 'let*)))))
+
(defun* expand-recur (form parent-is-tale loop-sentinal binding-forms &optional (single-arg-recur nil))
(let ((mxform (macroexpand form)))
(cond ((symbolp mxform) mxform)
@@ -486,6 +504,17 @@
((prognp mxform)
`(,@(reverse (cdr (reverse mxform)))
,(expand-recur (car (reverse mxform)) t loop-sentinal binding-forms single-arg-recur)))
+ ((let-likep mxform)
+ (let* ((letish (car mxform))
+ (ll-binders (cadr mxform))
+ (body (cddr mxform))
+ (reverse-body (reverse body))
+ (all-but-last (reverse (cdr reverse-body)))
+ (last-item (car reverse-body)))
+ `(,letish
+ ,ll-binders
+ ,@all-but-last
+ ,(expand-recur last-item t loop-sentinal binding-forms single-arg-recur))))
((recurp mxform)
(if single-arg-recur
(expand-recur-recur `(recur (list ,@(cdr mxform)))
View
55 elab.el
@@ -0,0 +1,55 @@
+(defun nilp (x)
+ (eq nil x))
+
+(defun quotep (form)
+ (and (listp form)
+ (not (nilp form))
+ (equal 'quote (car form))))
+
+(setf *matlab-macros* (tbl!))
+(defmacro* defmatlab-macro (name args &body body)
+ (let ((actual-name (inter (format "%s-elab--" name))))
+ `(progn
+ (defun* ,actual-name ,args ,@body)
+ (tbl! *matlab-macros* ',name ',actual-name))))
+
+
+(defun matlab-macrop (symbol)
+ ($ symbol in *matlab-macros*))
+
+(defun expand-matlab-macro (form)
+ (let ((macro-name (tbl *matlab-macros* (car form)))
+ (macro-body (cdr form)))
+ (apply macro-name body)))
+
+(defun sym->camel-case (s)
+ (let* ((parts (split-string (format "%s" s) "-"))
+ (parts (cons (car parts) (mapcar #'capitalize (cdr parts)))))
+ (apply #'concat parts)))
+
+(sym->camel-case 'test-this)
+
+(defun prognp (form)
+ (and (listp form)
+ (not (nilp form))
+ (equal (car form) 'progn)))
+
+(defun form->matlab (form)
+ (cond ((numberp form) (format "%s" form))
+ ((stringp form)
+ (replace-regexp-in-string "'" "''" formm))
+ ((symbolp form) (sym->camel-case form))
+ ((listp form)
+ (cond
+ ((nilp form) "[]")
+ ((quotep form) "'%s'" (replace-regexp-in-string "'" "''" (form->matlab (cadr form))))
+ ((matlab-macrop form)
+ (form->matlab (expand-matlab-macro form)))
+ (t
+ (let ((f-name (sym->camel-case (car form)))
+ (args (join (mapcar #'form->matlab (cdr form)) ", ")))
+ (format "%s(%s)" f-name args)))))))
+
+
+(form->matlab '(sin some-data 2))
+
View
@@ -0,0 +1,22 @@
+(defun let-like? (form)
+ (and (listp form)
+ (let ((head (first form)))
+ (foldl
+ (lambda (it ac)
+ (or (= it head)))
+ nil
+ '(let let* lexical-let lexical-let*)))))
+(defun expand-ellision (form)
+ (cond
+ ((atom form) form)
+ ((listp form)
+ (let* ((head (first form))
+ (head-string (format "%s" head))
+ (any-&
+
+(defmacro* with-ellision (&body body)
+ (let ((exp-body (macroexpand-all body)))
+
+
+(macroexpand-all '(defun f (x) (+ x 1)))
+
View
@@ -0,0 +1,22 @@
+(defun take-randomly (lst)
+ (let ((ind (floor (random (length lst)))))
+ (dloop [index 0
+ [item & rest] lst
+ front nil]
+ (if (= index ind) (list item (append (reverse front) rest))
+ (recur (+ 1 index) rest (cons item front))))))
+
+(take-randomly '(1 2 3 4 5 6))
+
+(defun generate-plucking-pattern ()
+ (dloop [in-strings '(E A D G B e)
+ out-strings nil]
+ (if in-strings
+ (dlet [[item rest] (take-randomly in-strings)]
+ (recur rest (cons item out-strings)))
+ out-strings)))
+
+(generate-plucking-pattern)
+
+
+
Oops, something went wrong.

0 comments on commit bb18ea6

Please sign in to comment.