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

(define (create-temp filename)
 (create-temp-file filename))

(define (maybe-obtain-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-lock filename)
  (with-errno-handler
   ((errno packet)
    (else #f))
   (delete-file (make-lockname filename))
   #t))

(define (obtain-lock filename)
  (let ((tempname (create-temp filename)))
    (delete-file tempname)
    (let loop ()
      (or (maybe-obtain-lock tempname filename)
	  (begin (sleep 1000)
		 (loop))))))
	
(define-syntax with-lock
  (syntax-rules 
   ()
   ((with-lock filename body ...)
    (with-handler
     (lambda (condition more)
       (release-lock filename)
       (more))
     (lambda ()
       (obtain-lock filename)
       (call-with-values (lambda ()
			   body ...)
			 (lambda a
			   (release-lock filename)
			   (apply values a))))))))