(define (make-lock-file-name file-name) (string-append file-name ".lock"))
(define (sleep time)
  (letrec*
    ((end-time
       (let ((end-time (current-time))
             (seconds (quotient time 1000))
             (nanoseconds (* (remainder time 1000) 1000000)))
         (set-time-second! end-time (+ (time-second end-time) seconds))
         (set-time-nanosecond! end-time (+ (time-nanosecond end-time) nanoseconds))
         end-time))
     (looper (lambda () (when (time<? (current-time) 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
             (add-duration (current-time time-utc)
                           (make-time time-duration 0 stale-time-seconds))
             #f))
         (lock-file-name (make-lock-file-name file-name))
         (lock-time (lambda ()
                      (guard (condition (else #f))
                        (file-info:ctime (file-info lock-file-name))))))
    (letrec
      ((locker
         (lambda (try-count)
           (cond ((not (file-exists? lock-file-name))
                  (guard (condition (else (locker (+ try-count 1))))
                    (create-hard-link file-name lock-file-name)
                    #t))
                 ((and retry-number (> try-count retry-number)) #f)
                 ((and stale-time (time>? lock-time stale-time))
                  (break-dot-lock file-name)
                  (create-hard-link file-name lock-file-name)
                  (guard (condition (else #f))
                    (create-hard-link file-name lock-file-name)
                    '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 ...)))))