partial-application.lisp

(defmacro cut (&rest args)
  (let ((func (cond ((eql '<> (car args)) (gensym))
		    ((symbolp (car args)) (list 'function (car args)))
		    (t (car args))))
	(gensyms (loop repeat (count '<> (cdr args))
		    collect (gensym)))
	(rest-arg (if (eql '<...> (car (last (cdr args)))) `(&rest ,(gensym)))))
    (labels ((rec (args-list gensyms-list result)
	       (cond ((null args-list) (reverse result))
		     ((eql '<> (car args-list))
		      (rec (cdr args-list) (cdr gensyms-list)
			   (cons (car gensyms-list) result)))
		     ((eql '<...> (car args-list))
		      (rec (cdr args-list) (cdr gensyms-list)
			   (cons (cadr rest-arg) result)))
		     (t (rec (cdr args-list) gensyms-list
			     (cons (car args-list) result))))))
      `(lambda ,(nconc (if (symbolp func) (cons func gensyms) gensyms)
		       rest-arg)
	 (funcall ,func ,@(rec (cdr args) gensyms nil))))))

(defmacro cute (&rest args)
  (let* ((func (cond ((eql '<> (car args)) (gensym))
		     ((symbolp (car args)) (list 'function (car args)))
		     (t (car args))))
	 (count (count '<> (cdr args)))
	 (gensyms (loop repeat count collect (gensym)))
	 (syms (loop repeat (- (list-length (cdr args)) count)
		       collect (gensym)))
	 (rest-arg (if (eql '<...> (car (last (cdr args))))
		       `(&rest ,(gensym)))))
    (labels ((rec (args-list gensyms-list result syms-list bindings)
	       (cond ((null args-list) (values (reverse result)
					       (reverse bindings)))
		     ((eql '<> (car args-list))
		      (rec (cdr args-list) (cdr gensyms-list)
			   (cons (car gensyms-list) result) syms-list
			   bindings))
		     ((eql '<...> (car args-list))
		      (rec (cdr args-list) (cdr gensyms-list)
			   (cons (cadr rest-arg) result) syms-list
			   bindings))
		     (t (rec (cdr args-list) gensyms-list
			     (cons (car syms-list) result) (cdr syms-list)
			     (cons (list (car syms-list) (car args-list))
				   bindings))))))
      (multiple-value-bind (args-result bindings)
	  (rec (cdr args) gensyms nil syms nil)
	`(let ,bindings
	   (lambda ,(nconc (if (symbolp func) (cons func gensyms) gensyms)
			   rest-arg)
	     (funcall ,func ,@args-result)))))))

SRFI-26