[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Help-smalltalk] Re: [PATCH] revamp CTypes, part 1, and some questions
|
From: |
Paolo Bonzini |
|
Subject: |
[Help-smalltalk] Re: [PATCH] revamp CTypes, part 1, and some questions |
|
Date: |
Mon, 13 Aug 2007 11:54:51 +0200 |
|
User-agent: |
Thunderbird 2.0.0.6 (Macintosh/20070728) |
Paolo Bonzini wrote:
This is a refactoring that came out while looking at GDBM conversion.
The root problem is that there are forward references to a class in a
<cCall: ...> pragma. In the conversion of GDBM, we get
Object subclass: GDBM [
... [
<cCall: ... returning: DatumStruct type>
]
CStruct subclass: DatumStruct [
]
Pragma arguments are evaluated at compile-time, which breaks horribly
because DatumStruct is still undefined (and hence nil).
Now I'm tempted to break source-code compatibility. How?
1) Requiring DatumStruct to come first is not possible, because of
possible circular references. (It would work in this case though).
2) Changing "DatumStruct type" to "#{DatumStruct}" seems like a good
idea anyway. It would match the way types are referenced in CStructs,
and likewise, we could allow #(#ptr #{DatumStruct}) etc. Do you people
agree?
It would also be possible to add a hack into scripts/Convert.st in some
way to rewrite "DatumStruct type" into "#{DatumStruct}".
If anybody has an idea how to avoid this, please shoot.
Paolo
Here is the patch.
Paolo
* finding or making smalltalk--devo--2.2--patch-512
* finding or making smalltalk--devo--2.2--patch-513
* computing changeset
A
{arch}/smalltalk/smalltalk--devo/smalltalk--devo--2.2/address@hidden/patch-log/patch-513
M ChangeLog
M kernel/CObject.st
M kernel/CStruct.st
M kernel/CType.st
M libgst/ChangeLog
M libgst/callin.c
M libgst/cint.c
M libgst/dict.c
M libgst/dict.h
M libgst/dict.inl
M libgst/prims.def
* changeset report
* added files
{arch}/smalltalk/smalltalk--devo/smalltalk--devo--2.2/address@hidden/patch-log/patch-513
* modified files
--- orig/ChangeLog
+++ mod/ChangeLog
@@ -1,5 +1,17 @@
2007-08-13 Paolo Bonzini <address@hidden>
+ * kernel/CObject.st: Make #alloc:/#new: not a primitive. Add a
+ defaultType class-instance variable and make the class-side #type
+ default to it; the instance-side #type defaults to the class-side #type.
+ Always return aValue from #at:put:. Remove the instance-side
+ #scalarIndex and rename the class-side method to cObjStoredType.
+ Add missing CString class>>#cObjStoredType.
+ * kernel/CStruct.st: Remove #type override.
+ * kernel/CType.st: Adapt so that the binding is stored in the class
+ variable. Use the #cObjectType accessor consistently.
+
+2007-08-13 Paolo Bonzini <address@hidden>
+
* kernel/BindingDict.st: Use a different association than the
one in Undeclared, using #become: on it.
* kernel/WeakObjects.st: Fix wrong method comments.
--- orig/kernel/CObject.st
+++ mod/kernel/CObject.st
@@ -36,6 +36,8 @@ Object variableWordSubclass: #CObject
poolDictionaries: 'CSymbols'
category: 'Language-C interface'!
+CObject class instanceVariableNames: 'defaultType'!
+
CObject variableWordSubclass: #CScalar
instanceVariableNames: ''
classVariableNames: ''
@@ -191,14 +193,12 @@ subclass: aSymbol
alloc: nBytes
"Allocate nBytes bytes and return an instance of the receiver"
- <primitive: VMpr_CObject_alloc>
- ^SystemExceptions.WrongClass signalOn: nBytes mustBe: SmallInteger
+ ^self alloc: nBytes type: nil
!
new: nBytes
"Allocate nBytes bytes and return an instance of the receiver"
- <primitive: VMpr_CObject_alloc>
- ^SystemExceptions.WrongClass signalOn: nBytes mustBe: SmallInteger
+ ^self alloc: nBytes type: nil
!
alloc: nBytes type: cTypeObject
@@ -217,8 +217,7 @@ alloc: nBytes type: cTypeObject
address: anInteger
"Answer a new object pointing to the passed address, anInteger"
^(self basicNew: 1)
- address: anInteger;
- type: self scalarIndex
+ address: anInteger
!
new
@@ -229,14 +228,10 @@ new
!CObject class methodsFor: 'conversion'!
-scalarIndex
- "Nothing special in the default case - answer a CType for the receiver"
- ^CType cObjectType: self
-!
-
type
"Nothing special in the default case - answer a CType for the receiver"
- ^CType cObjectType: self
+ defaultType isNil ifTrue: [ defaultType := CType cObjectType: self ].
+ ^defaultType
! !
@@ -294,9 +289,10 @@ at: anIndex put: aValue
dereferencedType := self dereferencedType.
offset := anIndex * dereferencedType sizeof.
valueType := dereferencedType valueType.
- ^valueType isInteger
+ valueType isInteger
ifTrue: [ self at: offset put: aValue type: valueType ]
- ifFalse: [ (self at: offset type: dereferencedType) value: aValue ]
+ ifFalse: [ (self at: offset type: dereferencedType) value: aValue ].
+ ^aValue
!
incr
@@ -366,14 +362,10 @@ narrow
to specify the return type."
!
-scalarIndex
- "Nothing special in the default case - answer the receiver's CType"
- ^type
-!
-
type
"Answer a CType for the receiver"
- ^type
+ type isNil ifTrue: [ type := self class type ].
+ ^type
! !
@@ -404,6 +396,14 @@ type: aCType
! !
+!CObject class methodsFor: 'private'!
+
+cObjStoredType
+ "Private - Provide a conversion from a CObject to a Smalltalk object
+ to be stored by #at:put:"
+ ^nil
+! !
+
!CObject methodsFor: 'private'!
adjPtrBy: byteOffset
@@ -440,30 +440,38 @@ value: anObject
!
type
- "Answer a CType for the receiver - for example, CByteType if
+ "Answer a CType for the receiver---for example, CByteType if
the receiver is CByte."
^self environment at: (self name, 'Type') asGlobalKey
! !
+!CScalar class methodsFor: 'private'!
+
+cObjStoredType
+ "Private - Provide a conversion from a CObject to a Smalltalk object
+ to be stored by #at:put:"
+ self subclassResponsibility
+! !
+
!CScalar methodsFor: 'accessing'!
cObjStoredType
"Private - Provide a conversion from a CObject to a Smalltalk object
to be stored by #at:put:"
- ^self scalarIndex
+ self subclassResponsibility
!
value
"Answer the value the receiver is pointing to. The exact returned
value depends on the receiver's class"
- ^self at: 0 type: self scalarIndex
+ ^self at: 0 type: self cObjStoredType
!
value: aValue
"Set the receiver to point to the value, aValue. The exact meaning
of aValue depends on the receiver's class"
- self at: 0 put: aValue type: self scalarIndex
+ self at: 0 put: aValue type: self cObjStoredType
! !
@@ -480,7 +488,7 @@ alignof
^CPtrSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^9
! !
@@ -498,7 +506,7 @@ alignof
^CPtrSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^9
! !
@@ -517,7 +525,7 @@ alignof
^CLongSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^4
! !
@@ -535,7 +543,7 @@ alignof
^CLongSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^4
! !
@@ -554,7 +562,7 @@ alignof
^CLongSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^5
! !
@@ -571,7 +579,7 @@ alignof
^CLongSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^5
! !
@@ -589,7 +597,7 @@ alignof
^CIntSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^10
! !
@@ -607,7 +615,7 @@ alignof
^CIntSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^10
! !
@@ -626,7 +634,7 @@ alignof
^CIntSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^11
! !
@@ -645,7 +653,7 @@ alignof
^CIntSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^11
! !
@@ -665,7 +673,7 @@ alignof
^CShortSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^2
! !
@@ -684,7 +692,7 @@ alignof
^CShortSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^2
! !
@@ -703,7 +711,7 @@ alignof
^CShortSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^3
! !
@@ -721,7 +729,7 @@ alignof
^CShortSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^3
! !
@@ -741,7 +749,7 @@ alignof
^1
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^0
! !
@@ -774,7 +782,7 @@ alignof
^1
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^0
! !
@@ -795,7 +803,7 @@ alignof
^1
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^1
! !
@@ -812,7 +820,7 @@ alignof
^1
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^1
! !
@@ -832,7 +840,7 @@ alignof
^CFloatSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^6
! !
@@ -849,7 +857,7 @@ alignof
^CFloatSize
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^6
! !
@@ -869,7 +877,7 @@ alignof
^CDoubleAlignment
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^7
! !
@@ -886,7 +894,7 @@ alignof
^CDoubleAlignment
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^7
! !
@@ -904,7 +912,7 @@ alignof
^CLongDoubleAlignment
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's instances scalar
type"
^12
! !
@@ -921,7 +929,7 @@ alignof
^CLongDoubleAlignment
!
-scalarIndex
+cObjStoredType
"Private - Answer an index referring to the receiver's scalar type"
^12
! !
@@ -976,7 +984,7 @@ cObjStoredType
"If they want to store the receiver with #at:put:, they store the
address (of the first character) without dereferencing the pointer."
- ^CLong scalarIndex
+ ^CLong cObjStoredType
!
cObjStoredValue
@@ -1014,9 +1022,9 @@ value: anObject
or 64-bit address. If it is a CObject, its address is
stored."
anObject isInteger
- ifTrue: [ ^self at: 0 put: anObject type: CLong scalarIndex ].
+ ifTrue: [ ^self at: 0 put: anObject type: CLong cObjStoredType ].
- self at: 0 put: anObject address type: CLong scalarIndex
+ self at: 0 put: anObject address type: CLong cObjStoredType
! !
@@ -1038,12 +1046,20 @@ value: anObject
!
type
- "Answer a CType for the receiver - for example, CByteType if
+ "Answer a CType for the receiver---for example, CByteType if
the receiver is CByte."
^CStringType
! !
+!CString class methodsFor: 'accessing'!
+
+cObjStoredType
+ "Private - Provide a conversion from a CObject to a Smalltalk object
+ to be stored by #at:put:"
+ ^8
+! !
+
!CString methodsFor: 'accessing'!
cObjStoredType
@@ -1069,38 +1085,33 @@ value: aValue
!CByte class methodsFor: 'conversion'!
-scalarIndex
+cObjStoredType
"Nothing special in the default case - answer a CType for the receiver"
- ^CType cObjectType: self
+ ^self type
!
type
- "Nothing special in the default case - answer a CType for the receiver"
- ^CType cObjectType: self
+ "Answer a CType for the receiver"
+ ^CByteType
! !
!CByte methodsFor: 'accessing'!
-scalarIndex
+cObjStoredType
"Nothing special in the default case - answer the receiver's CType"
- ^type
-!
-
-type
- "Answer a CType for the receiver"
- ^type
+ ^self type
!
value
"Answer the value the receiver is pointing to. The returned value
is a SmallInteger"
- ^(self at: 0 type: super scalarIndex) value
+ ^(self at: 0 type: super cObjStoredType) value
!
value: aValue
"Set the receiver to point to the value, aValue (a SmallInteger)."
- self at: 0 put: aValue asCharacter type: super scalarIndex
+ self at: 0 put: aValue asCharacter type: super cObjStoredType
! !
--- orig/kernel/CStruct.st
+++ mod/kernel/CStruct.st
@@ -71,11 +71,6 @@ new
"Allocate a new instance of the receiver. To free the memory after
GC, remember to call #addToBeFinalized."
^self alloc: self sizeof
-!
-
-type
- "Answer a CType for the receiver"
- ^CType cObjectType: self
! !
--- orig/kernel/CType.st
+++ mod/kernel/CType.st
@@ -87,9 +87,9 @@ CPtrCType subclass: #CArrayCType
!CType class methodsFor: 'C instance creation'!
-cObjectType: aCObjectSubclass
+cObjectType: aCObjectSubclassBinding
"Create a new CType for the given subclass of CObject"
- ^self basicNew init: aCObjectSubclass
+ ^self basicNew init: aCObjectSubclassBinding
! !
@@ -104,7 +104,7 @@ new
address: cObjOrInt
"Create a new CObject with the type (class) identified by the receiver,
pointing to the given address (identified by an Integer or CObject)."
- ^(cObjectType basicNew: 1)
+ ^(self cObjectType basicNew: 1)
type: self;
address: (cObjOrInt isInteger
ifTrue: [ cObjOrInt ]
@@ -139,12 +139,12 @@ cObjectType
sizeof
"Answer the size of the receiver's instances"
- ^cObjectType sizeof
+ ^self cObjectType sizeof
!
alignof
"Answer the size of the receiver's instances"
- ^cObjectType alignof
+ ^self cObjectType alignof
!
valueType
@@ -181,7 +181,7 @@ init: aCObjectClass
storeOn: aStream
"Store Smalltalk code that compiles to the receiver"
aStream
- print: cObjectType;
+ print: self cObjectType;
nextPutAll: 'Type'
! !
@@ -191,7 +191,7 @@ valueType
"valueType is used as a means to communicate to the interpreter the
underlying type of the data. For scalars, it is supplied by the
CObject subclass."
- ^cObjectType scalarIndex
+ ^self cObjectType cObjStoredType
! !
@@ -279,6 +279,7 @@ numberOfElements: anInteger
! !
+Smalltalk at: #CObjectType put: (CType cObjectType: CObject).
Smalltalk at: #CCharType put: (CScalarCType cObjectType: CChar).
Smalltalk at: #CUCharType put: (CScalarCType cObjectType: CUChar).
Smalltalk at: #CShortType put: (CScalarCType cObjectType: CShort).
--- orig/libgst/ChangeLog
+++ mod/libgst/ChangeLog
@@ -1,3 +1,17 @@
+2007-08-13 Paolo Bonzini <address@hidden>
+
+ * libgst/callin.c: Use _gst_c_object_new instead of
+ _gst_c_object_new_typed.
+ * libgst/cint.c: Likewise.
+ * libgst/dict.inl: Likewise.
+ * libgst/dict.c: Remove _gst_c_object_type_ctype and _gst_c_type_new.
+ Add a new parameter to _gst_c_object_new_typed and call it
+ _gst_c_object_new; dereference the binding of the TYPEOOP.
+ Remove _gst_alloc_cobject.
+ * libgst/prims.def: Remove VMpr_CObject_alloc. Check receiver
+ type for VMpr_CObject_allocType. Use _gst_c_object_new instead of
+ _gst_c_object_new_typed.
+
2007-08-12 Paolo Bonzini <address@hidden>
* libgst/comp.c: Make literals read-only in make_oop_constant.
--- orig/libgst/callin.c
+++ mod/libgst/callin.c
@@ -260,7 +260,7 @@ _gst_va_msg_sendf (PTR resultPtr,
INC_ADD_OOP (ctype);
args[++i] =
- _gst_c_object_new_typed (va_arg (ap, PTR), ctype);
+ _gst_c_object_new (va_arg (ap, PTR), ctype, _gst_nil_oop);
INC_ADD_OOP (args[i]);
}
@@ -272,7 +272,7 @@ _gst_va_msg_sendf (PTR resultPtr,
OOP ctype;
ctype = va_arg (ap, OOP);
args[++i] =
- _gst_c_object_new_typed (va_arg (ap, PTR), ctype);
+ _gst_c_object_new (va_arg (ap, PTR), ctype, _gst_nil_oop);
INC_ADD_OOP (args[i]);
}
--- orig/libgst/cint.c
+++ mod/libgst/cint.c
@@ -1069,9 +1069,9 @@ c_to_smalltalk (cparam *result, OOP retu
else if (returnType == CDATA_COBJECT)
{
if (IS_INT (returnTypeOOP))
- resultOOP = COBJECT_NEW (result->u.ptrVal);
- else
- resultOOP = _gst_c_object_new_typed (result->u.ptrVal,
returnTypeOOP);
+ returnTypeOOP = _gst_nil_oop;
+ resultOOP = _gst_c_object_new (result->u.ptrVal, returnTypeOOP,
+ _gst_c_object_class);
}
else if (returnType == CDATA_STRING || returnType == CDATA_STRING_OUT)
{
--- orig/libgst/dict.c
+++ mod/libgst/dict.c
@@ -89,7 +89,6 @@ OOP _gst_byte_array_class = NULL;
OOP _gst_byte_stream_class = NULL;
OOP _gst_c_func_descriptor_class = NULL;
OOP _gst_c_object_class = NULL;
-OOP _gst_c_object_type_ctype = NULL;
OOP _gst_c_type_class = NULL;
OOP _gst_callin_process_class = NULL;
OOP _gst_char_class = NULL;
@@ -1002,8 +1001,6 @@ init_smalltalk_dictionary (void)
int i, numFeatures;
_gst_current_namespace = _gst_smalltalk_dictionary;
- _gst_c_object_type_ctype = _gst_c_type_new (_gst_c_object_class);
-
for (numFeatures = 0; feature_strings[numFeatures]; numFeatures++);
featuresArray = new_instance_with (_gst_array_class, numFeatures,
@@ -1017,7 +1014,6 @@ init_smalltalk_dictionary (void)
add_smalltalk ("Smalltalk", _gst_smalltalk_dictionary);
add_smalltalk ("Version", _gst_string_new (fullVersionString));
add_smalltalk ("KernelFilePath", _gst_string_new (_gst_kernel_file_path));
- add_smalltalk ("CObjectType", _gst_c_object_type_ctype);
add_smalltalk ("KernelInitialized", _gst_false_oop);
add_smalltalk ("SymbolTable", _gst_symbol_table);
add_smalltalk ("Processor", _gst_processor_oop);
@@ -1285,9 +1281,6 @@ _gst_init_dictionary_on_image_load (mst_
dictionary_at (_gst_class_variable_dictionary (_gst_namespace_class),
_gst_intern_string ("Current"));
- _gst_c_object_type_ctype = dictionary_at (_gst_smalltalk_dictionary,
- _gst_intern_string ("CObjectType"));
-
_gst_init_builtin_objects_classes ();
/* Important: this is called *after* _gst_init_symbols
@@ -2064,43 +2057,30 @@ _gst_message_new_args (OOP selectorOOP,
}
OOP
-_gst_c_object_new_typed (PTR cObjPtr,
- OOP typeOOP)
+_gst_c_object_new (PTR cObjPtr,
+ OOP typeOOP,
+ OOP defaultClassOOP)
{
gst_cobject cObject;
gst_ctype cType;
OOP cObjectOOP;
+ OOP classOOP;
- cType = (gst_ctype) OOP_TO_OBJ (typeOOP);
- cObject = (gst_cobject) new_instance_with (cType->cObjectType, 1,
- &cObjectOOP);
-
+ if (!IS_NIL (typeOOP))
+ {
+ cType = (gst_ctype) OOP_TO_OBJ (typeOOP);
+ classOOP = cType->cObjectType;
+ }
+ else
+ classOOP = defaultClassOOP;
+
+ cObject = (gst_cobject) new_instance_with (classOOP, 1, &cObjectOOP);
cObject->type = typeOOP;
SET_COBJECT_VALUE_OBJ (cObject, cObjPtr);
return (cObjectOOP);
}
-OOP
-_gst_alloc_cobject (OOP class_oop,
- size_t size)
-{
- PTR space;
- OOP typeOOP, cobjOOP;
- inc_ptr incPtr;
-
- space = (PTR) xmalloc ((int) size);
-
- incPtr = INC_SAVE_POINTER ();
- typeOOP = _gst_c_type_new (class_oop);
- INC_ADD_OOP (typeOOP);
-
- cobjOOP = _gst_c_object_new_typed (space, typeOOP);
-
- INC_RESTORE_POINTER (incPtr);
-
- return cobjOOP;
-}
void
_gst_free_cobject (OOP cObjOOP)
@@ -2114,17 +2094,6 @@ _gst_free_cobject (OOP cObjOOP)
SET_COBJECT_VALUE_OBJ (cObject, NULL);
}
-OOP
-_gst_c_type_new (OOP cObjectSubclassOOP)
-{
- gst_ctype cType;
- OOP cTypeOOP;
-
- cType = (gst_ctype) new_instance (_gst_c_type_class, &cTypeOOP);
- cType->cObjectType = cObjectSubclassOOP;
- return (cTypeOOP);
-}
-
void
_gst_set_file_stream_file (OOP fileStreamOOP,
int fd,
--- orig/libgst/dict.h
+++ mod/libgst/dict.h
@@ -504,21 +504,12 @@ extern OOP _gst_shared_pool_dictionary (
ATTRIBUTE_PURE
ATTRIBUTE_HIDDEN;
-/* Creates a new CObject pointing to cObjPtr, extracting the name of
- the class to be instantiated from the CType, TYPEOOP. */
-extern OOP _gst_c_object_new_typed (PTR cObjPtr,
- OOP typeOOP)
- ATTRIBUTE_HIDDEN;
-
-/* Allocates a new CObject by malloc-ing SIZE bytes; CLASS_OOP is the
- class to be instantiated. */
-extern OOP _gst_alloc_cobject (OOP class_oop,
- size_t size)
- ATTRIBUTE_HIDDEN;
-
-/* Creates a new CType that when passed to _gst_c_object_new_typed
- creates an instance of COBJECTSUBCLASSOOP. */
-extern OOP _gst_c_type_new (OOP cObjectSubclassOOP)
+/* Creates a new CObject pointing to cObjPtr, 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)
ATTRIBUTE_HIDDEN;
/* Creates a new String with LEN indexed instance variables. */
--- orig/libgst/dict.inl
+++ mod/libgst/dict.inl
@@ -295,7 +295,7 @@ static inline int64_t to_c_int_64 (OOP o
/* Answer a new CObject pointing to COBJPTR. */
#define COBJECT_NEW(cObjPtr) \
- (_gst_c_object_new_typed(cObjPtr, _gst_c_object_type_ctype))
+ (_gst_c_object_new(cObjPtr, _gst_nil_oop, _gst_c_object_class))
/* Answer the void * extracted from a CObject, COBJ (*not* an OOP,
but an object pointer). */
--- orig/libgst/prims.def
+++ mod/libgst/prims.def
@@ -3417,26 +3417,6 @@ primitive VMpr_SystemDictionary_setTrace
PRIM_FAILED;
}
-/* CObject class alloc: nBytes */
-
-primitive VMpr_CObject_alloc [succeed,fail]
-{
- OOP oop1;
- OOP oop2;
- _gst_primitives_executed++;
-
- oop2 = POP_OOP ();
- oop1 = STACKTOP ();
- if (IS_INT (oop2))
- {
- intptr_t arg2;
- arg2 = TO_INT (oop2);
- SET_STACKTOP (_gst_alloc_cobject (oop1, arg2));
- PRIM_SUCCEEDED;
- }
- UNPOP (1);
- PRIM_FAILED;
-}
/* Memory type: aType at: anAddress */
primitive VMpr_Memory_at [succeed,fail]
@@ -3919,18 +3899,22 @@ primitive VMpr_CObject_allocType [succee
{
OOP oop1;
OOP oop2;
+ OOP oop3;
_gst_primitives_executed++;
oop1 = POP_OOP ();
oop2 = POP_OOP ();
- if (IS_INT (oop2) && is_a_kind_of (OOP_CLASS (oop1), _gst_c_type_class))
+ oop3 = STACKTOP ();
+ if (IS_INT (oop2)
+ && (IS_NIL (oop1) || is_a_kind_of (OOP_CLASS (oop1), _gst_c_type_class))
+ && COMMON (RECEIVER_IS_A_KIND_OF (oop3, _gst_c_object_class)))
{
intptr_t arg2;
PTR ptr;
arg2 = TO_INT (oop2);
ptr = xmalloc (arg2);
- SET_STACKTOP (_gst_c_object_new_typed (ptr, oop1));
+ SET_STACKTOP (_gst_c_object_new (ptr, oop1, oop3));
PRIM_SUCCEEDED;
}
UNPOP (2);
@@ -4504,12 +4488,12 @@ primitive VMpr_CObject_at :
/* It's an oddball case, but it does seem possible that oop3
could get GC'ed out of existence before it gets used,
since oop3 is not on the stack, and if
- _gst_c_object_new_typed could cause a GC */
+ _gst_c_object_new could cause a GC */
inc_ptr incPtr;
incPtr = INC_SAVE_POINTER ();
INC_ADD_OOP (oop3);
- PUSH_OOP (_gst_c_object_new_typed (addr, oop3));
+ PUSH_OOP (_gst_c_object_new (addr, oop3, _gst_c_object_class));
INC_RESTORE_POINTER (incPtr);
PRIM_SUCCEEDED;
}
@@ -4827,8 +4811,10 @@ primitive VMpr_String_ByteArray_asCData
oop2 = POP_OOP ();
oop1 = STACKTOP ();
#ifndef OPTIMIZE
- if ((IS_CLASS (oop1, _gst_string_class) && id == prim_id
(VMpr_String_asCData))
- || (IS_CLASS (oop1, _gst_byte_array_class) && id == prim_id
(VMpr_ByteArray_asCData)))
+ if ((IS_CLASS (oop1, _gst_string_class)
+ && id == prim_id (VMpr_String_asCData))
+ || (IS_CLASS (oop1, _gst_byte_array_class)
+ && id == prim_id (VMpr_ByteArray_asCData)))
{
#endif
if (is_a_kind_of (OOP_CLASS (oop2), _gst_c_type_class))
@@ -4838,7 +4824,7 @@ primitive VMpr_String_ByteArray_asCData
if (data)
{
memcpy (data, OOP_TO_OBJ (oop1)->data, size);
- SET_STACKTOP (_gst_c_object_new_typed (data, oop2));
+ SET_STACKTOP (_gst_c_object_new (data, oop2,
_gst_c_object_class));
PRIM_SUCCEEDED;
}
}