`with-refs` Macro

with-refs.scm

(define-module (antlers utils with-refs)
               #:use-module (ice-9 match)
               #:use-module (srfi srfi-1)
               #:use-module (srfi srfi-9)
               #:export (with-refs))

;;; Commentary:
;;
;; The first draft looked like this, which, to be honest, I kind of like for it's simplicity.
;; Ditched it because of the repetitive match-lambda-lists and hash-set/-ref
;; calls, but... it feels so short readable, even by comparison to where I ended up.
;;
;; (define (with-refs* clauses thunk)
;;   (define bindings (make-hash-table))
;;   (define register-clause-bindings
;;     (match-lambda (`((,module-ref ,var-ref) ,val)
;;                     (hash-set! bindings (list module-ref var-ref 'module) (gensym))
;;                     (hash-set! bindings (list module-ref var-ref 'internal-val) (gensym))
;;                     (hash-set! bindings (list module-ref var-ref 'external-val) (gensym)))))
;;   (define clause->bindings
;;     (match-lambda (`((,module-ref ,var-ref) ,val)
;;                     `((,(hash-ref bindings (list module-ref var-ref 'module)) (resolve-module ,module-ref))
;;                       (,(hash-ref bindings (list module-ref var-ref 'internal-val)) ,val)
;;                       (,(hash-ref bindings (list module-ref var-ref 'external-val)) #f)))))
;;   (define clause->setter
;;     (match-lambda (`((,module-ref ,var-ref) ,val)
;;                     `((set! ,(hash-ref bindings (list module-ref var-ref 'external-val))
;;                              (module-ref ,(hash-ref bindings (list module-ref var-ref 'module)) ,var-ref))
;;                       (module-define! ,(hash-ref bindings (list module-ref var-ref 'module))
;;                                       (quote ,var-ref)
;;                                       ,(hash-ref bindings (list module-ref var-ref 'internal-val)))))))
;;   (define clause->resetter
;;     (match-lambda (`((,module-ref ,var-ref) ,val)
;;                     `((set! ,(hash-ref bindings (list module-ref var-ref 'internal-val))
;;                              (module-ref ,(hash-ref bindings (list module-ref var-ref 'module)) ,var-ref))
;;                       (module-define! ,(hash-ref bindings (list module-ref var-ref 'module))
;;                                       (quote ,var-ref)
;;                                       ,(hash-ref bindings (list module-ref var-ref 'external-val)))))))
;;   (map register-clause-bindings clauses)
;;   `(let ,@(map clause->bindings clauses)
;;      (dynamic-wind
;;        (lambda () ,@(append-map clause->setter clauses))
;;        ,thunk
;;        (lambda () ,@(append-map clause->resetter clauses)))))
;;
;;; Code:

(define *unset-gensym* (gensym))

(define-record-type <clause>
  (make-clause module-ref var-ref initial-val
               module-gensym internal-val-gensym external-val-gensym)
  clause?
  (module-ref          clause-module-ref)
  (var-ref             clause-var-ref)
  (initial-val         clause-initial-val)
  (module-gensym       clause-module-gensym)
  (internal-val-gensym clause-internal-val-gensym)
  (external-val-gensym clause-external-val-gensym))
  
(define (clause->bindings clause)
  `((,(clause-module-gensym clause) (resolve-module ,(clause-module-ref clause)))
    (,(clause-internal-val-gensym clause) ,(clause-initial-val clause))
    (,(clause-external-val-gensym clause) #f)))

(define (clause->setter clause)
  `((set! ,(clause-external-val-gensym clause)
           (if (module-bound? ,(clause-module-gensym clause) ,(clause-var-ref clause))
               (module-ref ,(clause-module-gensym clause) ,(clause-var-ref clause))
             ,*unset-gensym*))
    (module-define! ,(clause-module-gensym clause)
                    ,(clause-var-ref clause)
                    ,(clause-internal-val-gensym clause))))

(define (clause->resetter clause)
  `((cond ((equal? ,(clause-external-val-gensym clause) ,*unset-gensym*)
           (variable-unset! (module-variable ,(clause-module-gensym clause) ,(clause-var-ref clause))))
          (else (set! ,(clause-internal-val-gensym clause)
                           (module-ref ,(clause-module-gensym clause) ,(clause-var-ref clause)))
                (module-define! ,(clause-module-gensym clause)
                                ,(clause-var-ref clause)
                                ,(clause-external-val-gensym clause))))))

(define (with-refs* clauses* thunk)
  (define clauses '())
  (define register-clause
    (match-lambda (`((,module-ref ,var-ref) ,val)
                    (set! clauses (cons (make-clause module-ref var-ref val (gensym) (gensym) (gensym))
                                         clauses)))))
  (map register-clause clauses*)
  `(let ,(cons `(,*unset-gensym* (gensym))
               (append-map clause->bindings clauses))
     (dynamic-wind
       (lambda () ,@(append-map clause->setter clauses))
       ,thunk
       (lambda () ,@(append-map clause->resetter clauses)))))

(defmacro with-refs (clauses expr . rest)
  (with-refs* clauses `(lambda () ,@(cons expr rest))))