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 | ||||
|   len			; Positive integer or #f | ||||
|   whence		; seek/set, seek/delta, or seek/end. | ||||
|   pid      		; Process holding lock | ||||
|   proc      		; Process holding lock | ||||
|   ) | ||||
| 
 | ||||
| (define lock-region?               %lock-region?) | ||||
|  | @ -59,16 +59,24 @@ | |||
| (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 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: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) | ||||
|   (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 | ||||
|  | @ -95,26 +103,31 @@ | |||
| (define (lock-region/no-block fdes lock) | ||||
|   (cond ((call-lock-region %set-lock fcntl/set-record-lock-noblock fdes lock)  | ||||
|          => (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)) | ||||
| 		    (else (errno-error errno lock-region/no-block fdes lock))))) | ||||
| 	(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) | ||||
|   (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))) | ||||
| 		(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) (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 | ||||
|  |  | |||
		Loading…
	
		Reference in New Issue
	
	 shivers
						shivers