;;;; synch-exn.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-exn

(;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
  (chicken base)
  (chicken syntax)
  (chicken condition)
  (only (srfi 18)
    thread?
    make-mutex mutex?
    mutex-specific mutex-specific-set!
    mutex-lock! mutex-unlock!
    mutex-state)
  synch-object
  synch-params)

;;; Protected

;;

(define-syntax synch
  (syntax-rules ()
    ;
    ((synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...) ?abandon?) ?body ...)
      ;eval args ahead of time
      (let ((mtx ?mtx))
        ;do not continue when cannot get a lock
        (when (apply mutex-lock! mtx (list ?lock-arg0 ...))
          (let ((abandon? ?abandon?) (exception? #f) (unlock-args (list ?unlock-arg0 ...)))
            (let ((results
                    (handle-exceptions exn
                      (begin
                        (set! exception? #t)
                        (unless abandon? (apply mutex-unlock! mtx unlock-args))
                        (list exn) )
                      (call-with-values
                        (lambda () ?body ...)
                        (lambda results (apply mutex-unlock! mtx unlock-args) results)))) )
              (cond (exception?
                      ((current-synch-raise) (car results)) )
                    (else
                      (apply values results) ) ) ) ) ) ) )
    ;
    ((synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
      (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 ...) ) ) )

;;

(include-relative "synch-incl")

) ;module synch-exn