(define (make-lockname filename)
  (string-append filename ".lock"))

(define (maybe-obtain-dot-lock tempname filename)
 (let ((port (open-file tempname (bitwise-ior open/write 
					      open/create 
					      open/exclusive))))
   (close port)
   (with-errno-handler
    ((errno packet)
     ((errno/exist)
      (delete-file tempname)
      #f))
    (create-hard-link tempname (make-lockname filename))
    (delete-file tempname)
    #t)))

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

(define (obtain-dot-lock filename . args)
  (let-optionals args ((retry-interval 1000) (retry-number #f))
     (let ((tempname (create-temp-file filename)))
       (delete-file tempname)
       (let loop ((retry-number retry-number))
	 (or (maybe-obtain-dot-lock tempname filename)
	     (begin (sleep retry-interval)
		    (cond ((not retry-number)
			   (loop retry-number))
			  ((> retry-number 0)
			   (loop (- retry-number 1)))
			  (else #f))))))))

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

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