scsh-0.5/scsh/flock.scm

139 lines
4.1 KiB
Scheme

;;; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; C syscall interface
;;;;;;;;;;;;;;;;;;;;;;;
(foreign-source
"#include <sys/types.h>"
"#include <unistd.h>"
"#include <fcntl.h>"
""
"extern int errno;"
""
"#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.
pid ; 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:pid %lock-region:pid)
(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:pid set-%lock-region:pid)
(define (make-lock-region exclusive? start len . maybe-whence)
(let ((whence (optional-arg maybe-whence seek/set)))
(make-%lock-region exclusive? start len whence 0)))
;;; 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 (lock-region fdes lock)
(let lp ()
(cond ((call-lock-region %set-lock fcntl/set-record-lock fdes lock) =>
(lambda (errno)
(if (= errno errno/intr) (lp) ; Retry on interrupt.
(errno-error errno lock-region 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-noblock fdes lock)
=> (lambda (errno)
(if (= errno errno/again) #f
(errno-error errno lock-region/no-block fdes lock))))
(else #t)))
;;; Return first lock overlapping 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)
(if err (errno-error err get-lock-region fdes lock)
(and (not (= type lock/release))
(make-%lock-region (= type lock/write) start len whence pid)))))
(define (unlock-region fdes lock)
(cond ((call-lock-region %set-lock lock/release fdes lock) =>
(lambda (errno) (errno-error errno unlock-region fdes 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 ...)))))