Smalltalk › Gnu

[PATCH] Garbage-collected CObjects

‹ Previous Topic Next Topic ›
 
classic Classic list List threaded Threaded
♦
♦
 1 message Options
Paolo Bonzini-2
Reply | Threaded
Open this post in threaded view
♦
♦
|

[PATCH] Garbage-collected CObjects

Paolo Bonzini-2
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  <[hidden email]>

        * 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  <[hidden email]>

        * 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  <[hidden email]>

        * CairoContext.st: Use GCed CStructs.
        * CairoTransform.st: Use GCed CStructs.

packages/sdl/libsdl:
2008-05-06  Paolo Bonzini  <[hidden email]>

        * 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
 @code{C@var{mumble}}.  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 @code{@var{type}
-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
+@code{malloc}ed 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:
+@itemize
+@item creating an instance with @code{@var{class} new} initializes
+  the pointer to @code{NULL};
+
+@item doing @code{@var{type} new}, where @var{type} is a @code{CType}
+  subclass instance, allocates a new instance with @code{malloc}.
+
+@item doing @code{@var{type} gcNew}, where @var{type} is a @code{CType}
+  subclass instance, allocates a new instance backed by garbage-collected
+  storage.
+
+@end itemize
+
+@code{CStruct} and @code{CUnion} subclasses are special.  First,
+@code{new} 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.
+
+@code{CObject}s created by the C callout mechanism are never backed by
+garbage-collected storage.
+
+@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.
 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
-@code{value:} message.  Non-scalars do not support these two messages.
-
-@code{replaceWith:} @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
+@code{value} 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
+@code{CPtr}s 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
-@code{long}.
+@code{CPtr}'s @code{value} and @code{value:} method get or change
+the underlying value that's pointed to.  @code{value} returns another
+@code{CObject} 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}.
+
+@code{CString} is a subclass of @code{CPtr} 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:}.  @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 @code{CObject}@footnote{Actually 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!"
 

_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk
Free forum by Nabble Edit this page