[PATCH] revamp CTypes, part 1, and some questions
Locked
[PATCH] revamp CTypes, part 1, and some questions
 
|
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 * looking for [hidden email]--2004b/smalltalk--devo--2.2--patch-512 to compare with * auto-adding [hidden email]--2004b/smalltalk--devo--2.2--patch-512 to greedy revision library /Users/bonzinip/Archives/revlib * found immediate ancestor revision in library ([hidden email]--2004b/smalltalk--devo--2.2--patch-511) * patching for this revision ([hidden email]--2004b/smalltalk--devo--2.2--patch-512) * comparing to [hidden email]--2004b/smalltalk--devo--2.2--patch-512 _______________________________________________ help-smalltalk mailing list [hidden email] http://lists.gnu.org/mailman/listinfo/help-smalltalk |
Re: [PATCH] revamp CTypes, part 1, and some questions
|
|
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 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/[hidden email]--2004b/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/[hidden email]--2004b/patch-log/patch-513 * modified files --- orig/ChangeLog +++ mod/ChangeLog @@ -1,5 +1,17 @@ 2007-08-13 Paolo Bonzini <[hidden email]> + * 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 <[hidden email]> + * 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 <[hidden email]> + + * 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 <[hidden email]> * 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; } } _______________________________________________ help-smalltalk mailing list [hidden email] http://lists.gnu.org/mailman/listinfo/help-smalltalk |
«
Return to Gnu
|
1 view|%1 views
| Free forum by Nabble | Edit this page |