[PATCH] Add CType>>#from:

This is refactored out of CCompound (CStruct's abstract superclass).

Example:

st> (CType from: #{VFS.CStatStruct}) inspect
An instance of CType
   cObjectType: VFS.CStatStruct

st> (CType from: #(#ptr #{VFS.CStatStruct})) inspect
An instance of CPtrCType
   cObjectType: CPtr
   elementType: a CType

st> (CType from: #(#array #{VFS.CStatStruct} 2)) inspect
An instance of CArrayCType
   cObjectType: CArray
   elementType: a CType
   numElements: 2


Together with two overridden #storeOn: methods, it allows to improve the
code in CStruct too.

I also took the occasion to make the numbering of CFunctionDescriptor
members consistent with the numbering of the integer "type" parameter of
CObject primitives.

Paolo

* looking for [hidden email]--2004b/smalltalk--devo--2.2--patch-513 to compare with
* comparing to [hidden email]--2004b/smalltalk--devo--2.2--patch-513
M  kernel/CStruct.st
M  kernel/CType.st
M  kernel/CompildMeth.st
M  libgst/cint.c
M  libgst/cint.h
M  libgst/sym.c
M  libgst/sym.h
M  libgst/prims.def

* modified files

--- orig/kernel/CStruct.st
+++ mod/kernel/CStruct.st
@@ -34,7 +34,7 @@
 
 CObject variableWordSubclass: #CCompound
       instanceVariableNames: ''
-      classVariableNames: 'TypeMap'
+      classVariableNames: ''
       poolDictionaries: ''
       category: 'Language-C interface'
 !
@@ -76,29 +76,6 @@ new
 
 !CCompound class methodsFor: 'subclass creation'!
 
-initialize
-    "Initialize the receiver's TypeMap"
-    TypeMap := IdentityDictionary new
- at: #long put: #{CLongType};
- at: #uLong put: #{CULongType};
- at: #byte put: #{CByteType};
- at: #char put: #{CCharType};
- at: #uChar put: #{CUCharType};
- at: #uchar put: #{CUCharType};
- at: #short put: #{CShortType};
- at: #uShort put: #{CUShortType};
- at: #ushort put: #{CUShortType};
- at: #int put: #{CIntType};
- at: #uInt put: #{CUIntType};
- at: #uint put: #{CUIntType};
- at: #float put: #{CFloatType};
- at: #double put: #{CDoubleType};
- at: #longDouble put: #{CLongDoubleType};
- at: #string put: #{CStringType};
- at: #smalltalk put: #{CSmalltalkType};
- yourself
-!
-
 sizeof
     "Answer 0, the size of an empty struct"
     ^0
@@ -169,99 +146,30 @@ declaration: array inject: startOffset i
 
     "Iterate through each member, doing alignment, size calculations,
      and creating accessor methods"
-    array do: [ :dcl || type name |
+    array do: [ :dcl || typeDecl name str type |
  name := dcl at: 1.
- type := dcl at: 2.
+ typeDecl := dcl at: 2.
  self emitInspectTo: inspStr for: name.
 
- self computeTypeString: type block: [ :typeInfo :typeString |
-    | str |
-    offset := aBlock value: offset value: typeInfo alignof.
-    maxAlignment := typeInfo alignof max: maxAlignment.
-
-    str := WriteStream on: (String new: 20).
-    str nextPutAll: name;
- nl;
- nextPutAll: '    ^self at: ';
- print: offset;
- nextPutAll: ' type: ';
- nextPutAll: typeString.
-    self compile: str classified: 'accessing'.
-    offset := offset + typeInfo sizeof
- ]
+ type := CType from: typeDecl.
+ offset := aBlock value: offset value: type alignof.
+ maxAlignment := type alignof max: maxAlignment.
+
+ str := WriteStream on: (String new: 20).
+ str nextPutAll: name;
+    nl;
+    nextPutAll: '    ^self at: ';
+    print: offset;
+    nextPutAll: ' type: ';
+    store: type.
+ self compile: str classified: 'accessing'.
+ offset := offset + type sizeof
     ].
 
     self compile: inspStr contents, ')' classified: 'debugging'.
     self compileSize: offset align: maxAlignment
 !
 
-computeAggregateType: type block: aBlock
-    "Private - Called by computeTypeString:block: for pointers/arrays.
-    Format of type:
-     (array int 3) or
-     (ptr FooStruct)
-    "
-    | structureType |
-    structureType := type at: 1.
-    structureType == #array
- ifTrue: [ ^self computeArrayType: type block: aBlock ].
-    structureType == #ptr
- ifTrue: [ ^self computePtrType: type block: aBlock ].
-!
-
-computeTypeString: type block: aBlock
-    "Private - Pass the size, alignment, and description of CType for aBlock,
-    given the field description in `type' (the second element of each pair)."
-    | typeInfo typeString |
-    type class == Array
- ifTrue: [ ^self computeAggregateType: type block: aBlock ].
-
-    "must be a type name, either built in or struct, either a Symbol
-     or an Association"
-
-    type isSymbol ifFalse: [
- typeString := '#{%1} value type'
-    % { type value nameIn: Namespace current }.
-
- ^aBlock value: type value value: typeString.
-    ].
-
-    TypeMap at: type ifPresent: [ :binding |
- ^aBlock value: binding value value: binding key
-    ].
-
-    ^aBlock
- value: (Namespace current at: type)
- value: type, ' type'
-!
-
-
-computeArrayType: type block: aBlock
-    "Private - Called by computeAggregateType:block: for arrays"
-    | numElts elementType |
-    elementType := type at: 2.
-    numElts := type at: 3.
-    self computeTypeString: elementType
- block: [ :typeInfo :typeString |
-     aBlock value: (CArrayCType elementType: typeInfo
-    numberOfElements: numElts)
-    value: '(CArrayCType elementType: ', typeString,
-   ' numberOfElements: ', (numElts printString), ')'
- ]
-!
-
-computePtrType: type block: aBlock
-    "Private - Called by computeAggregateType:block: for pointers"
-    | subType |
-    subType := type at: 2.
-    self computeTypeString: subType
- block: [ :typeInfo :typeString |
-     aBlock value: CPtr
-    value: '(CPtrCType elementType: ', typeString, ')'
-    ]
-!
-
-
 compileSize: size align: alignment
     "Private - Compile sizeof and alignof methods"
     | sizeofMethod alignofMethod |


--- orig/kernel/CType.st
+++ mod/kernel/CType.st
@@ -35,7 +35,7 @@
 
 Object subclass: #CType
        instanceVariableNames: 'cObjectType'
-       classVariableNames: ''
+       classVariableNames: 'TypeMap'
        poolDictionaries: ''
        category: 'Language-C interface'
 !
@@ -85,11 +85,79 @@ CPtrCType subclass: #CArrayCType
 
 
 
+!CType class methodsFor: 'initialization'!
+
+initialize
+    "Initialize the receiver's TypeMap"
+    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).
+    Smalltalk at: #CUShortType   put: (CScalarCType cObjectType: CUShort).
+    Smalltalk at: #CLongType   put: (CScalarCType cObjectType: CLong).
+    Smalltalk at: #CULongType   put: (CScalarCType cObjectType: CULong).
+    Smalltalk at: #CIntType   put: (CScalarCType cObjectType: CInt).
+    Smalltalk at: #CUIntType   put: (CScalarCType cObjectType: CUInt).
+    Smalltalk at: #CSmalltalkType  put: (CScalarCType cObjectType: CSmalltalk).
+    Smalltalk at: #CFloatType   put: (CScalarCType cObjectType: CFloat).
+    Smalltalk at: #CDoubleType   put: (CScalarCType cObjectType: CDouble).
+    Smalltalk at: #CLongDoubleType put: (CScalarCType cObjectType: CLongDouble).
+    Smalltalk at: #CStringType   put: (CStringCType cObjectType: CString).
+    Smalltalk at: #CByteType   put: (CScalarCType cObjectType: CByte).
+    Smalltalk at: #CBooleanType   put: (CScalarCType cObjectType: CBoolean).
+    
+    TypeMap := IdentityDictionary new
+        at: #long put: CLongType;
+        at: #uLong put: CULongType;
+        at: #byte put: CByteType;
+        at: #char put: CCharType;
+        at: #uChar put: CUCharType;
+        at: #uchar put: CUCharType;
+        at: #short put: CShortType;
+        at: #uShort put: CUShortType;
+        at: #ushort put: CUShortType;
+        at: #int put: CIntType;
+        at: #uInt put: CUIntType;
+        at: #uint put: CUIntType;
+        at: #float put: CFloatType;
+        at: #double put: CDoubleType;
+        at: #longDouble put: CLongDoubleType;
+        at: #string put: CStringType;
+        at: #smalltalk put: CSmalltalkType;
+        yourself
+! !
+
 !CType class methodsFor: 'C instance creation'!
 
 cObjectType: aCObjectSubclassBinding
     "Create a new CType for the given subclass of CObject"
     ^self basicNew init: aCObjectSubclassBinding
+!
+
+from: type
+    "Private - Pass the size, alignment, and description of CType for aBlock,
+    given the field description in `type' (the second element of each pair)."
+    | typeInfo typeString |
+    type class == Array
+ ifTrue: [ ^self computeAggregateType: type ].
+
+    "must be a type name, either built in or struct, either a Symbol
+     or an Association"
+
+    type isSymbol ifFalse: [ ^type value type ].
+    ^TypeMap at: type ifAbsent: [ Namespace current at: type ]
+!
+
+computeAggregateType: type
+    "Private - Called by from: for pointers/arrays.
+    Format of type:
+     (#array #int 3) or
+     (#ptr #{FooStruct})
+    "
+    | structureType |
+    structureType := type at: 1.
+    structureType == #array ifTrue: [ ^CArrayCType from: type ].
+    structureType == #ptr ifTrue: [ ^CPtrCType from: type ].
 ! !
 
 
@@ -207,6 +275,13 @@ elementType
 
 !CPtrCType class methodsFor: 'instance creation'!
 
+computePtrType: type
+    "Private - Called by computeAggregateType: for pointers"
+    | subType typeInfo |
+    subType := type at: 2.
+    typeInfo := self from: subType.
+    ^self elementType: typeInfo!
+
 elementType: aCType
     "Answer a new instance of CPtrCType that maps pointers to the given CType"
     ^self new init: CPtr; elementType: aCType
@@ -227,6 +302,15 @@ new: size
     ^CObject alloc: elementType sizeof * size type: self
 ! !
 
+!CPtrCType methodsFor: 'storing'!
+
+storeOn: aStream
+    aStream
+ nextPutAll: '(CPtrCType elementType: ';
+ store: self elementType;
+ nextPut: $)
+! !
+
 !CPtrCType methodsFor: 'private'!
 
 elementType: aCType
@@ -238,6 +322,16 @@ elementType: aCType
 
 !CArrayCType class methodsFor: 'instance creation'!
 
+from: type
+    "Private - Called by CType>>from: for arrays"
+    | numElts elementType typeInfo |
+    elementType := type at: 2.
+    numElts := type at: 3.
+    typeInfo := self from: elementType.
+    ^self
+ elementType: typeInfo
+ numberOfElements: numElts!
+
 elementType: aCType
     self shouldNotImplement
 !
@@ -254,6 +348,17 @@ elementType: aCType numberOfElements: an
 ! !
 
 
+!CArrayCType methodsFor: 'storing'!
+
+storeOn: aStream
+    aStream
+ nextPutAll: '(CArrayCType elementType: ';
+ store: self elementType;
+ nextPutAll: ' numberOfElements: ';
+ store: numElements printString;
+ nextPut: $)
+! !
+
 !CArrayCType methodsFor: 'accessing'!
 
 sizeof
@@ -279,20 +384,4 @@ 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).
-Smalltalk at: #CUShortType put: (CScalarCType cObjectType: CUShort).
-Smalltalk at: #CLongType put: (CScalarCType cObjectType: CLong).
-Smalltalk at: #CULongType put: (CScalarCType cObjectType: CULong).
-Smalltalk at: #CIntType put: (CScalarCType cObjectType: CInt).
-Smalltalk at: #CUIntType put: (CScalarCType cObjectType: CUInt).
-Smalltalk at: #CSmalltalkType put: (CScalarCType cObjectType: CSmalltalk).
-Smalltalk at: #CFloatType put: (CScalarCType cObjectType: CFloat).
-Smalltalk at: #CDoubleType put: (CScalarCType cObjectType: CDouble).
-Smalltalk at: #CLongDoubleType put: (CScalarCType cObjectType: CLongDouble).
-Smalltalk at: #CStringType put: (CStringCType cObjectType: CString).
-Smalltalk at: #CByteType put: (CScalarCType cObjectType: CByte).
-Smalltalk at: #CBooleanType put: (CScalarCType cObjectType: CBoolean).
-!
+CType initialize!


--- orig/kernel/CompildMeth.st
+++ mod/kernel/CompildMeth.st
@@ -540,15 +540,19 @@ rewriteAsCCall: func for: aClass
     ^self rewriteAsCCall: func returning: #smalltalk args: args!
 
 rewriteAsCCall: func returning: returnType args: argsArray
-    | descr literals bytecodes newMethod |
+    | descr literals bytecodes newMethod returnCType |
     self isValidCCall
  ifFalse: [ ^'C call-out not empty' ].
     (CFunctionDescriptor isFunction: func)
  ifFalse: [ ^'C function not defined '].
 
+    returnCType := (returnType isSymbol or: [ returnType isKindOf: CType ])
+ ifTrue: [ returnType ]
+ ifFalse: [ (CType from: returnType) cObjStoredType ].
+
     descr := CFunctionDescriptor
  for: func
- returning: returnType
+ returning: returnCType
  withArgs: argsArray.
 
     "One of these:
@@ -561,9 +565,9 @@ rewriteAsCCall: func returning: returnTy
     bytecodes := #[ 136 1 45 0 30 34 67 0 ] ]
  ifFalse: [
     literals := { descr. #{ValueHolder}. }.
-    bytecodes := returnType isSymbol
- ifTrue: [ #[ 136 1 95 1 30 34 22 0 51 0 ] ]
- ifFalse: [ #[ 136 1 95 1 30 34 22 0 30 35 51 0 ] ] ].
+    bytecodes := (returnCType isKindOf: CType)
+ ifTrue: [ #[ 136 1 95 1 30 34 22 0 30 35 51 0 ] ]
+ ifFalse: [ #[ 136 1 95 1 30 34 22 0 51 0 ] ] ].
 
     newMethod := CompiledMethod
  literals: literals


--- orig/libgst/cint.c
+++ mod/libgst/cint.c
@@ -58,45 +58,6 @@
 #include "../libffi/include/ffi.h"
 #include <ltdl.h>
 
-typedef enum
-{ /* types for C parameters */
-  CDATA_UNKNOWN, /* when there is no type a priori */
-  CDATA_CHAR,
-  CDATA_STRING,
-  CDATA_STRING_OUT, /* for things that modify string params */
-  CDATA_SYMBOL,
-  CDATA_BYTEARRAY,
-  CDATA_BYTEARRAY_OUT,
-  CDATA_BOOLEAN,
-  CDATA_INT,
-  CDATA_UINT,
-  CDATA_LONG,
-  CDATA_ULONG,
-  CDATA_FLOAT,
-  CDATA_DOUBLE,
-  CDATA_LONG_DOUBLE,
-  CDATA_VOID, /* valid only as a return type */
-  CDATA_VARIADIC, /* for parameters, this param is an
-   array to be interpreted as
-   arguments.  Note that only simple
-   conversions are performed in this
-   case.  */
-  CDATA_VARIADIC_OOP, /* for parameters, this param is an
-   array whose elements are OOPs to be
-   passed.  */
-  CDATA_COBJECT, /* a C object is being passed */
-  CDATA_COBJECT_PTR, /* a C object pointer is being passed */
-  CDATA_OOP, /* no conversion to-from C (OOP) */
-  CDATA_SELF, /* pass self as the corresponding
-   argument */
-  CDATA_SELF_OOP, /* pass self as an OOP */
-  CDATA_WCHAR,
-  CDATA_WSTRING,
-  CDATA_WSTRING_OUT,
-  CDATA_SYMBOL_OUT
-}
-cdata_type;
-
 typedef struct symbol_type_map
 {
   OOP *symbol;
@@ -228,38 +189,46 @@ static cfunc_info *c_func_cur = NULL;
 
 /* printable names for corresponding C types */
 static const char *c_type_name[] = {
-  "void?", /* CDATA_UNKNOWN */
   "char", /* CDATA_CHAR */
+  "unsigned char", /* CDATA_UCHAR */
+  "short", /* CDATA_SHORT */
+  "unsigned short", /* CDATA_USHORT */
+  "long", /* CDATA_LONG */
+  "unsigned long", /* CDATA_ULONG */
+  "float", /* CDATA_FLOAT */
+  "double", /* CDATA_DOUBLE */
   "char *", /* CDATA_STRING */
+  "OOP", /* CDATA_OOP */
+  "int", /* CDATA_INT */
+  "unsigned int", /* CDATA_UINT */
+  "long double", /* CDATA_LONG_DOUBLE */
+
+  "void?", /* CDATA_UNKNOWN */
   "char *", /* CDATA_STRING_OUT */
   "char *", /* CDATA_SYMBOL */
   "char *", /* CDATA_BYTEARRAY */
   "char *", /* CDATA_BYTEARRAY_OUT */
   "int", /* CDATA_BOOLEAN */
-  "int", /* CDATA_INT */
-  "unsigned int", /* CDATA_UINT */
-  "long", /* CDATA_LONG */
-  "unsigned long", /* CDATA_ULONG */
-  "float", /* CDATA_FLOAT */
-  "double", /* CDATA_DOUBLE */
-  "long double", /* CDATA_LONG_DOUBLE */
   "void?", /* CDATA_VOID */
   "...", /* CDATA_VARIADIC */
   "...", /* CDATA_VARIADIC_OOP */
   "void *", /* CDATA_COBJECT -- this is misleading */
   "void **", /* CDATA_COBJECT_PTR */
-  "OOP", /* CDATA_OOP */
   "void?", /* CDATA_SELF */
   "OOP", /* CDATA_SELF_OOP */
   "wchar_t", /* CDATA_WCHAR */
   "wchar_t *", /* CDATA_WSTRING */
   "wchar_t *", /* CDATA_WSTRING_OUT */
+  "char *", /* CDATA_SYMBOL_OUT */
 };
 
 /* A map between symbols and the cdata_type enum.  */
 static const symbol_type_map type_map[] = {
   {&_gst_unknown_symbol, CDATA_UNKNOWN},
   {&_gst_char_symbol, CDATA_CHAR},
+  {&_gst_uchar_symbol, CDATA_UCHAR},
+  {&_gst_short_symbol, CDATA_SHORT},
+  {&_gst_ushort_symbol, CDATA_USHORT},
   {&_gst_string_symbol, CDATA_STRING},
   {&_gst_string_out_symbol, CDATA_STRING_OUT},
   {&_gst_symbol_symbol, CDATA_SYMBOL},
@@ -754,12 +723,17 @@ get_ffi_type (OOP returnTypeOOP)
 
     case CDATA_VOID:
     case CDATA_INT:
-    case CDATA_UINT:
     case CDATA_CHAR:
+    case CDATA_SHORT:
     case CDATA_WCHAR:
     case CDATA_BOOLEAN:
       return &ffi_type_sint;
 
+    case CDATA_UINT:
+    case CDATA_UCHAR:
+    case CDATA_USHORT:
+      return &ffi_type_uint;
+
    case CDATA_FLOAT:
      return &ffi_type_float;
 
@@ -860,11 +834,30 @@ push_smalltalk_obj (OOP oop,
 
         case CDATA_INT:
  case CDATA_UINT:
- case CDATA_CHAR:
   cp->u.intVal = TO_C_INT (oop);
   SET_TYPE (&ffi_type_sint);
   return;
 
+ case CDATA_CHAR:
+  cp->u.intVal = (char) TO_C_INT (oop);
+  SET_TYPE (&ffi_type_sint);
+  return;
+
+ case CDATA_UCHAR:
+  cp->u.intVal = (unsigned char) TO_C_INT (oop);
+  SET_TYPE (&ffi_type_sint);
+  return;
+
+ case CDATA_SHORT:
+  cp->u.intVal = (short) TO_C_INT (oop);
+  SET_TYPE (&ffi_type_sint);
+  return;
+
+ case CDATA_USHORT:
+  cp->u.intVal = (unsigned short) TO_C_INT (oop);
+  SET_TYPE (&ffi_type_sint);
+  return;
+
  case CDATA_DOUBLE:
           cp->u.doubleVal = (double) TO_C_LONG (oop);
   SET_TYPE (&ffi_type_double);
@@ -894,6 +887,9 @@ push_smalltalk_obj (OOP oop,
         case CDATA_INT:
  case CDATA_UINT:
  case CDATA_CHAR:
+ case CDATA_UCHAR:
+ case CDATA_SHORT:
+ case CDATA_USHORT:
  case CDATA_BOOLEAN:
   cp->u.intVal = (oop == _gst_true_oop);
   SET_TYPE (&ffi_type_sint);
@@ -902,7 +898,7 @@ push_smalltalk_obj (OOP oop,
     }
 
   else if ((class == _gst_char_class
-    && (cType == CDATA_CHAR || cType == CDATA_WCHAR))
+    && (cType == CDATA_CHAR || cType == CDATA_UCHAR || cType == CDATA_WCHAR))
            || (class == _gst_unicode_character_class && cType == CDATA_WCHAR))
     {
       cp->u.intVal = CHAR_OOP_VALUE (oop);
@@ -1027,16 +1023,28 @@ c_to_smalltalk (cparam *result, OOP retu
       resultOOP = char_new ((wchar_t) result->u.intVal);
       break;
 
+    case CDATA_UCHAR:
+      resultOOP = FROM_INT ((gst_uchar) result->u.intVal);
+      break;
+
     case CDATA_BOOLEAN:
       resultOOP = result->u.intVal ? _gst_true_oop : _gst_false_oop;
       break;
 
     case CDATA_INT:
-      resultOOP = FROM_C_INT ((long) result->u.intVal);
+      resultOOP = FROM_C_INT ((int) result->u.intVal);
       break;
 
     case CDATA_UINT:
-      resultOOP = FROM_C_INT ((long) result->u.intVal);
+      resultOOP = FROM_C_UINT ((unsigned int) result->u.intVal);
+      break;
+
+    case CDATA_SHORT:
+      resultOOP = FROM_INT ((short) result->u.intVal);
+      break;
+
+    case CDATA_USHORT:
+      resultOOP = FROM_INT ((unsigned short) result->u.intVal);
       break;
 
     case CDATA_LONG:


--- orig/libgst/cint.h
+++ mod/libgst/cint.h
@@ -56,6 +56,49 @@
 #ifndef GST_CINT_H
 #define GST_CINT_H
 
+typedef enum
+{ /* types for C parameters */
+  CDATA_CHAR,
+  CDATA_UCHAR,
+  CDATA_SHORT,
+  CDATA_USHORT,
+  CDATA_LONG,
+  CDATA_ULONG,
+  CDATA_FLOAT,
+  CDATA_DOUBLE,
+  CDATA_STRING,
+  CDATA_OOP, /* no conversion to-from C (OOP) */
+  CDATA_INT,
+  CDATA_UINT,
+  CDATA_LONG_DOUBLE,
+
+  CDATA_UNKNOWN, /* when there is no type a priori */
+  CDATA_STRING_OUT, /* for things that modify string params */
+  CDATA_SYMBOL,
+  CDATA_BYTEARRAY,
+  CDATA_BYTEARRAY_OUT,
+  CDATA_BOOLEAN,
+  CDATA_VOID, /* valid only as a return type */
+  CDATA_VARIADIC, /* for parameters, this param is an
+   array to be interpreted as
+   arguments.  Note that only simple
+   conversions are performed in this
+   case.  */
+  CDATA_VARIADIC_OOP, /* for parameters, this param is an
+   array whose elements are OOPs to be
+   passed.  */
+  CDATA_COBJECT, /* a C object is being passed */
+  CDATA_COBJECT_PTR, /* a C object pointer is being passed */
+  CDATA_SELF, /* pass self as the corresponding
+   argument */
+  CDATA_SELF_OOP, /* pass self as an OOP */
+  CDATA_WCHAR,
+  CDATA_WSTRING,
+  CDATA_WSTRING_OUT,
+  CDATA_SYMBOL_OUT
+}
+cdata_type;
+
 /* Value of errno which is checked by the Smalltalk base classes.  */
 extern int _gst_errno
   ATTRIBUTE_HIDDEN;


--- orig/libgst/prims.def
+++ mod/libgst/prims.def
@@ -3436,45 +3436,45 @@ primitive VMpr_Memory_at [succeed,fail]
       arg2 = TO_C_LONG (oop3);
       switch (arg1)
  {
- case 0: /* char */
- case 1: /* unsigned char */
+ case CDATA_CHAR: /* char */
+ case CDATA_UCHAR: /* unsigned char */
   PUSH_OOP (CHAR_OOP_AT (*(unsigned char *) arg2));
   PRIM_SUCCEEDED;
- case 2: /* short */
+ case CDATA_SHORT: /* short */
   PUSH_INT (*(short *) arg2);
   PRIM_SUCCEEDED;
- case 3: /* unsigned short */
+ case CDATA_USHORT: /* unsigned short */
   PUSH_INT (*(unsigned short *) arg2);
   PRIM_SUCCEEDED;
- case 4: /* long */
+ case CDATA_LONG: /* long */
   PUSH_OOP (FROM_C_LONG (*(long *) arg2));
   PRIM_SUCCEEDED;
- case 5: /* unsigned long */
+ case CDATA_ULONG: /* unsigned long */
   PUSH_OOP (FROM_C_ULONG (*(unsigned long *) arg2));
   PRIM_SUCCEEDED;
- case 6: /* float */
+ case CDATA_FLOAT: /* float */
   PUSH_OOP (floate_new (*(float *) arg2));
   PRIM_SUCCEEDED;
- case 7: /* double */
+ case CDATA_DOUBLE: /* double */
   PUSH_OOP (floatd_new (*(double *) arg2));
   PRIM_SUCCEEDED;
- case 8: /* string */
+ case CDATA_STRING: /* string */
   if (*(char **) arg2)
     PUSH_OOP (_gst_string_new (*(char **) arg2));
   else
     PUSH_OOP (_gst_nil_oop);
 
   PRIM_SUCCEEDED;
- case 9: /* OOP */
+ case CDATA_OOP: /* OOP */
   PUSH_OOP (*(OOP *) arg2);
   PRIM_SUCCEEDED;
- case 10: /* int */
+ case CDATA_INT: /* int */
   PUSH_OOP (FROM_C_INT (*(int *) arg2));
   PRIM_SUCCEEDED;
- case 11: /* unsigned int */
+ case CDATA_UINT: /* unsigned int */
   PUSH_OOP (FROM_C_UINT (*(unsigned int *) arg2));
   PRIM_SUCCEEDED;
- case 12: /* long double */
+ case CDATA_LONG_DOUBLE: /* long double */
   PUSH_OOP (floatq_new (*(long double *) arg2));
   PRIM_SUCCEEDED;
  }
@@ -3503,8 +3503,8 @@ primitive VMpr_Memory_atPut [succeed,fai
       arg2 = TO_C_LONG (oop3);
       switch (arg1)
  {
- case 0: /* char */
- case 1: /* unsigned char */
+ case CDATA_CHAR: /* char */
+ case CDATA_UCHAR: /* unsigned char */
   /* may want to use Character instead? */
   if (IS_CLASS (oop3, _gst_char_class)
       || (IS_CLASS (oop3, _gst_unicode_character_class)
@@ -3519,23 +3519,23 @@ primitive VMpr_Memory_atPut [succeed,fai
       PRIM_SUCCEEDED;
     }
   break;
- case 2: /* short */
- case 3: /* unsigned short */
+ case CDATA_SHORT: /* short */
+ case CDATA_USHORT: /* unsigned short */
   if (IS_INT (oop4))
     {
       *(short *) arg2 = (short) TO_INT (oop4);
       PRIM_SUCCEEDED;
     }
   break;
- case 4: /* long */
- case 5: /* unsigned long */
+ case CDATA_LONG: /* long */
+ case CDATA_ULONG: /* unsigned long */
   if (IS_C_LONG (oop4))
     {
       *(long *) arg2 = TO_C_LONG (oop4);
       PRIM_SUCCEEDED;
     }
   break;
- case 6: /* float */
+ case CDATA_FLOAT: /* float */
   if (IS_CLASS (oop4, _gst_floatd_class))
     {
       *(float *) arg2 = (float) FLOATD_OOP_VALUE (oop4);
@@ -3552,7 +3552,7 @@ primitive VMpr_Memory_atPut [succeed,fai
       PRIM_SUCCEEDED;
     }
   break;
- case 7: /* double */
+ case CDATA_DOUBLE: /* double */
   if (IS_CLASS (oop4, _gst_floatd_class))
     {
       *(double *) arg2 = FLOATD_OOP_VALUE (oop4);
@@ -3569,7 +3569,7 @@ primitive VMpr_Memory_atPut [succeed,fai
       PRIM_SUCCEEDED;
     }
   break;
- case 8: /* string */
+ case CDATA_STRING: /* string */
   if (IS_CLASS (oop4, _gst_string_class)
       || IS_CLASS (oop4, _gst_symbol_class))
     {
@@ -3579,18 +3579,18 @@ primitive VMpr_Memory_atPut [succeed,fai
       PRIM_SUCCEEDED;
     }
   break;
- case 9: /* OOP */
+ case CDATA_OOP: /* OOP */
   *(OOP *) arg2 = oop4;
   PRIM_SUCCEEDED;
- case 10: /* int */
- case 11: /* unsigned int */
+ case CDATA_INT: /* int */
+ case CDATA_UINT: /* unsigned int */
   if (IS_C_INT (oop4))
     {
       *(int *) arg2 = TO_C_INT (oop4);
       PRIM_SUCCEEDED;
     }
   break;
- case 12: /* long double */
+ case CDATA_LONG_DOUBLE: /* long double */
   if (IS_CLASS (oop4, _gst_floatd_class))
     {
       *(long double *) arg2 = (long double) FLOATD_OOP_VALUE (oop4);
@@ -4420,36 +4420,36 @@ primitive VMpr_CObject_at :
 
   switch (arg3)
     {
-    case 0:
-    case 1:
+    case CDATA_CHAR:
+    case CDATA_UCHAR:
       PUSH_OOP (CHAR_OOP_AT (*(gst_uchar *) addr));
       PRIM_SUCCEEDED;
 
-    case 2:
+    case CDATA_SHORT:
       PUSH_INT (*(short *) addr);
       PRIM_SUCCEEDED;
 
-    case 3:
+    case CDATA_USHORT:
       PUSH_INT (*(unsigned short *) addr);
       PRIM_SUCCEEDED;
 
-    case 4:
+    case CDATA_LONG:
       PUSH_OOP (FROM_C_LONG (*(long *) addr));
       PRIM_SUCCEEDED;
 
-    case 5:
+    case CDATA_ULONG:
       PUSH_OOP (FROM_C_ULONG (*(unsigned long *) addr));
       PRIM_SUCCEEDED;
 
-    case 6:
+    case CDATA_FLOAT:
       PUSH_OOP (floate_new (*(float *) addr));
       PRIM_SUCCEEDED;
 
-    case 7:
+    case CDATA_DOUBLE:
       PUSH_OOP (floatd_new (*(double *) addr));
       PRIM_SUCCEEDED;
 
-    case 8:
+    case CDATA_STRING:
       {
  char **strAddr;
  strAddr = (char **) addr;
@@ -4464,19 +4464,19 @@ primitive VMpr_CObject_at :
     PRIM_SUCCEEDED;
   }
       }
-    case 9:
+    case CDATA_OOP:
       PUSH_OOP (*(OOP *) addr);
       PRIM_SUCCEEDED;
 
-    case 10:
+    case CDATA_INT:
       PUSH_OOP (FROM_C_INT (*(int *) addr));
       PRIM_SUCCEEDED;
 
-    case 11:
+    case CDATA_UINT:
       PUSH_OOP (FROM_C_UINT (*(unsigned int *) addr));
       PRIM_SUCCEEDED;
 
-    case 12:
+    case CDATA_LONG_DOUBLE:
       PUSH_OOP (floatq_new (*(long double *) addr));
       PRIM_SUCCEEDED;
     }
@@ -4538,8 +4538,8 @@ primitive VMpr_CObject_atPut :
   arg4 = TO_INT (oop4);
   switch (arg4)
     {
-    case 0: /* char */
-    case 1: /* uchar */
+    case CDATA_CHAR: /* char */
+    case CDATA_UCHAR: /* uchar */
       if (IS_CLASS (oop3, _gst_char_class)
   || (IS_CLASS (oop3, _gst_unicode_character_class)
       && CHAR_OOP_VALUE (oop3) <= 127))
@@ -4554,8 +4554,8 @@ primitive VMpr_CObject_atPut :
  }
       break;
 
-    case 2: /* short */
-    case 3: /* ushort */
+    case CDATA_SHORT: /* short */
+    case CDATA_USHORT: /* ushort */
       if (IS_INT (oop3))
  {
   *(short *) addr = (short) TO_INT (oop3);
@@ -4563,8 +4563,8 @@ primitive VMpr_CObject_atPut :
  }
       break;
 
-    case 4: /* long */
-    case 5: /* ulong */
+    case CDATA_LONG: /* long */
+    case CDATA_ULONG: /* ulong */
       if (IS_C_LONG (oop3))
  {
   *(long *) addr = (long) TO_C_LONG (oop3);
@@ -4572,7 +4572,7 @@ primitive VMpr_CObject_atPut :
  }
       break;
 
-    case 6:
+    case CDATA_FLOAT:
       {
  float *floatAddr;
  floatAddr = (float *) addr;
@@ -4599,7 +4599,7 @@ primitive VMpr_CObject_atPut :
       }
       break;
 
-    case 7: /* double */
+    case CDATA_DOUBLE: /* double */
       {
  double *doubleAddr;
  doubleAddr = (double *) addr;
@@ -4626,7 +4626,7 @@ primitive VMpr_CObject_atPut :
       }
       break;
 
-    case 8: /* string */
+    case CDATA_STRING: /* string */
       { /* note that this does not allow for
    replacemnt in place */
  /* to replace in place, use replaceFrom: */
@@ -4649,12 +4649,12 @@ primitive VMpr_CObject_atPut :
  break;
       }
 
-    case 9:
+    case CDATA_OOP:
       *(OOP *) addr = oop3;
       PRIM_SUCCEEDED;
 
-    case 10: /* int */
-    case 11: /* uint */
+    case CDATA_INT: /* int */
+    case CDATA_UINT: /* uint */
       if (IS_C_INT (oop3))
  {
   *(int *) addr = (int) TO_C_INT (oop3);
@@ -4662,7 +4662,7 @@ primitive VMpr_CObject_atPut :
  }
       break;
 
-    case 12: /* long double */
+    case CDATA_LONG_DOUBLE: /* long double */
       {
  long double *longDoubleAddr;
  longDoubleAddr = (long double *) addr;


--- orig/libgst/sym.c
+++ mod/libgst/sym.c
@@ -128,6 +128,7 @@ OOP _gst_primitive_symbol = NULL;
 OOP _gst_repeat_symbol = NULL;
 OOP _gst_self_smalltalk_symbol = NULL;
 OOP _gst_self_symbol = NULL;
+OOP _gst_short_symbol = NULL;
 OOP _gst_smalltalk_symbol = NULL;
 OOP _gst_smalltalk_namespace_symbol = NULL;
 OOP _gst_start_execution_symbol = NULL;
@@ -142,8 +143,10 @@ OOP _gst_times_repeat_symbol = NULL;
 OOP _gst_to_by_do_symbol = NULL;
 OOP _gst_to_do_symbol = NULL;
 OOP _gst_true_symbol = NULL;
+OOP _gst_uchar_symbol = NULL;
 OOP _gst_uint_symbol = NULL;
 OOP _gst_ulong_symbol = NULL;
+OOP _gst_ushort_symbol = NULL;
 OOP _gst_undeclared_symbol = NULL;
 OOP _gst_unknown_symbol = NULL;
 OOP _gst_value_with_rec_with_args_symbol = NULL;
@@ -268,6 +271,7 @@ static const symbol_info sym_info[] = {
   {&_gst_c_object_ptr_symbol, "cObjectPtr"},
   {&_gst_category_symbol, "category:"},
   {&_gst_char_symbol, "char"},
+  {&_gst_uchar_symbol, "uChar"},
   {&_gst_does_not_understand_symbol, "doesNotUnderstand:"},
   {&_gst_float_symbol, "float"},
   {&_gst_double_symbol, "double"},
@@ -288,6 +292,8 @@ static const symbol_info sym_info[] = {
   {&_gst_repeat_symbol, "repeat"},
   {&_gst_self_symbol, "self"},
   {&_gst_self_smalltalk_symbol, "selfSmalltalk"},
+  {&_gst_short_symbol, "short"},
+  {&_gst_ushort_symbol, "uShort"},
   {&_gst_smalltalk_symbol, "smalltalk"},
   {&_gst_smalltalk_namespace_symbol, "Smalltalk"},
   {&_gst_start_execution_symbol, "startExecution:"},


--- orig/libgst/sym.h
+++ mod/libgst/sym.h
@@ -135,6 +135,8 @@ extern OOP _gst_primitive_symbol ATTRIBU
 extern OOP _gst_repeat_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_self_smalltalk_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_self_symbol ATTRIBUTE_HIDDEN;
+extern OOP _gst_short_symbol ATTRIBUTE_HIDDEN;
+extern OOP _gst_ushort_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_smalltalk_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_smalltalk_namespace_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_start_execution_symbol ATTRIBUTE_HIDDEN;
@@ -149,6 +151,7 @@ extern OOP _gst_times_repeat_symbol ATTR
 extern OOP _gst_to_by_do_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_to_do_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_true_symbol ATTRIBUTE_HIDDEN;
+extern OOP _gst_uchar_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_uint_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_ulong_symbol ATTRIBUTE_HIDDEN;
 extern OOP _gst_undeclared_symbol ATTRIBUTE_HIDDEN;




_______________________________________________
help-smalltalk mailing list
[hidden email]
http://lists.gnu.org/mailman/listinfo/help-smalltalk