;;;; synch.scm
;;;; Kon Lovett, Jan '18
;;;; Kon Lovett, May '17
;;;; Kon Lovett, Mar '06

;; Issues
;;
;; - syntax checking is minimal so expansion errors are cryptic

(module synch

(;export
  ;;
  synch
  synch-with
  call-synch
  call-synch-with
  apply-synch
  apply-synch-with
  let-synch-with
  set!-synch-with
  synch-lock
  synch-unlock
  object-synch-cut-with
  record-synch
  record-synch-lock
  record-synch-unlock
  ;;
  %synch
  %synch-with
  %call-synch
  %call-synch-with
  %apply-synch
  %apply-synch-with
  %let-synch-with
  %set!-synch-with
  %synch-lock
  %synch-unlock
  %object-synch-cut-with
  %record-synch
  %record-synch-lock
  %record-synch-unlock
  ;;
  make-synch-with-object
  synch-with-object?
  define-constructor-synch
  define-predicate-synch
  (define-operation-synch check-synch-with-object)
  define-operation-%synch
  ;
  synchronized-procedure
  ;;
  ;DEPRECATED
  call/synch
  call-with/synch
  apply/synch
  apply-with/synch
  let/synch
  set!/synch
  synch/lock
  synch/unlock
  object/synch
  record/synch
  record-synch/lock
  record-synch/unlock
  %call/synch
  %call-with/synch
  %apply/synch
  %apply-with/synch
  %let/synch
  %set!/synch
  %synch/lock
  %synch/unlock
  %object/synch
  %record/synch
  %record-synch/lock
  %record-synch/unlock
  make-object/synch
  object?/synch
  define-constructor/synch
  define-predicate/synch
  (define-operation/synch check-synch-with-object)
  define-operation/%synch)

(import
  scheme
  (only chicken
    use
    declare
    define-for-syntax optional
    void unless warning gensym) )
(use
  (only srfi-18
    thread?
    make-mutex mutex?
    mutex-specific mutex-specific-set!
    mutex-lock! mutex-unlock!
    mutex-state)
  (only type-checks
    define-check+error-type
    check-procedure) )

;;;

(define-for-syntax (record-mutex-name nam)
  (string->symbol (string-append (symbol->string nam) "-" "mutex")) )

;;; Protected

;;

(define-syntax synch
	(syntax-rules ()
    ;
		((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
    	(let ((mtx ?mtx))
        (dynamic-wind
          (lambda () (mutex-lock! mtx ?lock-arg0 ...))
          (lambda () ?body ...)
          (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    ;
		((_ (?mtx (?lock-arg0 ...)) ?body ...)
    	(synch (?mtx (?lock-arg0 ...) ()) ?body ...) )
    ;
		((_ ?mtx ?body ...)
    	(synch (?mtx () ()) ?body ...) ) ) )

;;

(define-syntax synch-with
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
      ;
      (let (
        (_dynamic-wind (rnm 'dynamic-wind) )
        (_let (rnm 'let) )
        (_lambda (rnm 'lambda) )
        (_mutex-unlock! (rnm 'mutex-unlock!) )
        (_mutex-specific (rnm 'mutex-specific) )
        (_mutex-lock! (rnm 'mutex-lock!) )
        (mtxvar (rnm (gensym)) ) )
        ;
        (let (
          (?mtx (cadr frm) )
          (?var (caddr frm) )
          (?body (cdddr frm) ) )
          ;
          (call-with-values
            (lambda ()
              (if (not (pair? ?mtx))
                (values ?mtx '() '())
                (let ((mtx (car ?mtx))
                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
                  (values mtx lock-args unlock-args) ) ) )
            (lambda (?mtx ?lock-args ?unlock-args)
              `(,_let ((,mtxvar ,?mtx))
                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
                   (,_dynamic-wind
                     (,_lambda () (,_mutex-lock! ,mtxvar ,@?lock-args))
                     (,_lambda () ,@?body)
                     (,_lambda () (,_mutex-unlock! ,mtxvar ,@?unlock-args)) ) ) ) ) ) ) ) ) ) )

(define-for-syntax call-synch-transformer
	(syntax-rules ()
    ;
		((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
				  (lambda () (?proc ?arg0 ...))
				  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    ;
		((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
		  (call-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    ;
		((_ ?mtx ?proc ?arg0 ...)
		  (call-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )

(define-syntax call-synch call-synch-transformer)

(define-for-syntax call-synch-with-transformer
	(syntax-rules ()
    ;
		((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
				  (lambda () (?proc (mutex-specific mtx) ?arg0 ...))
				  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    ;
		((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
		  (call-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    ;
		((_ ?mtx ?proc ?arg0 ...)
		  (call-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )

(define-syntax call-synch-with call-synch-with-transformer)

(define-for-syntax apply-synch-transformer
	(syntax-rules ()
	  ((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
				  (lambda () (apply ?proc ?arg0 ...))
				  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
	  ((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
		  (apply-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    ;
		((_ ?mtx ?proc ?arg0 ...)
		  (apply-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )

(define-syntax apply-synch apply-synch-transformer)

(define-for-syntax apply-synch-with-transformer
	(syntax-rules ()
    ;
		((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda () (mutex-lock! mtx ?lock-arg0 ...))
				  (lambda () (apply ?proc (mutex-specific mtx) ?arg0 ...))
				  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    ;
		((_ (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
		  (apply-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    ;
		((_ ?mtx ?proc ?arg0 ...)
		  (apply-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )

(define-syntax apply-synch-with apply-synch-with-transformer)

(define-for-syntax let-synch-with-transformer
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (##sys#check-syntax 'let-synch-with frm '(_ list . _))
      ;
      (let ((_synch-with (rnm 'synch-with)))
        (let* (
          (?body
            (cddr frm) )
          (res
            (let loop ((bnds (cadr frm)))
              (if (null? bnds)
                ?body
                (let ((?bnd (car bnds)))
                  (##sys#check-syntax 'let-synch-with ?bnd '(variable . _))
                  `((,_synch-with ,(cadr ?bnd) ,(car ?bnd) ,@(loop (cdr bnds)))) ) ) ) ) )
          ;
          (car res) ) ) ) ) )

(define-syntax let-synch-with let-synch-with-transformer)

(define-syntax set!-synch-with
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
      ;
      (let (
        (_synch-with (rnm 'synch-with) )
        (_mutex-specific (rnm 'mutex-specific) )
        (_mutex-specific-set! (rnm 'mutex-specific-set!) )
        (_begin (rnm 'begin) ) )
        ;
        (let (
          (?mtx (cadr frm) )
          (?var (caddr frm) )
          (?body (cdddr frm) ) )
          ;
          `(,_synch-with ,?mtx ,?var
             (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
             (,_mutex-specific ,?mtx) ) ) ) ) ) )

;;

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

(define-syntax synch-lock synch-lock-transformer)

(define-for-syntax synch-unlock-transformer
	(syntax-rules ()
    ;
		((_ (?mtx (?unlock-arg0 ...)) ?body ...)
		  (let ((mtx ?mtx))
			  (dynamic-wind
				  (lambda ()
					  (unless (thread? (mutex-state mtx))
						  (warning 'synch-unlock "mutex is not locked - locking")
						  (mutex-lock! mtx)))
				  (lambda () ?body ...)
				  (lambda () (mutex-unlock! mtx ?unlock-arg0 ...)) ) ) )
    ;
		((_ ?mtx ?body ...)
		  (synch-unlock (?mtx ()) ?body ...) ) ) )

(define-syntax synch-unlock synch-unlock-transformer)

;;

(define-for-syntax object-synch-cut-with-transformer
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (##sys#check-syntax 'object-synch-cut-with frm '(_ _ . _))
      ;
      (let (
        (_synch-with (rnm 'synch-with))
        (_>< (rnm '><))
        (var (rnm (gensym)))
        (mtx (cadr frm)) )
        ;
        (let body-loop ((unparsed (cddr frm)) (parsed '()))
          (if (null? unparsed)
            ;
            `(,_synch-with ,mtx ,var ,@(reverse parsed))
            ;
            (let (
              (expr (car unparsed))
              (next (cdr unparsed)) )
              ;
              (let expr-loop ((rest expr) (parsed-expr '()))
                (cond
                  ;
                  ((null? rest)
                    (body-loop next (cons (reverse parsed-expr) parsed)))
                  ;
                  ((pair? rest)
                    (let (
                      (arg (car rest))
                      (next (cdr rest)) )
                      ;
                      (if (cmp _>< arg)
                        (expr-loop next (cons var parsed-expr))
                        (expr-loop next (cons arg parsed-expr)) ) ))
                  ;
                  ((cmp _>< rest)
                    (body-loop next (cons var parsed)))
                  ;
                  (else
                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )

(define-syntax object-synch-cut-with object-synch-cut-with-transformer)

;;

(define-syntax record-synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'record-synch frm '(_ _ symbol . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_synch (rnm 'synch)) )
        (let (
          (?rec (cadr frm))
          (?sym (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_synch (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax record-synch-lock
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'record-synch-lock frm '(_ _ symbol . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_synch-lock (rnm 'synch-lock)) )
        (let (
          (?rec (cadr frm))
          (?sym (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_synch-lock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax record-synch-unlock
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'record-synch-unlock frm '(_ _ symbol . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_synch-unlock (rnm 'synch-unlock)) )
        (let (
          (?rec (cadr frm))
          (?sym (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_synch-unlock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

;;; Unprotected

(define-syntax %*synch
	(syntax-rules ()
    ;
		((_ (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?body ...)
		  (let ((mtx ?mtx))
        (mutex-lock! mtx ?lock-arg0 ...)
				(call-with-values
					(lambda () ?body ...)
					(lambda ret
						(mutex-unlock! mtx ?unlock-arg0 ...)
						(apply values ret))) ) )
    ;
		((_ ?mtx ?body ...)
		  (%*synch (?mtx () ()) ?body ...) ) ) )

;;

(define-syntax %*synch-with
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%*synch-with frm '(_ _ variable . _))
      (let ((_call-with-values (rnm 'call-with-values))
            (_mutex-specific (rnm 'mutex-specific))
            (_mutex-lock! (rnm 'mutex-lock!))
            (_mutex-unlock! (rnm 'mutex-unlock!))
            (_let (rnm 'let))
            (_apply (rnm 'apply))
            (_values (rnm 'values))
            (_lambda (rnm 'lambda))
            (_ret (rnm 'ret))
            (mtxvar (rnm (gensym))))
        (let ((?mtx (cadr frm))
              (?var (caddr frm))
              (?body (cdddr frm)))
          (call-with-values
            (lambda ()
              (if (not (pair? ?mtx))
                (values ?mtx '() '())
                (let ((mtx (car ?mtx))
                      (lock-args (if (<= 2 (length ?mtx)) (cadr ?mtx) '()))
                      (unlock-args (if (= 3 (length ?mtx)) (caddr ?mtx) '())) )
                  (values mtx lock-args unlock-args) ) ) )
            (lambda (?mtx ?lock-args ?unlock-args)
              `(,_let ((,mtxvar ,?mtx))
                 (,_let ((,?var (,_mutex-specific ,mtxvar)))
                   (,_mutex-lock! ,mtxvar ,@?lock-args)
                   (,_call-with-values
                     (,_lambda () ,@?body)
                     (,_lambda ,_ret
                       (,_mutex-unlock! ,mtxvar ,@?unlock-args)
                       (,_apply ,_values ,_ret)) ) ) ) ) ) ) ) ) ) )

;;

(define-syntax %synch
	(syntax-rules ()
		((_ ?mtx ?body ...) (%*synch ?mtx ?body ...) ) ) )

;;

(define-syntax %synch-with
	(syntax-rules ()
		((_ ?mtx ?var ?body ...)
		  (%*synch-with ?mtx ?var ?body ...) ) ) )

(define-for-syntax %call-synch-transformer
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...)
		  (%*synch ?mtx (?proc ?arg0 ...)) ) ) )

(define-syntax %call-synch %call-synch-transformer)

(define-for-syntax %call-synch-with-transformer
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...)
		  (%*synch-with ?mtx var (?proc var ?arg0 ...)) ) ) )

(define-syntax %call-synch-with %call-synch-with-transformer)

(define-for-syntax %apply-synch-transformer
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...)
		  (%*synch ?mtx (apply ?proc ?arg0 ...)) ) ) )

(define-syntax %apply-synch %apply-synch-transformer)

(define-for-syntax %apply-synch-with-transformer
	(syntax-rules ()
		((_ ?mtx ?proc ?arg0 ...)
		  (%*synch-with ?mtx var (apply ?proc var ?arg0 ...)) ) ) )

(define-syntax %apply-synch-with %apply-synch-with-transformer)

(define-for-syntax %let-synch-with-transformer
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%let-synch-with frm '(_ list . _))
      (let ((_%synch-with (rnm '%synch-with)))
        (let ((?body (cddr frm)))
          (car
            (let loop ((?bnds (cadr frm)))
              (if (null? ?bnds)
                ?body
                (let ((bnd (car ?bnds)))
                  (##sys#check-syntax '%let-synch-with bnd '(variable _))
                  `((,_%synch-with ,(cadr bnd) ,(car bnd) ,@(loop (cdr ?bnds)))) ) ) ) ) ) ) ) ) )

(define-syntax %let-synch-with %let-synch-with-transformer)

(define-syntax %set!-synch-with
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (##sys#check-syntax 'set!-synch-with frm '(_ _ variable . #(_ 0)))
      ;
      (let (
        (_%synch-with (rnm '%synch-with) )
        (_mutex-specific (rnm 'mutex-specific) )
        (_mutex-specific-set! (rnm 'mutex-specific-set!) )
        (_let (rnm 'let) )
        (_begin (rnm 'begin) )
        (mtxvar (rnm (gensym)) ) )
        ;
        (let (
          (?mtx (cadr frm) )
          (?var (caddr frm) )
          (?body (cdddr frm) ) )
          ;
          `(,_let ((,mtxvar ,?mtx))
             (,_%synch-with ,mtxvar ,?var
               (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
               (,_mutex-specific ,mtxvar) ) ) ) ) ) ) )

;;

(define-for-syntax %synch-lock-transformer
	(syntax-rules ()
    ;
		((_ (?mtx (?lock-arg0 ...)) ?body ...)
		  (let ((mtx ?mtx) (ok? #f))
				(mutex-lock! mtx ?lock-arg0 ...)
				(call-with-values
					(lambda () (let ((res (begin ?body ...))) (set! ok? #t) res))
					(lambda ret
						(unless ok? (mutex-unlock! mtx))
						(apply values ret))) ) )
    ;
		((_ ?mtx ?body ...)
		  (%synch-lock (?mtx ()) ?body ...) ) ) )

(define-syntax %synch-lock %synch-lock-transformer)

(define-for-syntax %synch-unlock-transformer
	(syntax-rules ()
    ;
		((_ (?mtx (?unlock-arg0 ...)) ?body ...)
      (let ((mtx ?mtx))
        (unless (thread? (mutex-state mtx))
          (warning '%synch-unlock "mutex is not locked - locking")
          (mutex-lock! mtx))
        (call-with-values
          (lambda () ?body ...)
          (lambda ret
            (mutex-unlock! mtx ?unlock-arg0 ...)
            (apply values ret)) ) ) )
    ;
		((_ ?mtx ?body ...)
      (%synch-unlock (?mtx ()) ?body ...) ) ) )

(define-syntax %synch-unlock %synch-unlock-transformer)

;;

(define-for-syntax %object-synch-cut-with-transformer
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (##sys#check-syntax '%object-synch-cut-with frm '(_ _ . _))
      ;
      (let (
        (_%synch-with (rnm '%synch-with))
        (_>< (rnm '><))
        (var (rnm (gensym)))
        (mtx (cadr frm)) )
        ;
        (let body-loop ((unparsed (cddr frm)) (parsed '()))
          (if (null? unparsed)
            ;
            `(,_%synch-with ,mtx ,var ,@(reverse parsed))
            ;
            (let (
              (expr (car unparsed))
              (next (cdr unparsed)) )
              ;
              (let expr-loop ((rest expr) (parsed-expr '()))
                (cond
                  ;
                  ((null? rest)
                    (body-loop next (cons (reverse parsed-expr) parsed)))
                  ;
                  ((pair? rest)
                    (let ((arg (car rest))
                          (next (cdr rest)))
                      (if (cmp _>< arg)
                          (expr-loop next (cons var parsed-expr))
                          (expr-loop next (cons arg parsed-expr)) ) ))
                  ;
                  ((cmp _>< rest)
                    (body-loop next (cons var parsed)))
                  ;
                  (else
                    (body-loop next (cons rest parsed))) ) ) ) ) ) ) ) ) )

(define-syntax %object-synch-cut-with %object-synch-cut-with-transformer)

;;

(define-syntax %record-synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%record-synch frm '(_ _ symbol . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_%synch (rnm '%synch)) )
        (let (
          (?rec (cadr frm))
          (?sym (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_%synch (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax %record-synch-lock
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%record-synch-lock frm '(_ _ symbol . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_%synch-lock (rnm '%synch-lock)) )
        (let (
          (?rec (cadr frm))
          (?sym (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_%synch-lock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax %record-synch-unlock
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%record-synch-unlock frm '(_ _ symbol . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_%synch-unlock (rnm '%synch-unlock)) )
        (let (
          (?rec (cadr frm))
          (?sym (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_%synch-unlock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

;;; Synch Object

;;

(define (mutex-with-object? obj)
	(and
	  (mutex? obj)
    (not (eq? (void) (mutex-specific obj))) ) )

;;

(define (make-synch-with-object obj #!optional (name '(object-synch-)))
  (let* (
    (name (if (pair? name) (gensym (car name)) name) )
    (mutex (make-mutex name) ) )
    ;
    (mutex-specific-set! mutex obj)
    mutex ) )

(define (synch-with-object? obj #!optional pred)
  (and
    (mutex-with-object? obj)
    (or
      (not pred)
      (pred (mutex-specific obj)) ) ) )

(define-check+error-type synch-with-object)

;;

(define (synchronized-procedure proc)
  (let ((mtx (make-synch-with-object proc 'synchronized-procedure)))
    (lambda args
      (synch-with mtx proc
        (apply proc args)) ) ) )

;;

;FIXME this API sucks

(define-for-syntax (synch-wrapper-name sym)
	(string->symbol (string-append (symbol->string sym) "-" "synch")) )

(define-syntax define-constructor-synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (##sys#check-syntax 'define-constructor-synch frm '(_ symbol . _))
      ;
      (let (
        (_define (rnm 'define) )
        (_apply (rnm 'apply) )
        (_args (rnm (gensym 'args)) )
        (_make-synch-with-object (rnm 'make-synch-with-object) ) )
        ;
        (let* (
          (prcnam (cadr frm) )
          (id (if (not (null? (cddr frm))) `('(,(caddr frm))) `('(,prcnam))) )
          (newnam (synch-wrapper-name prcnam) ) )
          ;
          `(,_define (,newnam . ,_args)
            (,_make-synch-with-object (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )

(define-syntax define-predicate-synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (##sys#check-syntax 'define-predicate-synch frm '(_ symbol))
      ;
      (let (
        (_define (rnm 'define))
        (_obj (rnm (gensym 'obj)))
        (_synch-with-object? (rnm 'synch-with-object?)) )
        ;
        (let* (
          (prcnam (cadr frm))
          (newnam (synch-wrapper-name prcnam)) )
          ;
          `(,_define (,newnam ,_obj)
            (,_synch-with-object? ,_obj ,prcnam)) ) ) ) ) )

;operand must be the 1st argument
(define-syntax define-operation-synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (##sys#check-syntax 'define-operation-synch frm '(_ symbol))
      ;
      (let ((_define (rnm 'define))
            (_apply (rnm 'apply))
            (_let (rnm 'let))
            (_car (rnm 'car))
            (_cdr (rnm 'cdr))
            (_if (rnm 'if))
            (_pair? (rnm 'pair?))
            (_synch-with (rnm 'synch-with))
            (_check-synch-with-object (rnm 'check-synch-with-object))
            (_mutex-specific (rnm 'mutex-specific))
            (_mtx+obj (rnm (gensym 'mtx+obj)))
            (_args (rnm (gensym 'args)))
            (_obj (rnm (gensym 'obj)))
            (_mtx (rnm (gensym 'mtx))) )
        (let* ((prcnam  (cadr frm))
               (newnam (synch-wrapper-name prcnam)) )
          `(,_define (,newnam ,_mtx+obj . ,_args)
             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
               (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )

;operand must be the 1st argument
(define-syntax define-operation-%synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (define (%synch-wrapper-name sym)
        (string->symbol (string-append (symbol->string sym) "-" "%synch")) )
      ;
      (##sys#check-syntax 'define-operation-%synch frm '(_ symbol))
      (let ((_define (rnm 'define))
            (_apply (rnm 'apply))
            (_let (rnm 'let))
            (_car (rnm 'car))
            (_cdr (rnm 'cdr))
            (_if (rnm 'if))
            (_pair? (rnm 'pair?))
            (_%synch-with (rnm '%synch-with))
            (_check-synch-with-object (rnm 'check-synch-with-object))
            (_mtx+obj (rnm (gensym 'mtx+obj)))
            (_args (rnm (gensym 'args)))
            (_obj (rnm (gensym 'obj)))
            (_mtx (rnm (gensym 'mtx))) )
        (let* (
          (prcnam (cadr frm))
          (newnam (%synch-wrapper-name prcnam)) )
          ;
          `(,_define (,newnam ,_mtx+obj . ,_args)
             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
               (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
							 (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )

;; ;DEPRECATED

(define-syntax call/synch call-synch-transformer)
(define-syntax call-with/synch call-synch-with-transformer)
(define-syntax apply/synch apply-synch-transformer)
(define-syntax apply-with/synch apply-synch-with-transformer)
(define-syntax let/synch let-synch-with-transformer)

(define-syntax set!/synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'set!/synch frm '(_ pair . _))
      (let ((_synch-with (rnm 'synch-with))
            (_mutex-specific (rnm 'mutex-specific))
            (_mutex-specific-set! (rnm 'mutex-specific-set!))
            (_begin (rnm 'begin)))
        (let (
          (?bnd (cadr frm))
          (?body (cddr frm)) )
          (let (
            (?var (car ?bnd))
            (?mtx (cadr ?bnd)) )
            ;
            `(,_synch-with ,?mtx ,?var
               (,_mutex-specific-set! ,?mtx (,_begin ,@?body))
               (,_mutex-specific ,?mtx) ) ) ) ) ) ) )

(define-syntax synch/lock synch-lock-transformer)
(define-syntax synch/unlock synch-unlock-transformer)
(define-syntax object/synch object-synch-cut-with-transformer)

(define-syntax record/synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'record/synch frm '(_ symbol _ . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_synch (rnm 'synch)) )
        (let (
          (?sym (cadr frm))
          (?rec (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_synch (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax record-synch/lock
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'record-synch/lock frm '(_ symbol _ . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_synch/lock (rnm 'synch/lock)) )
        (let (
          (?sym (cadr frm))
          (?rec (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_synch/lock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax record-synch/unlock
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'record-synch/unlock frm '(_ symbol _ . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_synch/unlock (rnm 'synch/unlock)) )
        (let (
          (?sym (cadr frm))
          (?rec (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_synch/unlock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax %call/synch %call-synch-transformer)
(define-syntax %call-with/synch %call-synch-with-transformer)
(define-syntax %apply/synch %apply-synch-transformer)
(define-syntax %apply-with/synch %apply-synch-with-transformer)
(define-syntax %let/synch %let-synch-with-transformer)

(define-syntax %set!/synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%set!/synch frm '(_ pair . _))
      (let ((_%synch-with (rnm '%synch-with))
            (_mutex-specific (rnm 'mutex-specific))
            (_mutex-specific-set! (rnm 'mutex-specific-set!))
            (_let (rnm 'let))
            (_begin (rnm 'begin))
            (mtxvar (rnm (gensym))))
        (let ((?bnd (cadr frm))
              (?body (cddr frm)))
          (let ((?var (car ?bnd))
                (?mtx (cadr ?bnd)))
            `(,_let ((,mtxvar ,?mtx))
               (,_%synch-with ,mtxvar ,?var
                 (,_mutex-specific-set! ,mtxvar (,_begin ,@?body))
                 (,_mutex-specific ,mtxvar) ) ) ) ) ) ) ) )

(define-syntax %synch/lock %synch-lock-transformer)
(define-syntax %synch/unlock %synch-unlock-transformer)
(define-syntax %object/synch %object-synch-cut-with-transformer)

(define-syntax %record/synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%record/synch frm '(_ symbol _ . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_%synch (rnm '%synch)))
        (let (
          (?sym (cadr frm))
          (?rec (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_%synch (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax %record-synch/lock
  (er-macro-transformer
  (lambda (frm rnm cmp)
    (##sys#check-syntax '%record-synch/lock frm '(_ symbol _ . _))
    (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_%synch/lock (rnm '%synch/lock)) )
      (let (
        (?sym (cadr frm))
        (?rec (caddr frm))
        (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_%synch/lock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define-syntax %record-synch/unlock
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '%record-synch/unlock frm '(_ symbol _ . _))
      (let (
        (_let (rnm 'let))
        (_recvar (rnm 'recvar))
        (_%synch/unlock (rnm '%synch/unlock)) )
        (let (
          (?sym (cadr frm))
          (?rec (caddr frm))
          (?body (cdddr frm)) )
          `(,_let ((,_recvar ,?rec))
            (,_%synch/unlock (,(record-mutex-name ?sym) ,_recvar) ,@?body) ) ) ) ) ) )

(define make-object/synch make-synch-with-object)
(define object?/synch synch-with-object?)

;

(define-for-syntax (synch/wrapper-name sym)
	(string->symbol (string-append (symbol->string sym) "/" "synch")) )

(define-syntax define-constructor/synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'define-constructor/synch frm '(_ symbol . _))
      (let ((_define (rnm 'define))
            (_apply (rnm 'apply))
            (_args (rnm (gensym 'args)))
            (_make-object/synch (rnm 'make-object/synch)) )
        (let* ((prcnam (cadr frm))
               (id (if (not (null? (cddr frm))) `('(,(caddr frm))) '()))
               (newnam (synch/wrapper-name prcnam)) )
          `(,_define (,newnam . ,_args)
             (,_make-object/synch (,_apply ,prcnam ,_args) ,@id)) ) ) ) ) )

(define-syntax define-predicate/synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'define-predicate/synch frm '(_ symbol))
      (let ((_define (rnm 'define))
            (_obj (rnm (gensym 'obj)))
            (_object?/synch (rnm 'object?/synch)) )
        (let* ((prcnam (cadr frm))
               (newnam (synch/wrapper-name prcnam)) )
          `(,_define (,newnam ,_obj) (,_object?/synch ,_obj ,prcnam)) ) ) ) ) )

;operand must be the 1st argument
(define-syntax define-operation/synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'define-operation/synch frm '(_ symbol))
      (let ((_define (rnm 'define))
            (_apply (rnm 'apply))
            (_let (rnm 'let))
            (_car (rnm 'car))
            (_cdr (rnm 'cdr))
            (_if (rnm 'if))
            (_pair? (rnm 'pair?))
            (_synch-with (rnm 'synch-with))
            (_check-synch-with-object (rnm 'check-synch-with-object))
            (_mutex-specific (rnm 'mutex-specific))
            (_mtx+obj (rnm (gensym 'mtx+obj)))
            (_args (rnm (gensym 'args)))
            (_obj (rnm (gensym 'obj)))
            (_mtx (rnm (gensym 'mtx))) )
        (let* ((prcnam  (cadr frm))
               (newnam (synch/wrapper-name prcnam)) )
          `(,_define (,newnam ,_mtx+obj . ,_args)
             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
               (,_check-synch-with-object ',newnam ,_mtx 'object/synch)
               (,_synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )

;operand must be the 1st argument
(define-syntax define-operation/%synch
  (er-macro-transformer
    (lambda (frm rnm cmp)
      ;
      (define (%synch/wrapper-name sym)
        (string->symbol (string-append (symbol->string sym) "/" "%synch")) )
      ;
      (##sys#check-syntax 'define-operation/%synch frm '(_ symbol))
      (let ((_define (rnm 'define))
            (_apply (rnm 'apply))
            (_let (rnm 'let))
            (_car (rnm 'car))
            (_cdr (rnm 'cdr))
            (_if (rnm 'if))
            (_pair? (rnm 'pair?))
            (_%synch-with (rnm '%synch-with))
            (_check-synch-with-object (rnm 'check-synch-with-object))
            (_mtx+obj (rnm (gensym 'mtx+obj)))
            (_args (rnm (gensym 'args)))
            (_obj (rnm (gensym 'obj)))
            (_mtx (rnm (gensym 'mtx))) )
        (let* ((prcnam (cadr frm))
               (newnam (%synch/wrapper-name prcnam)) )
          `(,_define (,newnam ,_mtx+obj . ,_args)
             (,_let ((,_mtx (,_if (,_pair? ,_mtx+obj) (,_car ,_mtx+obj) ,_mtx+obj)))
               (,_check-synch-with-object ',newnam ,_mtx 'object/synch)
							 (,_%synch-with ,_mtx+obj ,_obj (,_apply ,prcnam ,_obj ,_args)) ) ) ) ) ) ) )

) ;module synch