(define (make-lock-file-name file-name) (string-append file-name ".lock"))
(define (sleep time)
  (letrec*
    ((end-time (+ (current-second) time))
     (looper (lambda () (when (> (current-second) end-time) (looper)))))
    (looper)))

(define (obtain-dot-lock file-name . args)
  (let* ((interval
           (* (if (>= (length args) 1)
                (let ((interval (list-ref args 0)))
                  (when (not (integer? interval))
                    (error (string-append "obtain-dot-lock error: interval must"
                                          " be integer"
                                          interval)))
                  interval)
                1000)))
         (retry-number
           (if (>= (length args) 2)
             (let ((retry-number (list-ref args 1)))
               (when (and (not (integer? retry-number))
                          (not (equal? retry-number #f)))
                 (error (string-append "obtain-dot-lock error: retry-number must"
                                       " be integer or #f")
                        retry-number))
               retry-number)
             #f))
         (stale-time-seconds
           (if (>= (length args) 3)
             (let ((stale-time (list-ref args 2)))
               (when (and (not (integer? stale-time))
                          (not (equal? stale-time #f)))
                 (error (string-append "obtain-dot-lock error: stale time must"
                                       " be integer or #f")
                        stale-time))
               stale-time)
             300))
         (stale-time (if stale-time-seconds
                       (+ (current-second) stale-time-seconds)
                       #f))
         (lock-file-name (make-lock-file-name file-name))
         (lock-time (lambda ()
                      (if (file-exists? lock-file-name)
                        (guard (condition (else 0))
                          (string->number
                            (with-input-from-file
                              lock-file-name
                              (lambda () (read)))))
                        0)))
         (write-lock-file
           (lambda ()
             (with-output-to-file
               lock-file-name
               (lambda ()
                 (write (current-second)))))))
    (letrec
      ((locker
         (lambda (try-count)
           (cond ((not (file-exists? lock-file-name))
                  (guard (condition (else (locker (+ try-count 1))))
                    (write-lock-file)
                    #t))
                 ((and retry-number (> try-count retry-number)) #f)
                 ((and stale-time (> (lock-time) stale-time))
                  (break-dot-lock file-name)
                  (write-lock-file)
                  (guard (condition (else #f))
                    (write-lock-file)
                    'broken))
                 ((or (not retry-number)
                      (<= try-count retry-number))
                  (sleep interval)
                  (locker (+ try-count)))))))
      (locker 0))))

(define (break-dot-lock file-name)
  (let ((lock-file-name (make-lock-file-name file-name)))
    (when (file-exists? lock-file-name) (delete-file lock-file-name))))

(define (release-dot-lock file-name)
  (let ((lock-file-name (make-lock-file-name file-name)))
    (guard (condition (else #f))
      (when (file-exists? lock-file-name) (delete-file lock-file-name))
      #t)))

(define-syntax with-dot-lock*
  (syntax-rules ()
    ((_ file-name thunk)
     (letrec* ((locked? (obtain-dot-lock file-name))
               (unlock (lambda ()
                         (when locked? (break-dot-lock file-name))
                         (set! locked? #f))))
       (when locked?
         (dynamic-wind (lambda () #t)
                       (lambda () (guard (condition (else (unlock))) (thunk)))
                       unlock))
       (unlock)))))

(define-syntax with-dot-lock
  (syntax-rules ()
    ((_ file-name body ...)
     (with-dot-lock* file-name (lambda () body ...)))))