scsh-0.5/scsh/flock.scm

;;; Scsh
;;; Posix advisory record-locking for file descriptors.
;;; These procs may only be applied to integer file descriptors; 
;;; they may not be applied to ports.
;;; Copyright (c) 1995 by David Albertz and Olin Shivers. See file COPYING.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; C syscall interface
;;;;;;;;;;;;;;;;;;;;;;;

(foreign-source
  "#include <sys/types.h>"
  "#include <unistd.h>"
  "#include <errno.h>"
  "#include <fcntl.h>"
  ""
  "/* Make sure foreign-function stubs interface to the C funs correctly: */"
  "#include \"flock1.h\""
  ""
  "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  "" "")

(define-foreign %set-lock (set_lock (integer fd)
				    (integer cmd)
				    (integer type)
				    (integer whence)
				    (integer start)
				    (integer len))
  (to-scheme integer errno_or_false))

(define-foreign %get-lock (get_lock (integer fd)
				    (integer cmd)
				    (integer type)
				    (integer whence)
				    (integer start)
				    (integer len))
  (to-scheme integer errno_or_false)
  integer	; lock type
  integer	; whence
  integer	; start
  integer	; len
  integer)	; pid
				       

;;; The LOCK record type
;;;;;;;;;;;;;;;;;;;;;;;;

(define-record %lock-region
  exclusive?
  start			; integer
  len			; Positive integer or #f
  whence		; seek/set, seek/delta, or seek/end.
  proc      		; Process holding lock
  )

(define lock-region?               %lock-region?)
(define lock-region:exclusive?     %lock-region:exclusive?)
(define lock-region:whence         %lock-region:whence)
(define lock-region:start          %lock-region:start)
(define lock-region:len            %lock-region:len)
(define lock-region:proc           %lock-region:proc)
(define set-lock-region:exclusive? set-%lock-region:exclusive?)
(define set-lock-region:whence     set-%lock-region:whence)
(define set-lock-region:start      set-%lock-region:start)
(define set-lock-region:len        set-%lock-region:len)
(define set-lock-region:proc       set-%lock-region:proc)

;;; Backwards compatibility for one or two releases.
(define lock-region:pid
  (deprecated-proc (lambda (lr)
		     (cond ((lock-region:proc lr) => proc:pid)
			   (else #f)))
		   'lock-region:pid
		   "Use lock-region:proc instead."))

(define (make-lock-region exclusive? start len . maybe-whence)
  (let ((whence (:optional maybe-whence seek/set)))
    (make-%lock-region exclusive? start len whence #f)))


;;; Internal middleman routine
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (call-lock-region proc cmd fdes lock)
  (check-arg lock-region? lock proc)
  (let ((lock-type (if (lock-region:exclusive? lock) lock/write lock/read)))
    (proc fdes cmd lock-type
	  (lock-region:whence lock)
	  (lock-region:start lock)
	  (lock-region:len lock))))


;;; The main routines
;;;;;;;;;;;;;;;;;;;;;

(define-errno-syscall (lock-region fdes lock)
  (lambda (fdes lock)
    (call-lock-region %set-lock fcntl/set-record-lock fdes lock)))

;;; Return true/false indicating success/failure.

(define (lock-region/no-block fdes lock)
  (cond ((call-lock-region %set-lock fcntl/set-record-lock-no-block fdes lock) 
         => (lambda (errno)
	      (cond ((or (= errno errno/again) (= errno errno/acces)) #f)
		    ((= errno errno/intr) (lock-region/no-block fdes lock))
		    (else (errno-error errno lock-region/no-block fdes lock)))))
	(else #t)))


;;; Return first lock that conflicts w/LOCK; if none, return #f.

(define (get-lock-region fdes lock)
  (receive (err type whence start len pid)
           (call-lock-region %get-lock fcntl/get-record-lock fdes lock)
    (cond ((not err)
	   (and (not (= type lock/release))
		(make-%lock-region (= type lock/write) start len whence
				   (pid->proc pid 'create))))
	  ((= err errno/intr) (get-lock-region fdes lock))
	  (else (errno-error err get-lock-region fdes lock)))))


(define-errno-syscall (unlock-region fdes lock)
  (lambda (fdes lock)
    (%set-lock fdes fcntl/set-record-lock lock/release
	       (lock-region:whence lock)
	       (lock-region:start lock)
	       (lock-region:len lock))))


;;; Locks with dynamic extent -- with and without sugar
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Throwing out frees the lock. Don't throw back in.

(define (with-region-lock* fd lock thunk)
  (let ((returned? #f))
    (dynamic-wind (lambda ()
		    (if returned?
			(error "Can't throw back into a with-region-lock" lock)
			(lock-region fd lock)))
		  thunk
		  (lambda ()
		    (unlock-region fd lock)
		    (set! returned? #t)))))

(define-syntax with-region-lock
  (syntax-rules ()
    ((with-region-lock fd lock body ...)
     (with-region-lock* fd lock (lambda () body ...)))))