Changed lock-region to use proc objects instead of pids, and fixed a
bug in UNLOCK-REGION.
This commit is contained in:
parent
ea9745ee2f
commit
454808a9cd
|
@ -51,7 +51,7 @@
|
||||||
start ; integer
|
start ; integer
|
||||||
len ; Positive integer or #f
|
len ; Positive integer or #f
|
||||||
whence ; seek/set, seek/delta, or seek/end.
|
whence ; seek/set, seek/delta, or seek/end.
|
||||||
pid ; Process holding lock
|
proc ; Process holding lock
|
||||||
)
|
)
|
||||||
|
|
||||||
(define lock-region? %lock-region?)
|
(define lock-region? %lock-region?)
|
||||||
|
@ -59,16 +59,24 @@
|
||||||
(define lock-region:whence %lock-region:whence)
|
(define lock-region:whence %lock-region:whence)
|
||||||
(define lock-region:start %lock-region:start)
|
(define lock-region:start %lock-region:start)
|
||||||
(define lock-region:len %lock-region:len)
|
(define lock-region:len %lock-region:len)
|
||||||
(define lock-region:pid %lock-region:pid)
|
(define lock-region:proc %lock-region:proc)
|
||||||
(define set-lock-region:exclusive? set-%lock-region:exclusive?)
|
(define set-lock-region:exclusive? set-%lock-region:exclusive?)
|
||||||
(define set-lock-region:whence set-%lock-region:whence)
|
(define set-lock-region:whence set-%lock-region:whence)
|
||||||
(define set-lock-region:start set-%lock-region:start)
|
(define set-lock-region:start set-%lock-region:start)
|
||||||
(define set-lock-region:len set-%lock-region:len)
|
(define set-lock-region:len set-%lock-region:len)
|
||||||
(define set-lock-region:pid set-%lock-region:pid)
|
(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)
|
(define (make-lock-region exclusive? start len . maybe-whence)
|
||||||
(let ((whence (:optional maybe-whence seek/set)))
|
(let ((whence (:optional maybe-whence seek/set)))
|
||||||
(make-%lock-region exclusive? start len whence 0)))
|
(make-%lock-region exclusive? start len whence #f)))
|
||||||
|
|
||||||
|
|
||||||
;;; Internal middleman routine
|
;;; Internal middleman routine
|
||||||
|
@ -95,26 +103,31 @@
|
||||||
(define (lock-region/no-block fdes lock)
|
(define (lock-region/no-block fdes lock)
|
||||||
(cond ((call-lock-region %set-lock fcntl/set-record-lock-noblock fdes lock)
|
(cond ((call-lock-region %set-lock fcntl/set-record-lock-noblock fdes lock)
|
||||||
=> (lambda (errno)
|
=> (lambda (errno)
|
||||||
(cond ((= errno errno/again) #f)
|
(cond ((or (= errno errno/again) (= errno errno/acces)) #f)
|
||||||
((= errno errno/intr) (lock-region/no-block fdes lock))
|
((= errno errno/intr) (lock-region/no-block fdes lock))
|
||||||
(else (errno-error errno lock-region/no-block fdes lock)))))
|
(else (errno-error errno lock-region/no-block fdes lock)))))
|
||||||
(else #t)))
|
(else #t)))
|
||||||
|
|
||||||
|
|
||||||
;;; Return first lock overlapping LOCK; if none, return #f.
|
;;; Return first lock that conflicts w/LOCK; if none, return #f.
|
||||||
|
|
||||||
(define (get-lock-region fdes lock)
|
(define (get-lock-region fdes lock)
|
||||||
(receive (err type whence start len pid)
|
(receive (err type whence start len pid)
|
||||||
(call-lock-region %get-lock fcntl/get-record-lock fdes lock)
|
(call-lock-region %get-lock fcntl/get-record-lock fdes lock)
|
||||||
(cond ((not err)
|
(cond ((not err)
|
||||||
(and (not (= type lock/release))
|
(and (not (= type lock/release))
|
||||||
(make-%lock-region (= type lock/write) start len whence pid)))
|
(make-%lock-region (= type lock/write) start len whence
|
||||||
|
(pid->proc pid 'create))))
|
||||||
((= err errno/intr) (get-lock-region fdes lock))
|
((= err errno/intr) (get-lock-region fdes lock))
|
||||||
(else (errno-error err get-lock-region fdes lock)))))
|
(else (errno-error err get-lock-region fdes lock)))))
|
||||||
|
|
||||||
|
|
||||||
(define-errno-syscall (unlock-region fdes lock)
|
(define-errno-syscall (unlock-region fdes lock)
|
||||||
(lambda (fdes lock) (call-lock-region %set-lock lock/release 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
|
;;; Locks with dynamic extent -- with and without sugar
|
||||||
|
|
Loading…
Reference in New Issue