(defmacro fbind-1 (bindings &body body)
  (let ((bindings (mapcar (lambda (b) (append b (list (gensym))))
                          bindings)))
    (eval
     `(alexandria:once-only ,(mapcar (lambda (b) `(,(third b) ',(second b)))
                                     bindings)
        ;; Dance around with BINDINGS since we're doubly quoted.
        ;; We're using LIST to force double evaluation!
        `(flet ,(list ,@(mapcar (lambda (b) ``(,',(first b) (&rest args)
                                               (apply ,,(third b) args)))
                          bindings))
           ;; Splice the value of BODY immediately but fully expand it only
           ;; later on.
           ,@',body)))))

;; --------------------------------------------------------------------------------

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun zip (&rest seqs)
    (apply #'mapcar (lambda (&rest elems) (apply #'list elems))
           seqs)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun gensyms (n)
    (loop :repeat n
          :collect (gensym))))

(defmacro eval-with (bindings &body body)
  ;; Dance around with BINDINGS since we're doubly quoted.
  `(eval `(let ,(list ,@(mapcar (lambda (b) ``(,',b ',,b))
                                bindings))
            ,,@body)))

(defmacro once-only-list-eval ((oo initforms) pass-over &body body)
  "Evaluates INITFORMS to get a list of forms that have to be evaluated only
once within the expansion we're helping to write. OO will be bound to a list of
gensyms that will show up in the final expansion. PASS-OVER is a list of
variables that the caller wants to \"pass over\" (an unfortunate consequence of
using EVAL).
"
  (alexandria:with-gensyms (forms syms)
    ;; ONCE-ONLY takes pairs of the form (SYMBOL INITFORM), where INITFORM is an
    ;; expression that when evaluated gives the form that will be evaluated
    ;; within the expansion. That's why we're quoting the forms (since they
    ;; don't reside in variables as usual).
    `(let* ((,forms (mapcar (lambda (f) `',f) ,initforms))
            (,syms (gensyms (length ,forms))))
       ;; Unforunately, the abstraction (the use of EVAL under the hood) shows
       ;; through. The user has to explicitly list all of the symbols that he
       ;; wishes to use within the EVAL (and whose value will be taken from
       ;; EVAL's outer scope).
       (eval-with ,pass-over
         `(alexandria:once-only ,(zip ,syms ,forms)
            ;; Use LIST to force the evaluation of gensyms given to ONCE-ONLY.
            ;; We're gathering the gensyms that will be used in the expansion
            ;; that ONCE-ONLY helped write, into a list bound to whichever
            ;; symbol was given as OO.
            (let ((,',oo (list ,@,syms)))
              ,@',body))))))

(defmacro fbind-2 (bindings &body body)
  (once-only-list-eval (oo (mapcar #'second bindings))
                       (bindings body)
    (let ((names (mapcar (lambda (b o) (list (first b) o))
                         bindings oo)))
      `(flet ,(mapcar (lambda (n) `(,(first n) (&rest args)
                                    (apply ,(second n) args)))
               names)
         ,@body))))

;; --------------------------------------------------------------------------------

(defmacro once-only-list-macro-function ((oo initforms) env pass-over &body body)
  (alexandria:with-gensyms (fun syms forms)
    `(let* ((,fun (macro-function 'alexandria:once-only))
            (,forms (mapcar (lambda (f) `',f) ,initforms))
            (,syms (gensyms (length ,forms))))
       (eval-with ,pass-over
         (funcall ,fun
                  (list 'alexandria:once-only
                        (zip ,syms ,forms)
                        `(let ((,',oo (list ,@,syms)))
                           ,@',body))
                  ,env)))))

(defmacro fbind (&environment env bindings &body body)
  (once-only-list-macro-function (oo (mapcar #'second bindings))
                                 env
                                 (bindings body)
    (let ((names (mapcar (lambda (b o) (list (first b) o))
                         bindings oo)))
      `(flet ,(mapcar (lambda (n) `(,(first n) (&rest args)
                                    (apply ,(second n) args)))
               names)
         ,@body))))

;; --------------------------------------------------------------------------------

(let ((counter 0))
  (flet ((get-function (x) (lambda (a) (+ a x))))
    (format t "counter before: ~a~%" counter)
    (fbind ((fun1 (progn (incf counter) (get-function 5)))
            (fun2 (get-function 10)))
      (format t "counter after: ~a~%" counter)
      (prog1 (list (fun1 5)
                   (fun1 5)
                   (fun2 10)
                   (fun2 10))
        (format t "counter way after: ~a~%" counter)))))

;; > counter before: 0
;; > counter after: 1
;; > counter way after: 1
;; => (10 10 20 20)