"======================================================================
|
|   C struct definition support classes.
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"


"======================================================================
|
| Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc.
| Written by Steve Byrne.
|
| This file is part of the GNU Smalltalk class library.
|
| The GNU Smalltalk class library is free software; you can redistribute it
| and/or modify it under the terms of the GNU Lesser General Public License
| as published by the Free Software Foundation; either version 2.1, or (at
| your option) any later version.
| 
| The GNU Smalltalk class library is distributed in the hope that it will be
| useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
| General Public License for more details.
| 
| You should have received a copy of the GNU Lesser General Public License
| along with the GNU Smalltalk class library; see the file COPYING.LESSER.
| If not, write to the Free Software Foundation, 59 Temple Place - Suite
| 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================"


CObject variableWordSubclass: #CStruct
      instanceVariableNames: ''
      classVariableNames: 'TypeMap'
      poolDictionaries: ''
      category: 'Language-C interface'
!



!Integer methodsFor: 'extension'!

alignTo: anInteger
    "Answer the receiver, truncated to the first higher or equal
     multiple of anInteger (which must be a power of two)"
    ^(self + anInteger - 1) bitClear: (anInteger - 1)
! !


!CStruct class methodsFor: 'instance creation'!

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
! !


!CStruct class methodsFor: 'subclass creation'!

initialize
    "Initialize the receiver's TypeMap"
    TypeMap := Dictionary 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: #string put: CStringType;
	at: #smalltalk put: CSmalltalkType;
	yourself
!

newStruct: structName declaration: array
    "Create a new class with the given name that contains code
     to implement the given C struct - see documentation for more
     information"

    | type name newClass offset maxAlignment str inspStr |
    newClass := CStruct variableWordSubclass: structName asSymbol
		       instanceVariableNames: ''
		       classVariableNames: ''
		       poolDictionaries: ''
		       category: 'Synthetic Class'.

    offset := 0.
    maxAlignment := 1.
    inspStr := WriteStream on: (String new: 8).
    inspStr nextPutAll: 'inspectSelectorList'; nl; nextPutAll: '    ^#('.

    "Iterate through each member, doing alignment, size calculations,
     and creating accessor methods"
    array do: [ :dcl |
	name := dcl at: 1.
	type := dcl at: 2.
	self emitInspectTo: inspStr for: name.

	self computeTypeString: type block: [ :size :alignment :typeString | 
	    offset := offset alignTo: alignment.

	    maxAlignment := alignment max: maxAlignment.

	    str := WriteStream on: (String new: 20).
	    str nextPutAll: name;
		nl;
		nextPutAll: '    ^self at: ';
		print: offset;
		nextPutAll: ' type: ';
		nextPutAll: typeString.
	    newClass compile: str classified: 'accessing'.
	    offset := offset + size
	]
    ].

    newClass compile: inspStr contents, ')' classified: 'debugging'.
    self compileSize: offset align: maxAlignment for: newClass.
!
			
computeAggregateType: type block: aBlock
    "Private - Called by computeTypeString:block: for pointers/arrays.
    Format of type:
    	(array int 3) or
    	(ptr FooStruct)
    "
    | structureType |
    " ### Should check for 2 or 3 elts only "
    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 |
    type class == Array
	ifTrue: [ ^self computeAggregateType: type block: aBlock ].

    "must be a type name, either built in or struct"

    typeInfo := TypeMap at: type ifAbsent: [ nil ].

    typeInfo notNil
	ifTrue: [ aBlock value: typeInfo sizeof
			 value: typeInfo alignof
			 value: typeInfo storeString
	]
	ifFalse: [ typeInfo := Smalltalk at: type.
		   aBlock value: typeInfo sizeof
			  value: typeInfo alignof
			  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: [ :size :alignment :typeString | 
	     aBlock value: size * numElts
		    value: alignment
		    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: [ :size :alignment :typeString | 
	     aBlock value: CPtr sizeof
		    value: CPtr alignof
		    value: '(CPtrCType elementType: ', typeString, ')'
    ]
!


compileSize: size align: alignment for: aClass
    "Private - Compile sizeof and alignof methods"
    | sizeofMethod alignofMethod |

    sizeofMethod :=  'sizeof
    ^', (size alignTo: alignment) printString.
    alignofMethod := 'alignof
    ^', (alignment printString).

    aClass compile: sizeofMethod classified: 'accessing'.
    aClass class compile: sizeofMethod classified: 'accessing'.

    aClass compile: alignofMethod classified: 'accessing'.
    aClass class compile: alignofMethod classified: 'accessing'.
!

emitInspectTo: str for: name
    "Private - Emit onto the given stream the code for adding the
     given selector to the CStruct's inspector."

    str nl;
	next: 8 put: Character space;
	nextPutAll: name
! !


!CStruct methodsFor: 'instance creation'!


inspectSelectorList
    "Answer a list of selectors whose return values should be inspected
     by #inspect."

    "We can't call subclassResponsibility because #inspect should never
     fail - it would lead to recursive walkbacks. So answer an empty
     array.
     For subclasses, it will answer an Array of the selectors whose
     values are to be shown in the inspector."
    ^#()
!
inspect
    "Inspect the contents of the receiver"
    "This inspect method applies to every instance of the receiver
     and their subclasses, which only override #inspectSelectorList."
    self printNl.
    self inspectSelectorList do: [ :each |
	Transcript
	   nextPutAll: '    ';
	   nextPutAll: each;
	   nextPutAll: ': ';
	   print: (self perform: each) value;
	   nl
    ].
! !

CStruct initialize!

