(in-package :lock)

(lisp:clines "#include \"fcntl.c\"")
(lisp:defentry %open-lock-file (lisp:string) (lisp:int "open_lock_file"))
(lisp:defentry %set-lock (lisp:int lisp:string) (lisp:int "set_lock"))
(lisp:defentry %close (lisp:int) (lisp:int "close"))

(defstruct (lock (:constructor make-lock (pathname)))
  (state '())
  (handle -1)
  pathname)

;; Keep track of lock files that need to be closed.
(defvar *locks* '())

(defun set-lock (lock type)
  (unless (plusp (lock-handle lock))
    (let* ((pathname (ensure-directories-exist (make-pathname :type "lock" :defaults (lock-pathname lock))))
	   (handle (%open-lock-file (namestring pathname))))
      (if (plusp handle)
          (progn
            (setf (lock-handle lock) handle)
            (push lock *locks*))
          (error "%OPEN-LOCK-FILE failed on ~s" (lock-pathname lock)))))
  (when (minusp (%set-lock (lock-handle lock) (copy-seq (string type))))
    (error "%SET-LOCK failed on ~s" (lock-pathname lock))))

(defun clear-locks ()
  (dolist (lock *locks*)
    (when (plusp (lock-handle lock))
      (when (minusp (%close (lock-handle lock)))
        (error "%CLOSE failed in ~s" (lock-pathname lock))))))

(defmacro with-locks ((&key) &body body)
  `(unwind-protect
       (progn ,@body)
     (clear-locks)))

(defmacro with-lock ((lock type) &body body)
  (with-unique-names (state)
    `(let ((,state (first (lock-state ,lock))))
       (unwind-protect
	    (progn
	      (unless (eq ',type ,state)
		(set-lock ,lock ',type)
		(push ',type (lock-state ,lock)))
	      ,@body)
         (unless (eq ',type ,state)
           (pop (lock-state ,lock))
           (set-lock ,lock ,state))))))