Permalink
Browse files

Fixed conjoin / disjoin compiler macros and added compiler macro for …

…compose.

darcs-hash:20090212234629-ce594-9a85a4be05a85ae56621bcb9b30ba7025d77adf4.gz
  • Loading branch information...
1 parent bd55ecf commit a9efdb1a185511aef8fa676eda6f4440ff13aaf2 gugamilare committed Feb 12, 2009
Showing with 33 additions and 17 deletions.
  1. +3 −0 dev/utilities/macros.lisp
  2. +30 −17 dev/utilities/utilities.lisp
@@ -225,6 +225,9 @@ predicate."
;;; ---------------------------------------------------------------------------
+(defun funcallable-expression-p (exp)
+ (and (consp exp) (member (car exp) '(quote function))))
+
(defun function-expression-p (exp)
(and (consp exp) (eq (car exp) 'function)))
@@ -554,7 +554,8 @@ example:
;; Hard to say if it was worth the effort.
(with-unique-names (args)
`#'(lambda (&rest ,args)
- ; can I safely declare this to have dynamic extent???
+ ; can I safely declare this to have dynamic extent??? - Well, why not?
+ (declare (dynamic-extent ,args))
(apply ,fun ,@curried-args ,args))))
;;; FIXME: I can't decide if the 1 argument case should get a special function. If
@@ -586,6 +587,18 @@ of the curry."
(setf result (funcall fn result)))
result))))
+(define-compiler-macro compose (&rest fns)
+ (let ((last (car (last fns))))
+ (with-unique-names (args)
+ `(lambda (&rest ,args)
+ ,(reduce #'(lambda (fn arg)
+ (if (funcallable-expression-p fn)
+ `(,(extract-head-form fn) ,arg)
+ `(funcall ,fn ,arg)))
+ (butlast fns)
+ :initial-value `(apply ,last ,args)
+ :from-end t)))))
+
#+Old
(defun compose (fn1 fn2)
"Return a function that is the composition of fn1 and fn2. I.e.,
@@ -605,14 +618,14 @@ of the curry."
(and z (apply y args))))) (cons fn fns)
:from-end t))
-(define-compiler-macro conjoin (&whole form &rest fns)
- (cond ((every #'(lambda (x) (or (symbolp x) (function-expression-p x))) fns)
- (with-unique-names (arg)
- `#'(lambda (,arg)
- (and ,@(mapcar #'(lambda (x)
- `(,(extract-head-form x) ,arg))
- fns)))))
- (t form)))
+(define-compiler-macro conjoin (&rest fns)
+ (with-unique-names (arg)
+ `#'(lambda (,arg)
+ (and ,@(mapcar #'(lambda (fn)
+ (if (funcallable-expression-p fn)
+ `(,(extract-head-form fn) ,arg)
+ `(funcall ,fn ,arg)))
+ fns)))))
;;; ---------------------------------------------------------------------------
;;; return a function that is the disjunction of fns. basically a functional or
@@ -626,14 +639,14 @@ of the curry."
(or z (apply y args))))) (cons fn fns)
:from-end t))
-(define-compiler-macro disjoin (&whole form &rest fns)
- (cond ((every #'(lambda (x) (or (symbolp x) (function-expression-p x))) fns)
- (with-unique-names (arg)
- `#'(lambda (,arg)
- (or ,@(mapcar #'(lambda (x)
- `(,(extract-head-form x) ,arg))
- fns)))))
- (t form)))
+(define-compiler-macro disjoin (&rest fns)
+ (with-unique-names (arg)
+ `#'(lambda (,arg)
+ (or ,@(mapcar #'(lambda (fn)
+ (if (funcallable-expression-p fn)
+ `(,(extract-head-form fn) ,arg)
+ `(funcall ,fn ,arg)))
+ fns)))))
;;; ---------------------------------------------------------------------------

0 comments on commit a9efdb1

Please sign in to comment.