My attempt at making almost first-class currying in CL.

currying.lisp

(defun intern-gen-sym (&optional str)
  (if str
      (intern (format nil "intern-g~a~s" str (incf *gensym-counter*)))
      (intern (format nil "intern-g~s" (incf *gensym-counter*)))))


(define-condition recursive-currying-lambda (error)
  ((datum :initform "Cannot curry lambda with 0 arguments" :allocation :class)))


(defmacro curried-lambda (lambda-list &body body)
  (let ((list-of-names
          (loop :with len := (length lambda-list)
                :for n :from 0 :upto len
                :collect (intern-gen-sym (format nil "CURRY--~s" n)))))
      `(lambda (&rest args)
         (ecase (length args)
           ,@(loop :with len := (length lambda-list)
                   :for n :from 0 :upto len
                   :if (zerop n)
                     :collect `(0 (error 'recursive-currying-lambda))
                   :else
                     :if (/= n len)
                       :collect `(,n (labels ((,(elt list-of-names n) ,(subseq lambda-list 0 n)
                                                (curried-lambda ,(subseq lambda-list n)
                                                  ,@body)))
                                       (apply #',(elt list-of-names n) args)))
                   :else
                     :collect `(,n (labels ((,(elt list-of-names n) ,(subseq lambda-list 0 n)
                                              ,@body))
                                     (apply #',(elt list-of-names n) args))))))))



(defmacro defcurry (name lambda-list &body body)
  (let ((list-of-names
          (loop :with len := (length lambda-list)
                :for n :from 0 :upto len
                :collect (intern-gen-sym (format nil "CURRY-~a-~s" name n))))
        (ftype-declaration (if (eql (caar body) 'declare)
                               (destructuring-bind (dec . (what)) (car body)
                                 (declare (ignorable dec))
                                 (when (eql (car what) 'ftype)
                                   (cadr (pop body))))))
        (inline-declaration (if (eql (caar body) 'declare)
                                (destructuring-bind (dec . (what)) (car body)
                                  (declare (ignorable dec))
                                  (when (eql (car what) 'inline)
                                    (cadr (pop body)))))))
    `(progn
       (defun ,name (&rest args)
         (ecase (length args)
           ,@(loop :with len := (length lambda-list)
                   :for n :from 0 :upto len
                   :if (/= n len)
                     :collect `(,n (labels ((,(elt list-of-names n) ,(subseq lambda-list 0 n)
                                              (curried-lambda ,(subseq lambda-list n)
                                                (declare ,@(if ftype-declaration
                                                               (loop :for arg :in (subseq lambda-list n)
                                                                     :for arg-num :from 0
                                                                     :collect `(type ,(elt (second (second ftype-declaration)) (+ n arg-num)) ,arg))))
                                                ,@body)))
                                     (declare ,(if inline-declaration
                                                   `(inline ,(elt list-of-names n))
                                                   ()))
                                     (declare ,(if ftype-declaration
                                                   (destructuring-bind (_ftype (_function var-list return-type) _name) ftype-declaration
                                                     (declare (ignorable _ftype) (ignorable _function) (ignorable _name) (ignorable return-type))
                                                     `(ftype (function ,(subseq var-list 0 n) function) ,(elt list-of-names n)))
                                                   ()))
                                     (apply #',(elt list-of-names n) args)))
                   :else
                     :collect `(,n (labels ((,(elt list-of-names n) ,(subseq lambda-list 0 n)
                                              ,@body))
                                     (declare ,(if inline-declaration
                                                   `(inline ,(elt list-of-names n))
                                                   ()))
                                     (declare ,(if ftype-declaration
                                                   (destructuring-bind (_ftype (_function var-list return-type) _name) ftype-declaration
                                                     (declare (ignorable _ftype) (ignorable _function) (ignorable _name))
                                                     `(ftype (function ,(subseq var-list 0 n) ,return-type) ,(elt list-of-names n)))
                                                   ()))
                                     (apply #',(elt list-of-names n) args))))))
       (define-compiler-macro ,name (&rest args)
         (ecase (length args)
           ,@(loop :with len := (length lambda-list)
                   :for n :from 0 :upto len
                   :if (/= n len)
                     :collect `(,n `(labels ((,',(elt list-of-names n)
                                                 ,',(subseq lambda-list 0 n)
                                               (curried-lambda ,',(subseq lambda-list n)
                                                 (declare ,@,@(mapcar (lambda (x) `(quote ,x))
                                                                      (if ftype-declaration
                                                                          (loop :for arg :in (subseq lambda-list n)
                                                                                :for arg-num :from 0
                                                                                :collect `((type ,(elt
                                                                                                   (second (second ftype-declaration))
                                                                                                   (+ n arg-num)) ,arg))))))
                                                 ,,@(mapcar (lambda (x) `(quote ,x)) body))))
                                      (declare ,',(if inline-declaration
                                                      `(inline ,(elt list-of-names n))
                                                      ()))
                                      (declare ,',(if ftype-declaration
                                                      (destructuring-bind (_ftype (_function var-list return-type) _name) ftype-declaration
                                                        (declare (ignorable _ftype) (ignorable _function) (ignorable _name) (ignorable return-type))
                                                        `(ftype (function ,(subseq var-list 0 n) function) ,(elt list-of-names n)))
                                                      ()))
                                      (,',(elt list-of-names n) ,@args)))
                   :else
                     :collect `(,n `(labels ((,',(elt list-of-names n) ,',(subseq lambda-list 0 n)
                                               ,,@(mapcar (lambda (x) `(quote ,x)) body)))
                                      (declare ,',(if inline-declaration
                                                      `(inline ,(elt list-of-names n))
                                                      ()))
                                      (declare ,',(if ftype-declaration
                                                      (destructuring-bind (_ftype (_function var-list return-type) _name) ftype-declaration
                                                        (declare (ignorable _ftype) (ignorable _function) (ignorable _name))
                                                        `(ftype (function ,(subseq var-list 0 n) ,return-type) ,(elt list-of-names n)))
                                                      ()))
                                      (,',(elt list-of-names n) ,@args)))))))))



;; Example
(defcurry foo (a b c)
  (declare (ftype (function (fixnum fixnum fixnum) fixnum) foo))
  (declare (inline foo))
  (declare (optimize (speed 3) (compilation-speed 0)))
  (+ a (* b c)))

;; You can call it just like any regular function now. All of the below calls are legal:
(funcall (foo) 1)
(foo 1 2)
(foo 1)
(funcall (foo 1 2) 3)