[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Help-smalltalk] [PATCH] Garbage-collected CObjects
|
From: |
Paolo Bonzini |
|
Subject: |
[Help-smalltalk] [PATCH] Garbage-collected CObjects |
|
Date: |
Tue, 06 May 2008 11:49:22 +0200 |
|
User-agent: |
Thunderbird 2.0.0.14 (Macintosh/20080421) |
Having to use two mallocs and an #ensure: block just to wrap a function
that accepts two double* arguments is just awful. But that's what the
Cairo bindings have to do!
So, here comes a way to use ByteArrays as an alternative backing storage
for CObjects.
- | ox oy |
- ox := CDouble value: aPoint x.
- oy := CDouble value: aPoint y.
- ^ [
- block value:self value:ox value: oy
- ] ensure: [
- ox ifNotNil: [ :x | x free ].
- oy ifNotNil: [ :y | y free ]].
+ ^block
+ value: self
+ value: (CDouble gcValue: aPoint x)
+ value: (CDouble gcValue: aPoint y)
Much nicer, and more efficient since the less you use finalization the
better.
However, it requires more care (it can crash badly if objects are moved
by a GC under the feet of C functions!), so it is accessed using special
#gcNew and #gcValue: methods, instead of changing the default instance
creation methods.
Incidentally, this would have been another way to solve the finalization
race problems with CStatStruct, that I fixed a while ago.
I took the opportunity to clean up a little the CObject docs.
Paolo
2008-05-06 Paolo Bonzini <address@hidden>
* kernel/ByteArray.st: Rewrite memory access methods in terms
of CObject.
* kernel/CObject.st: Add support for ByteArrays as CObject storage.
Add #= and #hash.
* kernel/CStruct.st: Add #gcNew.
* kernel/CType.st: Add #gcNew.
* kernel/Object.st: Add #isCObject.
* tests/cobjects.st: Add more tests.
* tests/cobjects.ok: Update.
libgst:
2008-05-06 Paolo Bonzini <address@hidden>
* libgst/callin.c: Adjust calls to COBJECT_NEW, COBJECT_VALUE,
SET_COBJECT_VALUE.
* libgst/cint.c: Likewise. Add _gst_c_type_size.
* libgst/cint.h: Declare _gst_c_type_size.
* libgst/dict.c: Likewise. Rename _gst_c_object_new to
_gst_c_object_new_base, add new instance variable to CObject.
Make CObject absolute in _gst_free_cobject.
* libgst/dict.h: Adjust struct gst_cobject and rename
prototype of _gst_c_object_new to _gst_c_object_new_base.
* libgst/dict.inl: Add cobject_value, set_cobject_value,
cobject_index_check. Adjust COBJECT_NEW. Rename COBJECT_VALUE_OBJ
and SET_COBJECT_VALUE_OBJ to COBJECT_OFFSET_OBJ and
SET_COBJECT_OFFSET_OBJ, respectively.
* libgst/prims.def: Adjust calls to COBJECT_NEW, COBJECT_VALUE,
SET_COBJECT_VALUE. Add calls to cobject_index_check. Handle
derefAt:type: from a garbage-collected CObject specially, and
otherwise preserve the base when casting a CObject.
packages/cairo:
2008-05-06 Paolo Bonzini <address@hidden>
* CairoContext.st: Use GCed CStructs.
* CairoTransform.st: Use GCed CStructs.
packages/sdl/libsdl:
2008-05-06 Paolo Bonzini <address@hidden>
* Display.st: Use GCed CStructs.
diff --git a/NEWS b/NEWS
index a6fcc39..9397c6e 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,17 @@ List of user-visible changes in GNU Smalltalk
NEWS FROM 3.0.2 TO 3.0a
+o CObjects can be backed with garbage-collected (as opposed to
+ heap-allocated) storage. Using this is not always possible, for
+ example for CObjects stored by external libraries or passed to
+ functions that call back to Smalltalk or otherwise may cause garbage
+ collections. If it is, however, it is easier to use, faster and
+ more predictable than finalization. As an added benefit,
+ garbage-collected CObjects accesses are bounds-checked.
+
+ Garbage-collected CObjects are created by sending #gcNew instead
+ of #new.
+
o ObjectMemory>>#snapshot and ObjectMemory>>#snapshot: return false in
the instance of GNU Smalltalk that produced the snapshot, and
true in the instance of GNU Smalltalk that was restored from the
diff --git a/TODO b/TODO
index aa61489..c41225a 100644
--- a/TODO
+++ b/TODO
@@ -9,11 +9,13 @@
* Swazoo (done)
-* TwistedPools (almost there)
+* TwistedPools (done)
+
+** garbage-collected storage for CObjects (done)
* more libraries
-** Cairo (must be documented, cross-platform checking)
-** SDL (likewise)
+** Cairo (missing cross-platform checking)
+** SDL (missing likewise)
* less likely
** Expat
@@ -21,7 +23,6 @@
** 3D gnuplot?
* maybe
-** allocate CStructs in ByteArrays?
** DBI refactoring and prepared statements support
** IPv6
** cookies and redirects for HTTPClient
diff --git a/doc/gst.texi b/doc/gst.texi
index 0316827..32465ee 100644
--- a/doc/gst.texi
+++ b/doc/gst.texi
@@ -1782,12 +1782,12 @@ effect that the VM can simply delay the releasing of
the memory associated
to the object, instead of being forced to waste memory even after
finalization happens.
-An object must be explicitly marked as to be finalized @emph{every time the
-image is loaded}; that is, finalizability is not preserved by an
-image save. This was done because in most cases finalization is
-used together with @code{CObject}s that would be stale when the image is
-loaded again, causing a segmentation violation as soon as they are accessed
-by the finalization method.
+An object must be explicitly marked as to be finalized @emph{every time
+the image is loaded}; that is, finalizability is not preserved by an
+image save. This was done because in most cases finalization is used
+together with operating system resources that would be stale when the
+image is loaded again. For @code{CObject}s, in particular, freeing them
+would cause a segmentation violation.
@end defmethod
@defmethod Object removeToBeFinalized
@@ -3431,14 +3431,39 @@ subclass called @code{CScalar}, which has subclasses
called
@address@hidden These subclasses can answer size and alignment
information.
-Instances of @code{CObject} holds a pointer to a C type variable. The
-variable can be allocated from Smalltalk by doing @address@hidden
-new}, where @var{type} is a @code{CType} subclass instance, or it
-may have been returned through the C callout mechanism as a return
-value. Remember that @code{CObject} and its subclasses represent a
-pointer to a C object and as such provide the full range of operations
-supported by C pointers.
+Instances of @code{CObject} can hold a raw C pointer (for example in
address@hidden heap)), or can delegate their storage to a @code{ByteArray}.
+In the latter case, the storage is automatically garbage collected when
+the @code{CObject} becomes dead, and the VM checks accesses to make sure
+they are in bounds. On the other hand, the storage may move, and for this
+reason extra care must be put when using this kind of @code{CObject} with
+C routines that call back into Smalltalk, or that store the passed pointer
+somewhere.
+Instances of @code{CObject} can be created in many ways:
address@hidden
address@hidden creating an instance with @address@hidden new} initializes
+ the pointer to @code{NULL};
+
address@hidden doing @address@hidden new}, where @var{type} is a @code{CType}
+ subclass instance, allocates a new instance with @code{malloc}.
+
address@hidden doing @address@hidden gcNew}, where @var{type} is a @code{CType}
+ subclass instance, allocates a new instance backed by garbage-collected
+ storage.
+
address@hidden itemize
+
address@hidden and @code{CUnion} subclasses are special. First,
address@hidden allocates a new instance with @code{malloc} instead of
initializing
+the pointer to @code{NULL}. Second, they support @code{gcNew} which
+creates a new instance backed by garbage-collected storage.
+
address@hidden created by the C callout mechanism are never backed by
+garbage-collected storage.
+
address@hidden and its subclasses represent a pointer to a C object and
+as such provide the full range of operations supported by C pointers.
For example, @code{+} @code{anInteger} which returns a CObject which is
higher in memory by @code{anInteger} times the size of each item. There
is also @code{-} which acts like @code{+} if it is given an
@@ -3449,37 +3474,35 @@ backward, by either 1 or @code{n} characters. Only the
pointer to the
string is changed; the actual characters in the string remain untouched.
CObjects can be divided into two families, scalars and non-scalars,
-just like C data types. Scalars fetch a Smalltalk object when sent
-the @code{value} message, and change their value when sent the
address@hidden:} message. Non-scalars do not support these two messages.
-
address@hidden:} @code{aString} replaces the string the instance
-points to with the new string. Actually, it copies the bytes from the
-Smalltalk @code{String} instance aString into the C string object, and null
-terminates. Be sure that the C string has enough room! You can also
-use a Smalltalk @code{ByteArray} as the data source.
+just like C data types. Scalars fetch a Smalltalk object when sent the
address@hidden message, and change their value when sent the @code{value:}
+message. Non-scalars do not support these two messages. Non-scalars
+include instances of @code{CArray} and subclasses of @code{CStruct}
+and @code{CUnion} (but not @code{CPtr}).
-Non-scalars include instances of @code{CArray}, @code{CPtr} and
-subclasses of @code{CStruct} and @code{CUnion}.
-
-CPtrs and CArrays get their underlying element type through a
address@hidden and @code{CArray}s get their underlying element type through a
@code{CType} subclass instance which is associated with the
@code{CArray} or @code{CPtr} instance.
-CPtr's also have @code{value} and @code{value:} which get or change the
-underlying value that's pointed to. In practice, @code{value} dereferences
-the pointer. CString is a subclass that answers a Smalltalk @code{String} when
-sent @code{value}, and automatically allocates storage to copy and
-null-terminate a Smalltalk @code{String} when sent @code{value:}.
-
-Note that a @code{CPtr} to @code{long} points to a place in memory where
-a pointer to long is stored. In other words it is really a @code{long **}
-and must be dereferenced twice with @code{cPtr value value} to get the
address@hidden
address@hidden's @code{value} and @code{value:} method get or change
+the underlying value that's pointed to. @code{value} returns another
address@hidden corresponding to the pointed value. That's because, for
+example, a @code{CPtr} to @code{long} points to a place in memory where
+a pointer to long is stored. It is really a @code{long **} and must be
+dereferenced twice with @code{cPtr value value} to get the @code{long}.
+
address@hidden is a subclass of @code{CPtr} that answers a Smalltalk
address@hidden when sent @code{value}, and automatically allocates
+storage to copy and null-terminate a Smalltalk @code{String} when sent
address@hidden:}. @code{replaceWith:} replaces the string the instance
+points to with a new string or @code{ByteArray}, passed as the argument.
+Actually, it copies the bytes from the Smalltalk @code{String} instance
+aString into the same buffer already pointed to by the @code{CString},
+with a null terminator.
Finally, there are @code{CStruct} and @code{CUnion}, which are abstract
subclasses of @address@hidden they have a common superclass
-named @code{CCompound}.}. In the following I will refer to CStruct, but the
+named @code{CCompound}.}. The following will refer to CStruct, but the
same considerations apply to CUnion as well, with the only difference that
CUnions of course implement the semantics of a C union.
diff --git a/kernel/ByteArray.st b/kernel/ByteArray.st
index ab4a236..946737d 100644
--- a/kernel/ByteArray.st
+++ b/kernel/ByteArray.st
@@ -110,7 +110,6 @@ a String''s elements are characters.'>
^self
type: 9
at: index
- size: CPtrSize - 1
]
charAt: index [
@@ -122,7 +121,6 @@ a String''s elements are characters.'>
^self
type: 0
at: index
- size: 0
]
unsignedCharAt: index [
@@ -134,7 +132,6 @@ a String''s elements are characters.'>
^self
type: 1
at: index
- size: 0
]
ucharAt: index [
@@ -146,7 +143,6 @@ a String''s elements are characters.'>
^self
type: 1
at: index
- size: 0
]
shortAt: index [
@@ -157,7 +153,6 @@ a String''s elements are characters.'>
^self
type: 2
at: index
- size: CShortSize - 1
]
unsignedShortAt: index [
@@ -168,7 +163,6 @@ a String''s elements are characters.'>
^self
type: 3
at: index
- size: CShortSize - 1
]
ushortAt: index [
@@ -179,7 +173,6 @@ a String''s elements are characters.'>
^self
type: 3
at: index
- size: CShortSize - 1
]
longAt: index [
@@ -190,7 +183,6 @@ a String''s elements are characters.'>
^self
type: 4
at: index
- size: CLongSize - 1
]
unsignedLongAt: index [
@@ -201,7 +193,6 @@ a String''s elements are characters.'>
^self
type: 5
at: index
- size: CLongSize - 1
]
ulongAt: index [
@@ -212,7 +203,6 @@ a String''s elements are characters.'>
^self
type: 5
at: index
- size: CLongSize - 1
]
intAt: index [
@@ -223,7 +213,6 @@ a String''s elements are characters.'>
^self
type: 10
at: index
- size: CIntSize - 1
]
unsignedIntAt: index [
@@ -234,7 +223,6 @@ a String''s elements are characters.'>
^self
type: 11
at: index
- size: CIntSize - 1
]
uintAt: index [
@@ -245,7 +233,6 @@ a String''s elements are characters.'>
^self
type: 11
at: index
- size: CIntSize - 1
]
floatAt: index [
@@ -256,7 +243,6 @@ a String''s elements are characters.'>
^self
type: 6
at: index
- size: CFloatSize - 1
]
doubleAt: index [
@@ -267,7 +253,6 @@ a String''s elements are characters.'>
^self
type: 7
at: index
- size: CDoubleSize - 1
]
longDoubleAt: index [
@@ -278,7 +263,6 @@ a String''s elements are characters.'>
^self
type: 12
at: index
- size: CLongDoubleSize - 1
]
stringAt: index [
@@ -289,7 +273,6 @@ a String''s elements are characters.'>
^self
type: 8
at: index
- size: CPtrSize - 1
]
objectAt: index put: value [
@@ -302,7 +285,6 @@ a String''s elements are characters.'>
type: 9
at: index
put: value
- size: CPtrSize - 1
]
charAt: index put: value [
@@ -316,7 +298,6 @@ a String''s elements are characters.'>
type: 0
at: index
put: value
- size: 0
]
unsignedCharAt: index put: value [
@@ -330,7 +311,6 @@ a String''s elements are characters.'>
type: 1
at: index
put: value
- size: 0
]
ucharAt: index put: value [
@@ -344,7 +324,6 @@ a String''s elements are characters.'>
type: 1
at: index
put: value
- size: 0
]
shortAt: index put: value [
@@ -357,7 +336,6 @@ a String''s elements are characters.'>
type: 2
at: index
put: value
- size: CShortSize - 1
]
unsignedShortAt: index put: value [
@@ -370,7 +348,6 @@ a String''s elements are characters.'>
type: 3
at: index
put: value
- size: CShortSize - 1
]
ushortAt: index put: value [
@@ -383,7 +360,6 @@ a String''s elements are characters.'>
type: 3
at: index
put: value
- size: CShortSize - 1
]
longAt: index put: value [
@@ -396,7 +372,6 @@ a String''s elements are characters.'>
type: 4
at: index
put: value
- size: CLongSize - 1
]
unsignedLongAt: index put: value [
@@ -409,7 +384,6 @@ a String''s elements are characters.'>
type: 5
at: index
put: value
- size: CLongSize - 1
]
ulongAt: index put: value [
@@ -422,7 +396,6 @@ a String''s elements are characters.'>
type: 5
at: index
put: value
- size: CLongSize - 1
]
intAt: index put: value [
@@ -435,7 +408,6 @@ a String''s elements are characters.'>
type: 10
at: index
put: value
- size: CIntSize - 1
]
unsignedIntAt: index put: value [
@@ -448,7 +420,6 @@ a String''s elements are characters.'>
type: 11
at: index
put: value
- size: CIntSize - 1
]
uintAt: index put: value [
@@ -461,7 +432,6 @@ a String''s elements are characters.'>
type: 11
at: index
put: value
- size: CIntSize - 1
]
floatAt: index put: value [
@@ -474,7 +444,6 @@ a String''s elements are characters.'>
type: 6
at: index
put: value
- size: CFloatSize - 1
]
doubleAt: index put: value [
@@ -487,7 +456,6 @@ a String''s elements are characters.'>
type: 7
at: index
put: value
- size: CDoubleSize - 1
]
longDoubleAt: index put: value [
@@ -500,7 +468,6 @@ a String''s elements are characters.'>
type: 12
at: index
put: value
- size: CLongDoubleSize - 1
]
stringAt: index put: value [
@@ -515,7 +482,6 @@ a String''s elements are characters.'>
type: 8
at: index
put: value
- size: CPtrSize - 1
]
growSize [
@@ -527,36 +493,21 @@ a String''s elements are characters.'>
^self size
]
- type: type at: index size: size [
+ type: type at: index [
"Private - Use Memory class to access in the receiver a value with the
given type."
<category: 'private'>
- | offset |
- index < 1
- ifTrue: [^SystemExceptions.IndexOutOfRange signalOn: self
withIndex: index].
- index > (self basicSize - size)
- ifTrue: [^SystemExceptions.IndexOutOfRange signalOn: self
withIndex: index].
- offset := index + (CLongSize * 2 - 1). "impl. dependent"
- ^Memory type: type at: (ObjectMemory addressOf: self) + offset
+ ^(CObject new storage: self) at: index - 1 type: type
]
- type: type at: index put: value size: size [
+ type: type at: index put: value [
"Private - Use Memory class to write to the receiver a value with the
given type."
<category: 'private'>
- | offset |
self isReadOnly ifTrue: [^SystemExceptions.ReadOnlyObject signal].
- index < 1
- ifTrue: [^SystemExceptions.IndexOutOfRange signalOn: self
withIndex: index].
- index > (self basicSize - size)
- ifTrue: [^SystemExceptions.IndexOutOfRange signalOn: self
withIndex: index].
- offset := index + (CLongSize * 2 - 1). "impl. dependent"
- ^Memory
- type: type
- at: (ObjectMemory addressOf: self) + offset
- put: value
+ ^(CObject new storage: self) at: index - 1 put: value type: type
]
byteAt: index [
diff --git a/kernel/CObject.st b/kernel/CObject.st
index 1d1a24f..3648825 100644
--- a/kernel/CObject.st
+++ b/kernel/CObject.st
@@ -33,7 +33,7 @@
Object subclass: CObject [
- | type |
+ | type storage |
<shape: #word>
<import: CSymbols>
@@ -58,6 +58,31 @@ into their corresponding C values for use in external
routines.'>
yourself
]
+ CObject class >> alloc: nBytes type: cTypeObject [
+ "Allocate nBytes bytes and return a CObject of the given type"
+
+ <category: 'primitive allocation'>
+ <primitive: VMpr_CObject_allocType>
+ nBytes isInteger
+ ifFalse: [^SystemExceptions.WrongClass signalOn: nBytes mustBe:
SmallInteger].
+ ^SystemExceptions.WrongClass signalOn: cTypeObject mustBe: CType
+ ]
+
+ CObject class >> gcAlloc: nBytes type: cTypeObject [
+ "Allocate nBytes bytes and return a CObject of the given type"
+
+ <category: 'primitive allocation'>
+ | class |
+ class := cTypeObject isNil
+ ifTrue: [ self ]
+ ifFalse: [ cTypeObject cObjectType ].
+
+ ^(class new)
+ type: cTypeObject;
+ storage: (ByteArray new: nBytes);
+ yourself
+ ]
+
CObject class >> alloc: nBytes [
"Allocate nBytes bytes and return an instance of the receiver"
@@ -65,21 +90,25 @@ into their corresponding C values for use in external
routines.'>
^self alloc: nBytes type: nil
]
- CObject class >> new: nBytes [
+ CObject class >> gcAlloc: nBytes [
"Allocate nBytes bytes and return an instance of the receiver"
<category: 'instance creation'>
- ^self alloc: nBytes type: nil
+ ^self gcAlloc: nBytes type: nil
]
- CObject class >> alloc: nBytes type: cTypeObject [
- "Allocate nBytes bytes and return a CObject of the given type"
+ CObject class >> gcNew: nBytes [
+ "Allocate nBytes bytes and return an instance of the receiver"
<category: 'instance creation'>
- <primitive: VMpr_CObject_allocType>
- nBytes isInteger
- ifFalse: [^SystemExceptions.WrongClass signalOn: nBytes mustBe:
SmallInteger].
- ^SystemExceptions.WrongClass signalOn: cTypeObject mustBe: CType
+ ^self gcAlloc: nBytes type: nil
+ ]
+
+ CObject class >> new: nBytes [
+ "Allocate nBytes bytes and return an instance of the receiver"
+
+ <category: 'instance creation'>
+ ^self alloc: nBytes type: nil
]
CObject class >> address: anInteger [
@@ -112,6 +141,24 @@ into their corresponding C values for use in external
routines.'>
^nil
]
+ = anObject [
+ "Return true if the receiver and aCObject are equal."
+
+ <category: 'basic'>
+ ^self class == anObject class and: [
+ self type = anObject type and: [
+ self storage == anObject storage and: [
+ self address = anObject address ]]]
+ ]
+
+ hash [
+ "Return a hash value for anObject."
+
+ <category: 'basic'>
+ ^self type hash
+ bitXor: (self storage identityHash * self sizeof + self address)
+ ]
+
finalize [
"To make the VM call this, use #addToBeFinalized. It frees
automatically any memory pointed to by the CObject. It is not
@@ -179,6 +226,11 @@ into their corresponding C values for use in external
routines.'>
^aValue
]
+ isCObject [
+ <category: 'testing functionality'>
+ ^true
+ ]
+
incr [
"Adjust the pointer by sizeof(dereferencedType) bytes up (i.e.
++receiver)"
@@ -265,10 +317,37 @@ into their corresponding C values for use in external
routines.'>
^type
]
+ isAbsolute [
+ "Answer whether the object points into a garbage-collected Smalltalk
+ storage, or it is an absolute address."
+
+ <category: 'accessing'>
+ ^storage isNil
+ ]
+
+ storage [
+ "Answer the storage that the receiver is pointing into, or nil
+ if the address is absolute."
+
+ <category: 'accessing'>
+ ^storage
+ ]
+
+ storage: anObject [
+ "Change the receiver to point to the storage of anObject."
+
+ <category: 'accessing'>
+ storage := anObject.
+ ]
+
address [
- "Answer the address the receiver is pointing to."
+ "Answer the address the receiver is pointing to. The address can
+ be absolute if the storage is nil, or relative to the Smalltalk
+ object in #storage. In this case, an address of 0 corresponds to
+ the first instance variable."
<category: 'accessing'>
+ <primitive: VMpr_CObject_address>
^self basicAt: self basicSize
]
@@ -276,7 +355,8 @@ into their corresponding C values for use in external
routines.'>
"Set the receiver to point to the passed address, anInteger"
<category: 'accessing'>
- self basicAt: self basicSize put: anInteger
+ <primitive: VMpr_CObject_addressColon>
+ SystemExceptions.WrongClass signalOn: anInteger mustBe: Integer
]
printOn: aStream [
@@ -285,9 +365,15 @@ into their corresponding C values for use in external
routines.'>
<category: 'accessing'>
aStream
print: self class;
- nextPut: $(;
- nextPutAll: (self address printStringRadix: 16);
- nextPut: $)
+ nextPut: $(.
+
+ self isAbsolute
+ ifTrue: [ aStream nextPutAll: (self address printStringRadix: 16) ]
+ ifFalse: [
+ self storage do: [ :each | aStream print: each; space ].
+ aStream nextPutAll: '@ '; print: self address ].
+
+ aStream nextPut: $)
]
type: aCType [
@@ -332,6 +418,10 @@ into their corresponding C values for use in external
routines.'>
byteOffset isInteger
ifFalse:
[^SystemExceptions.WrongClass signalOn: byteOffset mustBe:
SmallInteger].
+ (self isAbsolute not and: [ aType isInteger ]) ifTrue: [
+ ^SystemExceptions.InvalidArgument signalOn: self address +
byteOffset
+ reason: 'offset out of range' ].
+
^SystemExceptions.WrongClass signalOn: aType
]
@@ -342,6 +432,11 @@ into their corresponding C values for use in external
routines.'>
<category: 'C data access'>
| type |
<primitive: VMpr_CObject_atPut>
+
+ (self isAbsolute not and: [ aValue isCObject not ]) ifTrue: [
+ ^SystemExceptions.InvalidArgument signalOn: self address +
byteOffset
+ reason: 'offset out of range' ].
+
type := aValue cObjStoredType.
"Attempt to store something meaningful from another CObject"
@@ -407,6 +502,17 @@ CObject subclass: CScalar [
^cObject
]
+ CScalar class >> gcValue: anObject [
+ "Answer a newly allocated CObject containing the passed value,
+ anObject, in garbage-collected storage."
+
+ <category: 'instance creation'>
+ | cObject |
+ cObject := self type new.
+ cObject value: anObject.
+ ^cObject
+ ]
+
CScalar class >> type [
"Answer a CType for the receiver---for example, CByteType if
the receiver is CByte."
diff --git a/kernel/CStruct.st b/kernel/CStruct.st
index 53db2bf..fd9964f 100644
--- a/kernel/CStruct.st
+++ b/kernel/CStruct.st
@@ -43,6 +43,14 @@ CObject subclass: CCompound [
]
+ CCompound class >> gcNew [
+ "Allocate a new instance of the receiver, backed by garbage-collected
+ storage."
+
+ <category: 'instance creation'>
+ ^self gcAlloc: self sizeof
+ ]
+
CCompound class >> new [
"Allocate a new instance of the receiver. To free the memory after
GC, remember to call #addToBeFinalized."
diff --git a/kernel/CType.st b/kernel/CType.st
index 2cae008..cef271f 100644
--- a/kernel/CType.st
+++ b/kernel/CType.st
@@ -136,6 +136,15 @@ elements.'>
structureType == #ptr ifTrue: [^CPtrCType from: type]
]
+ gcNew [
+ "Allocate a new CObject with the type (class) identified by the
receiver.
+ The object is movable in memory, but on the other hand it is
+ garbage-collected automatically."
+
+ <category: 'C instance creation'>
+ ^CObject gcAlloc: self sizeof type: self
+ ]
+
new [
"Allocate a new CObject with the type (class) identified by the
receiver.
It is the caller's responsibility to free the memory allocated for it."
diff --git a/kernel/Object.st b/kernel/Object.st
index 11095b4..90e0bff 100644
--- a/kernel/Object.st
+++ b/kernel/Object.st
@@ -162,6 +162,11 @@ All classes in the system are subclasses of me.'>
^notNilBlock value: self
]
+ isCObject [
+ <category: 'testing functionality'>
+ ^false
+ ]
+
isString [
<category: 'testing functionality'>
^false
diff --git a/libgst/callin.c b/libgst/callin.c
index 4cbd9af..29006d3 100644
--- a/libgst/callin.c
+++ b/libgst/callin.c
@@ -234,7 +234,8 @@ _gst_va_msg_sendf (PTR resultPtr,
break;
case 'C':
- args[++i] = COBJECT_NEW (va_arg (ap, PTR));
+ args[++i] = COBJECT_NEW (va_arg (ap, PTR), _gst_nil_oop,
+ _gst_c_object_class);
INC_ADD_OOP (args[i]);
break;
@@ -259,8 +260,7 @@ _gst_va_msg_sendf (PTR resultPtr,
ctype = _gst_type_name_to_oop (va_arg (ap, const char *));
INC_ADD_OOP (ctype);
- args[++i] =
- _gst_c_object_new (va_arg (ap, PTR), ctype, _gst_nil_oop);
+ args[++i] = COBJECT_NEW (va_arg (ap, PTR), ctype, _gst_nil_oop);
INC_ADD_OOP (args[i]);
}
@@ -271,8 +271,7 @@ _gst_va_msg_sendf (PTR resultPtr,
{
OOP ctype;
ctype = va_arg (ap, OOP);
- args[++i] =
- _gst_c_object_new (va_arg (ap, PTR), ctype, _gst_nil_oop);
+ args[++i] = COBJECT_NEW (va_arg (ap, PTR), ctype, _gst_nil_oop);
INC_ADD_OOP (args[i]);
}
@@ -307,7 +306,7 @@ _gst_va_msg_sendf (PTR resultPtr,
case 'C':
*(PTR *) resultPtr =
- IS_NIL (result) ? NULL : COBJECT_VALUE (result);
+ IS_NIL (result) ? NULL : cobject_value (result);
break;
case 's':
@@ -588,7 +587,7 @@ _gst_c_object_to_oop (PTR co)
if (co == NULL)
return (_gst_nil_oop);
else
- return (INC_ADD_OOP (COBJECT_NEW (co)));
+ return (INC_ADD_OOP (COBJECT_NEW (co, _gst_nil_oop, _gst_c_object_class)));
}
void
@@ -597,7 +596,7 @@ _gst_set_c_object (OOP oop, PTR co)
if (!_gst_smalltalk_initialized)
_gst_initialize (NULL, NULL, GST_NO_TTY);
- SET_COBJECT_VALUE(oop, co);
+ set_cobject_value (oop, co);
}
@@ -630,7 +629,7 @@ _gst_oop_to_c (OOP oop)
return (0);
else if (is_a_kind_of (OOP_CLASS (oop), _gst_c_object_class))
- return ((long) COBJECT_VALUE (oop));
+ return ((long) cobject_value (oop));
else
return (0);
@@ -758,7 +757,7 @@ _gst_oop_to_c_object (OOP oop)
if (IS_NIL (oop))
return (NULL);
else
- return (COBJECT_VALUE (oop));
+ return (cobject_value (oop));
}
OOP
diff --git a/libgst/cint.c b/libgst/cint.c
index 2f7bfc0..c4ed5d8 100644
--- a/libgst/cint.c
+++ b/libgst/cint.c
@@ -652,6 +652,63 @@ lookup_function (const char *funcName)
}
+int
+_gst_c_type_size (int type)
+{
+ switch (type)
+ {
+ case CDATA_CHAR:
+ return sizeof (char);
+ case CDATA_UCHAR:
+ return sizeof (unsigned char);
+
+ case CDATA_SHORT:
+ return sizeof (short);
+ case CDATA_USHORT:
+ return sizeof (unsigned short);
+
+ case CDATA_INT:
+ return sizeof (int);
+ case CDATA_UINT:
+ return sizeof (unsigned int);
+
+ case CDATA_LONG:
+ return sizeof (long);
+ case CDATA_ULONG:
+ return sizeof (unsigned long);
+
+ case CDATA_FLOAT:
+ return sizeof (float);
+ case CDATA_DOUBLE:
+ return sizeof (double);
+ case CDATA_LONG_DOUBLE:
+ return sizeof (long double);
+
+ case CDATA_OOP:
+ return sizeof (OOP);
+
+ case CDATA_WCHAR:
+ return sizeof (wchar_t);
+
+ case CDATA_WSTRING:
+ return sizeof (wchar_t *);
+
+ case CDATA_STRING:
+ case CDATA_STRING_OUT:
+ case CDATA_SYMBOL:
+ case CDATA_BYTEARRAY:
+ case CDATA_BYTEARRAY_OUT:
+ case CDATA_SYMBOL_OUT:
+ return sizeof (char *);
+
+ case CDATA_COBJECT:
+ return sizeof (void *);
+
+ case CDATA_COBJECT_PTR:
+ return sizeof (void **);
+ }
+}
+
OOP
_gst_invoke_croutine (OOP cFuncOOP,
OOP receiver,
@@ -671,7 +728,7 @@ _gst_invoke_croutine (OOP cFuncOOP,
if (IS_NIL (desc->cFunction))
return (NULL);
- c_func_cur = (cfunc_info *) COBJECT_VALUE (desc->cFunction);
+ c_func_cur = (cfunc_info *) cobject_value (desc->cFunction);
if (!c_func_cur)
return (NULL);
@@ -752,7 +809,7 @@ _gst_invoke_croutine (OOP cFuncOOP,
switch (arg->cType)
{
case CDATA_COBJECT_PTR:
- SET_COBJECT_VALUE (arg->oop, arg->u.cObjectPtrVal.ptrVal);
+ set_cobject_value (arg->oop, arg->u.cObjectPtrVal.ptrVal);
continue;
case CDATA_WSTRING_OUT:
@@ -1053,13 +1110,13 @@ push_smalltalk_obj (OOP oop,
/* Set up an indirect pointer to protect against the OOP
moving during the call-out. */
cp->u.cObjectPtrVal.pPtrVal = &cp->u.cObjectPtrVal.ptrVal;
- cp->u.cObjectPtrVal.ptrVal = COBJECT_VALUE (oop);
+ cp->u.cObjectPtrVal.ptrVal = cobject_value (oop);
cp->oop = oop;
SET_TYPE (&ffi_type_pointer);
return;
case CDATA_COBJECT:
- cp->u.ptrVal = COBJECT_VALUE (oop);
+ cp->u.ptrVal = cobject_value (oop);
SET_TYPE (&ffi_type_pointer);
return;
}
@@ -1162,8 +1219,8 @@ c_to_smalltalk (cparam *result, OOP returnTypeOOP)
{
if (IS_INT (returnTypeOOP))
returnTypeOOP = _gst_nil_oop;
- resultOOP = _gst_c_object_new (result->u.ptrVal, returnTypeOOP,
- _gst_c_object_class);
+ resultOOP = COBJECT_NEW (result->u.ptrVal, returnTypeOOP,
+ _gst_c_object_class);
}
else if (returnType == CDATA_STRING || returnType == CDATA_STRING_OUT)
{
@@ -1244,7 +1301,7 @@ _gst_make_descriptor (OOP classOOP,
OOPs */
incPtr = INC_SAVE_POINTER ();
- cFunction = COBJECT_NEW (cfi);
+ cFunction = COBJECT_NEW (cfi, _gst_nil_oop, _gst_c_object_class);
INC_ADD_OOP (cFunction);
cFunctionName = _gst_string_new (funcName);
diff --git a/libgst/cint.h b/libgst/cint.h
index 09bed43..db92e68 100644
--- a/libgst/cint.h
+++ b/libgst/cint.h
@@ -118,6 +118,9 @@ typedef struct gst_cfunc_descriptor
}
*gst_cfunc_descriptor;
+/* Returns the size of an object passed to a C routine with type TYPE. */
+extern int _gst_c_type_size (int type);
+
/* Invokes a C routine. Arguments passed from Smalltalk are stored starting
from ARGS, and the object to which the message that called-out was
sent is RECEIVER. CFUNCOOP is the C function descriptor used
diff --git a/libgst/dict.c b/libgst/dict.c
index 2611ad9..7878822 100644
--- a/libgst/dict.c
+++ b/libgst/dict.c
@@ -707,8 +707,8 @@ static const class_definition class_info[] = {
"SecurityPolicy", "dictionary owner", NULL, NULL },
{&_gst_c_object_class, &_gst_object_class,
- ISP_ULONG, true, 1, /* leave this this way */
- "CObject", "type", NULL, "CSymbols" },
+ ISP_ULONG, true, 2,
+ "CObject", "type storage", NULL, "CSymbols" },
{&_gst_c_type_class, &_gst_object_class,
ISP_FIXED, true, 1,
@@ -2080,9 +2080,10 @@ _gst_message_new_args (OOP selectorOOP,
}
OOP
-_gst_c_object_new (PTR cObjPtr,
- OOP typeOOP,
- OOP defaultClassOOP)
+_gst_c_object_new_base (OOP baseOOP,
+ uintptr_t cObjOfs,
+ OOP typeOOP,
+ OOP defaultClassOOP)
{
gst_cobject cObject;
gst_ctype cType;
@@ -2099,7 +2100,8 @@ _gst_c_object_new (PTR cObjPtr,
cObject = (gst_cobject) new_instance_with (classOOP, 1, &cObjectOOP);
cObject->type = typeOOP;
- SET_COBJECT_VALUE_OBJ (cObject, cObjPtr);
+ cObject->storage = baseOOP;
+ SET_COBJECT_OFFSET_OBJ (cObject, cObjOfs);
return (cObjectOOP);
}
@@ -2111,10 +2113,13 @@ _gst_free_cobject (OOP cObjOOP)
gst_cobject cObject;
cObject = (gst_cobject) OOP_TO_OBJ (cObjOOP);
- xfree ((PTR) COBJECT_VALUE_OBJ (cObject));
+ if (!IS_NIL (cObject->storage))
+ cObject->storage = _gst_nil_oop;
+ else
+ xfree ((PTR) COBJECT_OFFSET_OBJ (cObject));
- /* at least make it not point to falsely valid storage */
- SET_COBJECT_VALUE_OBJ (cObject, NULL);
+ /* make it not point to falsely valid storage */
+ SET_COBJECT_OFFSET_OBJ (cObject, NULL);
}
void
diff --git a/libgst/dict.h b/libgst/dict.h
index d79fc78..ba58fca 100644
--- a/libgst/dict.h
+++ b/libgst/dict.h
@@ -291,6 +291,7 @@ typedef struct gst_cobject
{
OBJ_HEADER;
OOP type;
+ OOP storage;
}
*gst_cobject;
@@ -516,12 +517,14 @@ extern OOP _gst_shared_pool_dictionary (OOP class_oop)
ATTRIBUTE_PURE
ATTRIBUTE_HIDDEN;
-/* Creates a new CObject pointing to cObjPtr, extracting the class
+/* Creates a new CObject pointing to cObjOfs bytes in BASEOOP (or
+ at the absolute address cObjOfs if BASEOOP is NULL), extracting the class
to be instantiated from the CType, TYPEOOP, or using the provided
class if TYPEOOP is nil. */
-extern OOP _gst_c_object_new (PTR cObjPtr,
- OOP typeOOP,
- OOP defaultClassOOP)
+extern OOP _gst_c_object_new_base (OOP baseOOP,
+ uintptr_t cObjOfs,
+ OOP typeOOP,
+ OOP defaultClassOOP)
ATTRIBUTE_HIDDEN;
/* Creates a new String with LEN indexed instance variables. */
diff --git a/libgst/dict.inl b/libgst/dict.inl
index b46d2bf..85a30af 100644
--- a/libgst/dict.inl
+++ b/libgst/dict.inl
@@ -198,6 +198,17 @@ static inline OOP floate_new (double f);
problems. */
static inline OOP floatq_new (long double f);
+/* Returns the address of the data stored in a CObject. */
+static inline PTR cobject_value (OOP oop);
+
+/* Sets the address of the data stored in a CObject. */
+static inline void set_cobject_value (OOP oop, PTR val);
+
+/* Return whether the address of the data stored in a CObject, offsetted
+ by OFFSET bytes, is still in bounds. */
+static inline mst_Boolean cobject_index_check (OOP oop, intptr_t offset,
+ size_t size);
+
/* Answer true if OOP is a SmallInteger or a LargeInteger of an
appropriate size. */
static inline mst_Boolean is_c_int_32 (OOP oop);
@@ -304,26 +315,19 @@ static inline int64_t to_c_int_64 (OOP oop);
(((gst_message)OOP_TO_OBJ(messageOOP))->args)
/* Answer a new CObject pointing to COBJPTR. */
-#define COBJECT_NEW(cObjPtr) \
- (_gst_c_object_new(cObjPtr, _gst_nil_oop, _gst_c_object_class))
+#define COBJECT_NEW(cObjPtr, typeOOP, defaultClassOOP) \
+ (_gst_c_object_new_base(_gst_nil_oop, (uintptr_t) cObjPtr, \
+ typeOOP, defaultClassOOP))
-/* Answer the void * extracted from a CObject, COBJ (*not* an OOP,
+/* Answer the offset component of the a CObject, COBJ (*not* an OOP,
but an object pointer). */
-#define COBJECT_VALUE_OBJ(cObj) \
- ( ((PTR *) cObj) [TO_INT(((gst_object)cObj)->objSize) - 1])
+#define COBJECT_OFFSET_OBJ(cObj) \
+ ( ((uintptr_t *) cObj) [TO_INT(cObj->objSize) - 1])
-/* Sets to VALUE the void * pointed to by the CObject, COBJ (*not* an
+/* Sets to VALUE the offset component of the CObject, COBJ (*not* an
OOP, but an object pointer). */
-#define SET_COBJECT_VALUE_OBJ(cObj, value) \
- ( ((PTR *) cObj) [TO_INT(((gst_object)cObj)->objSize) - 1] = (PTR)(value))
-
-/* Sets to VALUE the void * pointed to by the CObject, COBJOOP. */
-#define COBJECT_VALUE(cObjOOP) \
- COBJECT_VALUE_OBJ(OOP_TO_OBJ(cObjOOP))
-
-/* Sets to VALUE the void * pointed to by the CObject, COBJOOP. */
-#define SET_COBJECT_VALUE(cObjOOP, value) \
- SET_COBJECT_VALUE_OBJ(OOP_TO_OBJ(cObjOOP), value)
+#define SET_COBJECT_OFFSET_OBJ(cObj, value) \
+ ( ((uintptr_t *) cObj) [TO_INT(cObj->objSize) - 1] = (uintptr_t)(value))
/* Answer the superclass of the Behavior, CLASS_OOP. */
#define SUPERCLASS(class_oop) \
@@ -1484,3 +1488,48 @@ from_c_uint_64 (uint64_t ui)
return (oop);
}
+
+static inline PTR
+cobject_value (OOP oop)
+{
+ gst_cobject cObj = (gst_cobject) OOP_TO_OBJ (oop);
+ if (IS_NIL (cObj->storage))
+ return (PTR) COBJECT_OFFSET_OBJ (cObj);
+ else
+ {
+ gst_uchar *baseAddr = ((gst_byte_array) OOP_TO_OBJ
(cObj->storage))->bytes;
+ return (PTR) (baseAddr + COBJECT_OFFSET_OBJ (cObj));
+ }
+}
+
+/* Sets the address of the data stored in a CObject. */
+static inline void
+set_cobject_value (OOP oop, PTR val)
+{
+ gst_cobject cObj = (gst_cobject) OOP_TO_OBJ (oop);
+ cObj->storage = _gst_nil_oop;
+ SET_COBJECT_OFFSET_OBJ (cObj, (uintptr_t) val);
+}
+
+
+/* Return whether the address of the data stored in a CObject, offsetted
+ by OFFSET bytes, is still in bounds. */
+static inline mst_Boolean cobject_index_check (OOP oop, intptr_t offset,
+ size_t size)
+{
+ gst_cobject cObj = (gst_cobject) OOP_TO_OBJ (oop);
+ OOP baseOOP = cObj->storage;
+ intptr_t maxOffset;
+ if (IS_NIL (baseOOP))
+ return true;
+
+ offset += COBJECT_OFFSET_OBJ (cObj);
+ if (offset < 0)
+ return false;
+
+ maxOffset = SIZE_TO_BYTES (NUM_WORDS (OOP_TO_OBJ (baseOOP)));
+ if (baseOOP->flags & F_BYTE)
+ maxOffset -= (baseOOP->flags & EMPTY_BYTES);
+
+ return (offset + size - 1 < maxOffset);
+}
diff --git a/libgst/prims.def b/libgst/prims.def
index ce491bd..e896c53 100644
--- a/libgst/prims.def
+++ b/libgst/prims.def
@@ -3913,7 +3913,7 @@ primitive VMpr_CObject_allocType [succeed,fail]
{
intptr_t arg2 = TO_INT (oop2);
PTR ptr = xmalloc (arg2);
- OOP cObjectOOP = _gst_c_object_new (ptr, oop1, oop3);
+ OOP cObjectOOP = COBJECT_NEW (ptr, oop1, oop3);
POP_N_OOPS (2);
SET_STACKTOP (cObjectOOP);
@@ -4394,7 +4394,7 @@ primitive VMpr_CObject_at :
oop3 = POP_OOP ();
oop2 = POP_OOP ();
- oop1 = POP_OOP ();
+ oop1 = STACKTOP ();
if (IS_INT (oop2)
&& ((IS_INT (oop3) && id == prim_id (VMpr_CObject_at))
|| is_a_kind_of (OOP_CLASS (oop3), _gst_c_type_class)))
@@ -4404,40 +4404,41 @@ primitive VMpr_CObject_at :
arg2 = TO_INT (oop2);
if (IS_INT (oop3))
{ /* int type spec means a scalar type */
- intptr_t arg3;
- addr = COBJECT_VALUE (oop1);
- addr += arg2; /* compute effective address */
- arg3 = TO_INT (oop3);
+ intptr_t arg3 = TO_INT (oop3);
+
+ if (!cobject_index_check (oop1, arg2, _gst_c_type_size (arg3)))
+ goto fail;
+ addr = ((char *) cobject_value (oop1)) + arg2;
switch (arg3)
{
case CDATA_CHAR:
case CDATA_UCHAR:
- PUSH_OOP (CHAR_OOP_AT (*(gst_uchar *) addr));
+ SET_STACKTOP (CHAR_OOP_AT (*(gst_uchar *) addr));
PRIM_SUCCEEDED;
case CDATA_SHORT:
- PUSH_INT (*(short *) addr);
+ SET_STACKTOP_INT (*(short *) addr);
PRIM_SUCCEEDED;
case CDATA_USHORT:
- PUSH_INT (*(unsigned short *) addr);
+ SET_STACKTOP_INT (*(unsigned short *) addr);
PRIM_SUCCEEDED;
case CDATA_LONG:
- PUSH_OOP (FROM_C_LONG (*(long *) addr));
+ SET_STACKTOP (FROM_C_LONG (*(long *) addr));
PRIM_SUCCEEDED;
case CDATA_ULONG:
- PUSH_OOP (FROM_C_ULONG (*(unsigned long *) addr));
+ SET_STACKTOP (FROM_C_ULONG (*(unsigned long *) addr));
PRIM_SUCCEEDED;
case CDATA_FLOAT:
- PUSH_OOP (floate_new (*(float *) addr));
+ SET_STACKTOP (floate_new (*(float *) addr));
PRIM_SUCCEEDED;
case CDATA_DOUBLE:
- PUSH_OOP (floatd_new (*(double *) addr));
+ SET_STACKTOP (floatd_new (*(double *) addr));
PRIM_SUCCEEDED;
case CDATA_STRING:
@@ -4446,62 +4447,78 @@ primitive VMpr_CObject_at :
strAddr = (char **) addr;
if (*strAddr)
{
- PUSH_OOP (_gst_string_new (*strAddr));
+ SET_STACKTOP (_gst_string_new (*strAddr));
PRIM_SUCCEEDED;
}
else
{
- PUSH_OOP (_gst_nil_oop);
+ SET_STACKTOP (_gst_nil_oop);
PRIM_SUCCEEDED;
}
}
case CDATA_OOP:
- PUSH_OOP (*(OOP *) addr);
+ SET_STACKTOP (*(OOP *) addr);
PRIM_SUCCEEDED;
case CDATA_INT:
- PUSH_OOP (FROM_C_INT (*(int *) addr));
+ SET_STACKTOP (FROM_C_INT (*(int *) addr));
PRIM_SUCCEEDED;
case CDATA_UINT:
- PUSH_OOP (FROM_C_UINT (*(unsigned int *) addr));
+ SET_STACKTOP (FROM_C_UINT (*(unsigned int *) addr));
PRIM_SUCCEEDED;
case CDATA_LONG_DOUBLE:
- PUSH_OOP (floatq_new (*(long double *) addr));
+ SET_STACKTOP (floatq_new (*(long double *) addr));
PRIM_SUCCEEDED;
}
-
}
else
{
+ OOP baseOOP;
+ uintptr_t ofs;
+ inc_ptr incPtr;
+
/* Non-integer oop3: use it as the type of the effective address. */
if (id == prim_id (VMpr_CObject_derefAt))
{
- addr = *(char **) COBJECT_VALUE (oop1);
- if (addr == 0)
+ if (!cobject_index_check (oop1, arg2, sizeof (uintptr_t)))
+ goto fail;
+
+ ofs = *(uintptr_t *) (((char *)cobject_value (oop1)) + arg2);
+ baseOOP = _gst_nil_oop;
+ if (ofs == 0)
{
- PUSH_OOP (_gst_nil_oop);
+ SET_STACKTOP (_gst_nil_oop);
PRIM_SUCCEEDED;
}
}
else
- addr = COBJECT_VALUE (oop1);
-
- addr += arg2; /* compute effective address */
+ {
+ /* No need to enforce bounds here (if we ever will, remember
+ that a pointer that is one-past the end of the object is
+ valid!). */
+
+ gst_cobject cObj = (gst_cobject) OOP_TO_OBJ (oop1);
+ baseOOP = cObj->storage;
+ ofs = COBJECT_OFFSET_OBJ (cObj) + arg2;
+ }
- /* oop3 could get GC'ed out of existence before it gets used:
- it is not on the stack, and _gst_c_object_new could cause a GC */
- inc_ptr incPtr;
+ /* oop3 could get GC'ed out of existence before it gets used: it is
+ not on the stack, and _gst_c_object_new_base could cause a GC */
incPtr = INC_SAVE_POINTER ();
+ INC_ADD_OOP (baseOOP);
INC_ADD_OOP (oop3);
- PUSH_OOP (_gst_c_object_new (addr, oop3, _gst_c_object_class));
+ SET_STACKTOP (_gst_c_object_new_base (baseOOP, ofs, oop3,
+ _gst_c_object_class));
INC_RESTORE_POINTER (incPtr);
PRIM_SUCCEEDED;
}
}
- UNPOP (3);
+
+ fail:
+ UNPOP (2);
PRIM_FAILED;
}
@@ -4522,13 +4539,12 @@ primitive VMpr_CObject_atPut [succeed,fail]
if (IS_INT (oop2) && IS_INT (oop4))
{
char *addr;
- intptr_t arg2;
- intptr_t arg4;
- arg2 = TO_INT (oop2);
- addr = COBJECT_VALUE (oop1);
+ intptr_t arg2 = TO_INT (oop2);
+ intptr_t arg4 = TO_INT (oop4);
+ if (!cobject_index_check (oop1, arg2, _gst_c_type_size (arg4)))
+ goto fail;
- addr += arg2; /* compute effective address */
- arg4 = TO_INT (oop4);
+ addr = ((char *) cobject_value (oop1)) + arg2;
switch (arg4)
{
case CDATA_CHAR: /* char */
@@ -4680,10 +4696,51 @@ primitive VMpr_CObject_atPut [succeed,fail]
}
}
+ fail:
UNPOP (3);
PRIM_FAILED;
}
+/* CObject address */
+primitive VMpr_CObject_address [succeed]
+{
+ OOP oop1;
+ gst_cobject cObj;
+ uintptr_t ptr;
+ _gst_primitives_executed++;
+
+ oop1 = STACKTOP ();
+ cObj = (gst_cobject) OOP_TO_OBJ (oop1);
+ ptr = (uintptr_t) COBJECT_OFFSET_OBJ (cObj);
+
+ if (IS_NIL (cObj->storage))
+ SET_STACKTOP (FROM_C_ULONG (ptr));
+ else
+ SET_STACKTOP (FROM_C_LONG (ptr));
+}
+
+
+/* CObject address: */
+primitive VMpr_CObject_addressColon [succeed, fail]
+{
+ OOP oop1, oop2;
+ gst_cobject cObj;
+ _gst_primitives_executed++;
+
+ oop2 = POP_OOP ();
+ oop1 = STACKTOP ();
+ cObj = (gst_cobject) OOP_TO_OBJ (oop1);
+
+ if (IS_NIL (cObj->storage) ? IS_C_ULONG (oop2) : IS_C_LONG (oop2))
+ {
+ SET_COBJECT_OFFSET_OBJ (cObj, TO_C_LONG (oop2));
+ PRIM_SUCCEEDED;
+ }
+
+ UNPOP (1);
+ PRIM_FAILED;
+}
+
/* CString replaceWith: aString */
primitive VMpr_CString_replaceWith [succeed,fail]
{
@@ -4706,7 +4763,7 @@ primitive VMpr_CString_replaceWith [succeed,fail]
srcBase = STRING_OOP_CHARS (oop2);
srcLen = NUM_INDEXABLE_FIELDS (oop2);
- dstBase = *(gst_uchar **) COBJECT_VALUE (oop1);
+ dstBase = *(gst_uchar **) cobject_value (oop1);
memcpy (dstBase, srcBase, srcLen);
dstBase[srcLen] = '\0'; /* since it's a CString type, we NUL
term it */
@@ -4731,7 +4788,7 @@ primitive VMpr_ByteArray_fromCData_size [succeed,fail]
{
intptr_t arg3 = TO_INT (oop3);
OOP byteArrayOOP =
- _gst_byte_array_new (COBJECT_VALUE (oop2), arg3);
+ _gst_byte_array_new (cobject_value (oop2), arg3);
SET_STACKTOP (byteArrayOOP);
PRIM_SUCCEEDED;
}
@@ -4754,7 +4811,7 @@ primitive VMpr_String_fromCData_size [succeed,fail]
{
intptr_t arg3 = TO_INT (oop3);
OOP stringOOP =
- _gst_counted_string_new (COBJECT_VALUE (oop2), arg3);
+ _gst_counted_string_new (cobject_value (oop2), arg3);
SET_STACKTOP (stringOOP);
PRIM_SUCCEEDED;
}
@@ -4772,7 +4829,7 @@ primitive VMpr_String_fromCData [succeed]
oop2 = POP_OOP ();
oop1 = STACKTOP ();
- stringOOP = _gst_string_new (COBJECT_VALUE (oop2));
+ stringOOP = _gst_string_new (cobject_value (oop2));
SET_STACKTOP (stringOOP);
PRIM_SUCCEEDED;
}
@@ -4795,7 +4852,7 @@ primitive VMpr_String_ByteArray_asCData :
PTR data = xmalloc (size);
if (data)
{
- OOP cObjectOOP = _gst_c_object_new (data, oop2, _gst_c_object_class);
+ OOP cObjectOOP = COBJECT_NEW (data, oop2, _gst_c_object_class);
memcpy (data, OOP_TO_OBJ (oop1)->data, size);
POP_OOP ();
SET_STACKTOP (cObjectOOP);
diff --git a/packages/cairo/CairoContext.st b/packages/cairo/CairoContext.st
index 138d590..40ada84 100644
--- a/packages/cairo/CairoContext.st
+++ b/packages/cairo/CairoContext.st
@@ -772,11 +772,9 @@ CairoContextProvider subclass: CairoContext [
in particular, affects the advance and not the extent."
<category: 'text'>
| ext |
- ext := CairoTextExtents new.
- ^[
- Cairo textExtents: context utf8: aString extents: ext.
- TextExtents from: ext
- ] ensure: [ ext free ]
+ ext := CairoTextExtents gcNew.
+ Cairo textExtents: context utf8: aString extents: ext.
+ ^TextExtents from: ext
]
].
diff --git a/packages/cairo/CairoTransform.st b/packages/cairo/CairoTransform.st
index 627fe92..2321ac9 100644
--- a/packages/cairo/CairoTransform.st
+++ b/packages/cairo/CairoTransform.st
@@ -41,11 +41,6 @@ CStruct subclass: CairoMatrix [
<category: 'Cairo-C interface'>
- CairoMatrix class >> new [
- <category: 'instance creation'>
- ^ super new addToBeFinalized
- ]
-
initIdentity [
<category: 'initialize'>
Cairo matrixInitIdentity: self.
@@ -53,20 +48,16 @@ CStruct subclass: CairoMatrix [
withPoint: aPoint do: block [
<category: 'using'>
- | ox oy |
- ox := CDouble value: aPoint x.
- oy := CDouble value: aPoint y.
- ^ [
- block value:self value:ox value: oy
- ] ensure: [
- ox ifNotNil: [ :x | x free ].
- oy ifNotNil: [ :y | y free ]].
+ ^block
+ value: self
+ value: (CDoubleType gcValue: aPoint x)
+ value: (CDoubleType gcValue: aPoint y)
]
copy [
<category: 'copying'>
| shiny |
- shiny := CairoMatrix new.
+ shiny := CairoMatrix gcNew.
Cairo matrixInit: shiny
xx: self xx value
yx: self yx value
@@ -340,7 +331,7 @@ Transform subclass: MatrixTransform [
"Initialize the receiver so that it represents the identity transform."
<category: 'initialize'>
- matrix := CairoMatrix new initIdentity.
+ matrix := CairoMatrix gcNew initIdentity.
]
accept: aVisitor [
diff --git a/packages/sdl/libsdl/Display.st b/packages/sdl/libsdl/Display.st
index 8b0262d..6177fbb 100644
--- a/packages/sdl/libsdl/Display.st
+++ b/packages/sdl/libsdl/Display.st
@@ -245,13 +245,12 @@ as the destination for a Cairo surface.'>
<category: 'drawing-SDL'>
| r |
- r := SDL.SdlRect new.
- [r x value: aRect left.
+ r := SDL.SdlRect gcNew.
+ r x value: aRect left.
r y value: aRect top.
r w value: aRect width.
r h value: aRect height.
- SdlVideo sdlFillRect: surface dstRect: r color: aColorNumber ]
- ensure: [ r free ]
+ SdlVideo sdlFillRect: surface dstRect: r color: aColorNumber
]
critical: aBlock [
diff --git a/tests/cobjects.ok b/tests/cobjects.ok
index 51a8578..ac3b504 100644
--- a/tests/cobjects.ok
+++ b/tests/cobjects.ok
@@ -97,3 +97,27 @@ returned value is StructB
Execution begins...
returned value is StructB
+
+Execution begins...
+8
+4369
+8738
+ByteArray (0 0 17 17 34 34 51 51 )
+ error: Invalid argument 8: offset out of range
+returned value is nil
+
+Execution begins...
+ error: Invalid argument -1: offset out of range
+returned value is nil
+
+Execution begins...
+ error: Invalid argument 7: offset out of range
+returned value is nil
+
+Execution begins...
+4369
+ error: Invalid argument 8: offset out of range
+returned value is nil
+
+Execution begins...
+returned value is true
diff --git a/tests/cobjects.st b/tests/cobjects.st
index 798be65..7435e6b 100644
--- a/tests/cobjects.st
+++ b/tests/cobjects.st
@@ -132,5 +132,47 @@ Eval [
^StructD new b elementType cObjectType
]
+
+"test some GCed CObjects."
+Eval [
+ cObject := (CShortType arrayType: 4) gcNew.
+ cObject storage size printNl.
+ cObject at: 1 put: 16r1111.
+ cObject at: 2 put: 16r2222.
+ cObject decr.
+ (cObject at: 2) printNl.
+ (cObject at: 3) printNl.
+ cObject at: 4 put: 16r3333.
+ cObject storage printNl.
+ cObject at: 5 put: 16rDEAD.
+]
+
+"test partly out of bound accesses"
+Eval [
+ cObject := (CShortType arrayType: 4) gcNew.
+ cObject adjPtrBy: 7.
+ cObject at: -4
+]
+
+Eval [
+ cObject := (CShortType arrayType: 4) gcNew.
+ cObject adjPtrBy: 7.
+ cObject at: 0
+]
+
+Eval [
+ cObject := (CShortType arrayType: 4) gcNew.
+ cIntObject := (cObject + 2) castTo: CIntType.
+ cIntObject value: 16r11111111.
+ (cObject at: 2) printNl.
+ cIntObject at: 1
+]
+
+Eval [
+ cObject := CCharType gcNew.
+ nil testCObjectPtr: cObject.
+ ^cObject isAbsolute "must be true"
+]
+
" ### need a lot more!"
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Help-smalltalk] [PATCH] Garbage-collected CObjects,
Paolo Bonzini <=