From bb5e96ee127a7a63c082008de60a51d78a9269bb Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Sat, 6 Mar 1999 03:42:40 +0000
Subject: [PATCH] Add support for non-recursive error-check locks for
 compatibility with the pthread implementation. Add new structures
 recursive-lock and error-check-lock. Make-lock now accepts a :kind key which
 defaults to :recursive for backwards compatibility. Rework with-lock-held to
 handle the error-check locks, and add a new key :wait - when :wait is Nil and
 the lock is not free the body is not executed.

---
 code/multi-proc.lisp | 76 ++++++++++++++++++++++++++++++--------------
 1 file changed, 52 insertions(+), 24 deletions(-)

diff --git a/code/multi-proc.lisp b/code/multi-proc.lisp
index 2151c71a6..38634dc39 100644
--- a/code/multi-proc.lisp
+++ b/code/multi-proc.lisp
@@ -5,7 +5,7 @@
 ;;; the Public domain, and is provided 'as is'.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.32 1999/01/11 19:05:36 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/multi-proc.lisp,v 1.33 1999/03/06 03:42:40 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1720,15 +1720,31 @@
 
 ;;;
 (defstruct (lock
-	     (:constructor make-lock (&optional name))
+	     (:constructor nil)
 	     (:print-function %print-lock))
   (name nil :type (or null simple-base-string))
   (process nil :type (or null process)))
 
+(defstruct (recursive-lock
+	     (:include lock)
+	     (:constructor make-recursive-lock (&optional name))))
+
+(defstruct (error-check-lock
+	     (:include lock)
+	     (:constructor make-error-check-lock (&optional name))))
+
+(defun make-lock (&optional name &key (kind :recursive))
+  (ecase kind
+    (:recursive (make-recursive-lock name))
+    (:error-check (make-error-check-lock name))))
+
 (defun %print-lock (lock stream depth)
   (declare (type lock lock) (stream stream) (ignore depth))
   (print-unreadable-object (lock stream :identity t)
-    (write-string "Lock" stream)
+    (write-string (etypecase lock
+		    (recursive-lock "Recursive-lock")
+		    (error-check-lock "Error-Check-lock"))
+		  stream)
     (let ((name (lock-name lock)))
       (when name
 	(format stream " ~a" name)))
@@ -1787,35 +1803,47 @@
 
 ;;; With-Lock-Held  --  Public
 ;;;
-(defmacro with-lock-held ((lock &optional (whostate "Lock Wait") &key timeout)
+(defmacro with-lock-held ((lock &optional (whostate "Lock Wait")
+				&key (wait t) timeout)
 			  &body body)
-
   "Execute the body with the lock held. If the lock is held by another
-  process then the current process waits until the lock is released or a
-  optional timeout is reached - recursive locks are allowed. The
-  optional wait timeout is a time in seconds acceptable to
-  process-wait-with-timeout.  The results of the body are return upon
-  success and NIL is return if the timeout is reached."
+  process then the current process waits until the lock is released or
+  an optional timeout is reached. The optional wait timeout is a time in
+  seconds acceptable to process-wait-with-timeout.  The results of the
+  body are return upon success and NIL is return if the timeout is
+  reached. When the wait key is NIL and the lock is held by another
+  process then NIL is return immediately without processing the body."
   (let ((have-lock (gensym)))
     `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
       (unwind-protect
-	   ,(if timeout
-		`(when (cond (,have-lock)
-			     #+i486 ((null (kernel:%instance-set-conditional
-					    ,lock 2 nil *current-process*)))
-			     #-i486 ((seize-lock ,lock))
-			     ((null ,timeout)
-			      (lock-wait ,lock ,whostate))
-			     ((lock-wait-with-timeout
-			       ,lock ,whostate ,timeout)))
-		  ,@body)
-		`(progn
-		  (unless (or ,have-lock
+	   ,(cond ((and timeout wait)
+		   `(when (cond (,have-lock
+				 (when (error-check-lock-p ,lock)
+				   (error "Dead lock")))
+				#+i486 ((null (kernel:%instance-set-conditional
+					       ,lock 2 nil *current-process*)))
+				#-i486 ((seize-lock ,lock))
+				((null ,timeout)
+				 (lock-wait ,lock ,whostate))
+				((lock-wait-with-timeout
+				  ,lock ,whostate ,timeout)))
+		      ,@body))
+		  (wait
+		   `(progn
+		      (when (and (error-check-lock-p ,lock) ,have-lock)
+		        (error "Dead lock"))
+		      (unless (or ,have-lock
+				 #+i486 (null (kernel:%instance-set-conditional
+					       ,lock 2 nil *current-process*))
+				 #-i486 (seize-lock ,lock))
+			(lock-wait ,lock ,whostate))
+		      ,@body))
+		  (t
+		   `(when (or (and (recursive-lock-p ,lock) ,have-lock)
 			      #+i486 (null (kernel:%instance-set-conditional
 					    ,lock 2 nil *current-process*))
 			      #-i486 (seize-lock ,lock))
-		    (lock-wait ,lock ,whostate))
-		  ,@body))
+		      ,@body)))
 	(unless ,have-lock
 	  #+i486 (kernel:%instance-set-conditional
 		  ,lock 2 *current-process* nil)
-- 
GitLab