;;;; synch-closed-incl.scm
;;;; Kon Lovett, Dec '18

;;; Protected

;;

(define-for-syntax (suffix-symbol sym suf)
  (import-for-syntax (only (chicken base) symbol-append))
  (symbol-append sym '- suf) )

;;

(define-syntax synch-with
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax 'synch-with frm '(_ _ variable . #(_ 0)))
      (let (
        (_let (rnm 'let))
        (_mutex-specific (rnm 'mutex-specific))
        (_synch (rnm 'synch))
        (_mtx (rnm (gensym 'mtx)))
        (_current-synch-abandon? (rnm 'current-synch-abandon?)) )
        (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 ((,_mtx ,?mtx))
                (,_let ((,?var (,_mutex-specific ,_mtx)))
                  (,_synch (,_mtx ,?lock-args ,?unlock-args) ,@?body) ) ) ) ) ) ) ) ) )

(define-syntax call-synch
  (syntax-rules ()
    ;
    ((call-synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
      (synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) (?proc ?arg0 ...)) )
    ;
    ((call-synch (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
      (call-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    ;
    ((call-synch ?mtx ?proc ?arg0 ...)
      (call-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )

(define-syntax call-synch-with
  (syntax-rules ()
    ;
    ((call-synch-with (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
      (synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) (?proc (mutex-specific ?mtx) ?arg0 ...)) )
    ;
    ((call-synch-with (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
      (call-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    ;
    ((call-synch-with ?mtx ?proc ?arg0 ...)
      (call-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )

(define-syntax apply-synch
  (syntax-rules ()
    ;
    ((apply-synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
      (synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) (apply ?proc ?arg0 ...)) )
    ;
    ((apply-synch (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
      (apply-synch (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    ;
    ((apply-synch ?mtx ?proc ?arg0 ...)
      (apply-synch (?mtx () ()) ?proc ?arg0 ...) ) ) )

(define-syntax apply-synch-with
  (syntax-rules ()
    ;
    ((apply-synch-with (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) ?proc ?arg0 ...)
      (synch (?mtx (?lock-arg0 ...) (?unlock-arg0 ...)) (apply ?proc (mutex-specific ?mtx) ?arg0 ...)) )
    ;
    ((apply-synch-with (?mtx (?lock-arg0 ...)) ?proc ?arg0 ...)
      (apply-synch-with (?mtx (?lock-arg0 ...) ()) ?proc ?arg0 ...) )
    ;
    ((apply-synch-with ?mtx ?proc ?arg0 ...)
      (apply-synch-with (?mtx () ()) ?proc ?arg0 ...) ) ) )

(define-syntax let-synch-with
  (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)
                (begin ?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 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-syntax object-synch-cut-with
  (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)
            ;code walked
            `(,_synch-with ,mtx ,var ,@(reverse parsed))
            ;walk code
            (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-for-syntax (record-mutex-name sym) (suffix-symbol sym 'mutex))

;;

(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 (synchronized-procedure proc)
  (let ((mtx (make-synch-with-object proc '(synchproc))))
    (lambda args (synch-with mtx proc (apply proc args))) ) )

;;

;FIXME this API sucks

(define-for-syntax (synch-wrapper-name sym) (suffix-symbol 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-w-obj (rnm (gensym 'mtx-w-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-w-obj . ,_args)
            (,_let ((,_mtx (,_if (,_pair? ,_mtx-w-obj) (,_car ,_mtx-w-obj) ,_mtx-w-obj)))
              (,_check-synch-with-object ',newnam ,_mtx 'object-synch)
              (,_synch-with ,_mtx-w-obj ,_obj (,_apply ,prcnam ,_obj ,_args))) ) ) ) ) ) )