Guile-hoot/module/hoot/fluids.scm

;;; Fluids
;;; Copyright (C) 2024 Igalia, S.L.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Fluids and dynamic states.
;;;
;;; Code:

(library (hoot fluids)
  (export make-fluid
          fluid-ref
          fluid-set!
          with-fluid*
          with-dynamic-state
          with-fluids)
  (import (hoot primitives))

  (define* (make-fluid #:optional default-value)
    (%inline-wasm '(func (param $default (ref eq)) (result (ref eq))
                         (struct.new $fluid (i32.const 0)
                                     (local.get $default)))
                  default-value))
  (define (fluid-ref x) (%fluid-ref x))
  (define (fluid-set! x y) (%fluid-set! x y))
  (define (with-fluid* fluid val thunk) (%with-fluid* fluid val thunk))
  (define (with-dynamic-state state thunk) (%with-dynamic-state state thunk))

  (define-syntax with-fluids
    (lambda (stx)
      (define (emit-with-fluids bindings body)
        (syntax-case bindings ()
          (()
           body)
          (((f v) . bindings)
           #`(with-fluid* f v
               (lambda ()
                 #,(emit-with-fluids #'bindings body))))))
      (syntax-case stx ()
        ((_ ((fluid val) ...) exp exp* ...)
         (with-syntax (((fluid-tmp ...) (generate-temporaries #'(fluid ...)))
                       ((val-tmp ...) (generate-temporaries #'(val ...))))
           #`(let ((fluid-tmp fluid) ...)
               (let ((val-tmp val) ...)
                 #,(emit-with-fluids #'((fluid-tmp val-tmp) ...)
                                     #'(let () exp exp* ...))))))))))