(define (make-lock-file-name file-name)
  (string-append file-name ".lock"))

(define (release-dot-lock file-name)
  (with-errno-handler
   ((errno packet)
    (else #f))
   (delete-file (make-lock-file-name file-name))
   #t))

(define (maybe-obtain-dot-lock file-name)
  (let ((temp-name (create-temp-file file-name)))
    (with-errno-handler
     ((errno packet)
      ((errno/exist)
       (delete-file temp-name)
       #f))
     (create-hard-link temp-name (make-lock-file-name file-name))
     (delete-file temp-name)
     #t)))

(define random
  (let ((crank (make-random (modulo (time) (- (expt 2 27) 1)))))
    (lambda (limit)
      (quotient (* (modulo (crank) 314159265)
		   limit)
		314159265))))
			   
;; STALE-TIME is the minimum age of a lock to be broken
;; if #f, don't break the lock

(define (obtain-dot-lock file-name retry-interval retry-number stale-time)
  (let ((lock-file-name (make-lock-file-name file-name)))
    (let loop ((retry-number retry-number))
      (cond
       ((maybe-obtain-dot-lock file-name)
	#t)
       ((and stale-time
	     (with-errno-handler
	      ((errno packet)
	       (else #f))
	      (> (time)
		 (+ (file-last-status-change (make-lock-file-name file-name))
		    stale-time))))
	(with-errno-handler
	 ((errno packet)
	  ((errno/noent) 'dont-care))
	 (delete-file lock-file-name))
	(loop retry-number))
       (else
	(sleep (+ (quotient (* retry-interval 3) 4)
		  (random (quotient retry-interval 2))))
	(cond ((not retry-number)
	       (loop retry-number))
	      ((> retry-number 0)
	       (loop (- retry-number 1)))
	      (else #f)))))))

(define (with-dot-lock* file-name thunk)
  (dynamic-wind
   (lambda () 
     (obtain-dot-lock file-name))
   (lambda ()
     (call-with-values thunk
		       (lambda a
			 (release-dot-lock file-name)
			 (apply values a))))
   (lambda ()
     (release-dot-lock file-name))))

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