From dbd749b21895b1d2875937c5a2e54728c73079dd Mon Sep 17 00:00:00 2001
From: Gwenael Casaccio <gwenael.casaccio@gmail.com>
Date: Sat, 12 Apr 2014 11:09:21 +0200
Subject: [PATCH 2/2] Add Process>>#isSuspendedInCCall

It's not possible to make the difference between a suspended process
and a process suspended by a C-Call. It's usefull to make the difference
when the C-Call is reentrant (with GTK callbacks for instance).

2014-04-11  Gwenael Casaccio  <gwenael.casaccio@gmail.com>

	* kernel/CCallable.st: Annotate c-call methods with suspendedCall attribute,
	indirect call to the primitive used by Process>>#isSuspendedInCCall.
	* kernel/Process.st: Add isSuspendedInCCall.
	* package/kernel-tests/kernel/ProcessTests.st: Add new file.
---
 ChangeLog                                    |  6 ++++++
 kernel/CCallable.st                          | 22 ++++++++++++++++++++--
 kernel/Process.st                            | 11 +++++++++++
 packages/kernel-tests/ChangeLog              |  4 ++++
 packages/kernel-tests/kernel/ProcessTests.st | 23 +++++++++++++++++++++++
 5 files changed, 64 insertions(+), 2 deletions(-)
 create mode 100644 packages/kernel-tests/kernel/ProcessTests.st

diff --git a/ChangeLog b/ChangeLog
index 4aa2f2c..9a8f5eb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2014-04-12  Gwenael Casaccio  <gwenael.casaccio@gmail.com>
+
+	* kernel/CCallable.st: Annotate c-call methods with suspendedCall attribute,
+	indirect call to the primitive used by Process>>#isSuspendedInCCall.
+	* kernel/Process.st: Add isSuspendedInCCall.
+
 2014-04-11  Gwenael Casaccio  <gwenael.casaccio@gmail.com>
 
 	* kernel/Process.st: Change the process creation it set on the right
diff --git a/kernel/CCallable.st b/kernel/CCallable.st
index a937b61..d043c7f 100644
--- a/kernel/CCallable.st
+++ b/kernel/CCallable.st
@@ -128,6 +128,13 @@ to perform the actual call-out to C routines.'>
     ]
 
     asyncCall [
+	<category: 'calling'>
+        <suspendedCCall>
+
+        ^ self primAsyncCall: thisContext parentContext
+    ]
+
+    primAsyncCall: aContext [
 	"Perform the call-out for the function represented by the receiver.
 	 The arguments (and the receiver if one of the arguments has type
 	 #self or #selfSmalltalk) are taken from the parent context.
@@ -136,11 +143,12 @@ to perform the actual call-out to C routines.'>
 	 call-out is not suspended."
 
 	<category: 'calling'>
+        <suspendedCCall>
 	<primitive: VMpr_CFuncDescriptor_asyncCall>
 	^self isValid 
 	    ifFalse: 
 		[SystemExceptions.CInterfaceError signal: 'Invalid C call-out ' , self name]
-	    ifTrue: [self asyncCallNoRetryFrom: thisContext parentContext]
+	    ifTrue: [self asyncCallNoRetryFrom: aContext ]
     ]
 
     asyncCallNoRetryFrom: aContext [
@@ -153,22 +161,31 @@ to perform the actual call-out to C routines.'>
 	 does not attempt to find functions in shared objects."
 
 	<category: 'calling'>
+        <suspendedCCall>
 	<primitive: VMpr_CFuncDescriptor_asyncCall>
 	self primitiveFailed
     ]
 
     callInto: aValueHolder [
+	<category: 'calling'>
+        <suspendedCCall>
+
+        ^ self primCallFrom: thisContext parentContext into: aValueHolder
+    ]
+
+    primCallFrom: aContext into: aValueHolder [
 	"Perform the call-out for the function represented by the receiver.  The
 	 arguments (and the receiver if one of the arguments has type
 	 #self or #selfSmalltalk) are taken from the parent context, and the
 	 the result is stored into aValueHolder.  aValueHolder is also returned."
 
 	<category: 'calling'>
+        <suspendedCCall>
 	<primitive: VMpr_CFuncDescriptor_call>
 	^self isValid 
 	    ifFalse: 
 		[SystemExceptions.CInterfaceError signal: 'Invalid C call-out ' , self name]
-	    ifTrue: [self callNoRetryFrom: thisContext parentContext into: aValueHolder]
+	    ifTrue: [self callNoRetryFrom: aContext into: aValueHolder]
     ]
 
     callNoRetryFrom: aContext into: aValueHolder [
@@ -180,6 +197,7 @@ to perform the actual call-out to C routines.'>
 	 attempt to find functions in shared objects."
 
 	<category: 'calling'>
+        <suspendedCCall>
 	<primitive: VMpr_CFuncDescriptor_call>
 	self primitiveFailed
     ]
diff --git a/kernel/Process.st b/kernel/Process.st
index 76d0742..c379e1f 100644
--- a/kernel/Process.st
+++ b/kernel/Process.st
@@ -422,6 +422,17 @@ can suspend themselves and resume themselves however they wish.'>
 	^suspendedContext isNil
     ]
 
+    isSuspendedInCCall [
+	<category: 'private'>
+
+	| ctx |
+	self isSuspended ifFalse: [ ^ false ].
+        ctx := self suspendedContext.
+	ctx isBlock ifTrue: [ ^ false ].
+        ctx method attributeAt: #suspendedCCall ifAbsent: [ ^ false ].
+        ^ true.
+    ]
+
     isWaiting [
 	"Answer whether the receiver is wating on a semaphore"
 
diff --git a/packages/kernel-tests/ChangeLog b/packages/kernel-tests/ChangeLog
index d0557f3..5a8b821 100644
--- a/packages/kernel-tests/ChangeLog
+++ b/packages/kernel-tests/ChangeLog
@@ -1,3 +1,7 @@
+2014-04-11  Gwenael Casaccio  <gwenael.casaccio@gmail.com>
+
+	* kernel/ProcessTests.st: Add new file.
+
 2014-02-06  Holger Hans Peter Freyther  <holger@moiji-mobile.com>
 
 	* kernel/CCallableTest.st: Add new file.
diff --git a/packages/kernel-tests/kernel/ProcessTests.st b/packages/kernel-tests/kernel/ProcessTests.st
new file mode 100644
index 0000000..65298fc
--- /dev/null
+++ b/packages/kernel-tests/kernel/ProcessTests.st
@@ -0,0 +1,23 @@
+True extend [                                                                 
+    testCallin: aCallback [                                                     
+        <cCall: 'testCallin' returning: #void args: #(#selfSmalltalk #cObject)> 
+    ]                                                                           
+]
+
+TestCase subclass: TestProcess [
+
+    testCCallState [
+        <category: 'testing'>
+
+        | p |
+        p := Processor activeProcess.
+        self assert: p isSuspendedInCCall not.
+        true
+            testCallin: (CCallbackDescriptor
+                            for: [ :x | self assert: p isSuspendedInCCall.
+                                        3
+                                 ]
+                            returning: #int
+                            withArgs: #(#string))
+    ]
+]
-- 
1.8.3.2

