;;;; synch-dyn.scm
;;;; Kon Lovett, Dec '18

;; Issues
;;
;; - syntax checking is minimal so expansion errors are cryptic
;;
;; - dynamic-wind exit is invoked by thread scheduler

(module synch-dyn

(;export
  ;;
  current-synch-exit-condition
  current-synch-raise synch-raise-warning
  current-synch-abandon?
  ;;
  synch
  synch-lock
  synch-unlock
  ;;
  synch-with
  call-synch
  call-synch-with
  apply-synch
  apply-synch-with
  let-synch-with
  set!-synch-with
  ;;
  object-synch-cut-with
  record-synch
  record-synch-lock
  record-synch-unlock
  ;;
  make-synch-with-object
  synch-with-object? check-synch-with-object error-synch-with-object
  ;
  define-constructor-synch
  define-predicate-synch
  define-operation-synch
  ;
  synchronized-procedure)

(import scheme)
(import (chicken base))
(import (chicken syntax))
(import (only (srfi 18)
  thread?
  make-mutex mutex?
  mutex-specific mutex-specific-set!
  mutex-lock! mutex-unlock!
  mutex-state))
(import synch-object)
(import synch-params)

;;; Protected

;;

(define-syntax synch
  (syntax-rules ()
    ;
    ((synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...) ?abandon?) ?body ...)
      ;eval args ahead of time
      (let (
        (mtx ?mtx)
        (lock-args (list ?lock-arg0 ...))
        (unlock-args (list ?unlock-arg0 ...))
        (abandon? ?abandon?) )
        ;do not continue when cannot get a lock
        (when (apply mutex-lock! ?mtx lock-args)
          (let (
            (ok? (not abandon?)) )
            (let (
              (result
                (dynamic-wind
                  void
                  (lambda ()
                    (let (
                      (result (begin ?body ...)) )
                      (set! ok? #t)
                      result ) )
                  (lambda ()
                    (when ok?
                      (apply mutex-unlock! ?mtx unlock-args))))) )
              (cond
                ((not ok?)
                  ((current-synch-raise) (current-synch-exit-condition)) )
                (else
                  result ) ) ) ) ) ) )
    ;
    ((synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
      (let ((mtx ?mtx))
        (synch (mtx (?lock-arg0 ...) (?unlock-arg0 ...) #f) ?body ...) ) )
    ;
    ((synch (?mtx (?lock-arg0 ...)) ?body ...)
      (synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
    ;
    ((synch (?mtx) ?body ...)
      (synch (?mtx () () (current-synch-abandon?)) ?body ...) )
    ;
    ((synch ?mtx ?body ...)
      (synch (?mtx) ?body ...) ) ) )
;;

(define-syntax synch-lock
  (syntax-rules ()
    ;
    ((synch-lock (?mtx (?lock-arg0 ...)) ?body ...)
      (let ((mtx ?mtx))
        (let ((ok? #f))
          (when (mutex-lock! mtx ?lock-arg0 ...)
            (dynamic-wind
              void
              (lambda ()
                (let ((res (begin ?body ...)))
                  (set! ok? #t)
                  res))
              (lambda ()
                (unless ok?
                  (mutex-unlock! mtx)))) ) ) ) )
    ;
    ((synch-lock ?mtx ?body ...)
      (synch-lock (?mtx ()) ?body ...) ) ) )

(define-syntax synch-unlock
  (syntax-rules ()
    ;
    ((synch-unlock (?mtx (?unlock-arg0 ...)) ?body ...)
      (let ((mtx ?mtx))
        (let ((st (mutex-state mtx)))
          (if (or (eq 'abandoned st) (eq 'not-abandoned st))
            (error 'synch-unlock "mutex unlocked" mtx)
            (dynamic-wind
              void
              (lambda () ?body ...)
              (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) ) ) )
    ;
    ((synch-unlock ?mtx ?body ...)
      (synch-unlock (?mtx ()) ?body ...) ) ) )

;;

(include "synch-incl")

) ;module synch-dyn