FFI: FFI-Kernel-mt.97.mcz

Previous Topic Next Topic
 
classic Classic list List threaded Threaded
1 message Options
Reply | Threaded
Open this post in threaded view
|

FFI: FFI-Kernel-mt.97.mcz

commits-2
Marcel Taeumel uploaded a new version of FFI-Kernel to project FFI:
http://source.squeak.org/FFI/FFI-Kernel-mt.97.mcz

==================== Summary ====================

Name: FFI-Kernel-mt.97
Author: mt
Time: 6 June 2020, 2:13:30.360722 pm
UUID: 7fde178a-2872-0c4d-8966-2278e26c0178
Ancestors: FFI-Kernel-mt.96

- improves support for type aliasing (e.g. "typedef long ID;") implicitely via ExternalStructure and explicitely via ExternalTypeAlias
- cleans up and extends code for house keeping (i.e., recompile all on platform change); see #platformChangedFrom:to: and #resetAllStructureTypes
- cleans up code for field-spec compilation and field-accessor generation
- documents a bug in accessor generation for types aliasing pointer types (e.g. "typedef char* char_ptr;") via ExternalStructure >> #isNull
- speed up and fix :-) ExternalType >> #isTypeAlias and #originalType
- adds FFIObjectHandle as a wrapper to be used in external objects that alias another type; see its class comment; used in field-accessor generation
- adds support for pointer-type lookup in ExternalType class >> #typeNamed:

=============== Diff against FFI-Kernel-mt.96 ===============

Item was added:
+ ----- Method: ByteArray>>asByteArrayPointer (in category '*FFI-Kernel') -----
+ asByteArrayPointer
+ "Return a ByteArray describing a pointer to the contents of the receiver."
+ ^self shouldNotImplement!

Item was removed:
- ----- Method: ExternalData class>>compileFields (in category 'class initialization') -----
- compileFields
- "Ensure proper initialization of ExternalType when first loading"
- ExternalType initialize.
- ^super compileFields!

Item was added:
+ ----- Method: ExternalData class>>externalType (in category 'external type') -----
+ externalType
+ "Without having concrete external data, we can only tell that some void* will be in charge."
+
+ ^ ExternalType void asPointerType!

Item was changed:
  ----- Method: ExternalData class>>fields (in category 'field definition') -----
  fields
+ "Note: The definition is for completeness only. ExternalData is treated specially by the VM."
- "ExternalData defineFields"
- "Note: The definition is for completeness only.
- ExternalData is treated specially by the VM."
  ^#(nil 'void*')!

Item was added:
+ ----- Method: ExternalData class>>isTypeAlias: (in category 'type alias') -----
+ isTypeAlias: fieldSpec
+ "Technically, external data aliases atomic C types like arrays of atomic types (e.g., 'int[]') or pointer to atomic types (e.g., 'int *'). However, that's an implementation detail of FFI and not the same as actual aliases you can define for struct types."
+
+ ^ false!

Item was added:
+ ----- Method: ExternalData>>externalType (in category 'converting') -----
+ externalType
+
+ ^ type!

Item was changed:
+ ----- Method: ExternalData>>fromCString (in category 'converting') -----
- ----- Method: ExternalData>>fromCString (in category 'conversion') -----
  fromCString
  "Assume that the receiver represents a C string and convert it to a Smalltalk string. hg 2/25/2000 14:18"
 
  | stream index char |
  type isPointerType ifFalse: [self error: 'External object is not a pointer type.'].
  stream := WriteStream on: String new.
  index := 1.
  [(char := handle unsignedCharAt: index) = 0 asCharacter] whileFalse: [
  stream nextPut: char.
  index := index + 1].
  ^stream contents!

Item was changed:
+ ----- Method: ExternalData>>fromCStrings (in category 'converting') -----
- ----- Method: ExternalData>>fromCStrings (in category 'conversion') -----
  fromCStrings
  "Assume that the receiver represents a set of C strings and is teerminated by a empty string and convert it to a Smalltalk ordered collection of strings"
 
  | stream index char strings str |
  type isPointerType ifFalse: [self error: 'External object is not a pointer type.'].
  strings := OrderedCollection new.
  index := 1.
  [
  stream := WriteStream on: String new.
  [(char := handle unsignedCharAt: index) = 0 asCharacter]
  whileFalse: [
  stream nextPut: char.
  index := index + 1
  ].
  str := stream contents.
  strings addLast: str.
  str size = 0
  ] whileFalse.
  ^strings!

Item was added:
+ ----- Method: ExternalStructure class>>allStructuresInCompilationOrder (in category 'system startup') -----
+ allStructuresInCompilationOrder
+ "Answers a list of all known structure (and packed structures and unions) in ascending order of field compilation."
+
+ | unordered ordered |
+ self == ExternalStructure
+ ifFalse: [self error: 'Correct compilation order cannot be guaranteed for a partial list of structure classes.'].
+
+ unordered :=  self allSubclasses reject: [:ea | ea isSkipped].
+ ordered := OrderedCollection new: unordered size.
+
+ [unordered notEmpty] whileTrue:
+ [ | structClass prevStructClass references |
+ structClass := unordered anyOne.
+
+ [references := structClass referencedTypeNames.
+ prevStructClass := unordered detect: [:c | c ~~ structClass and: [references includes: c name]] ifNone: [nil].
+ prevStructClass isNil]
+ whileFalse: [structClass := prevStructClass].
+
+ "we found a structure/alias which does not depend on other structures/aliases"
+ ordered add: (unordered remove: structClass)].
+
+ ^ ordered!

Item was changed:
+ ----- Method: ExternalStructure class>>byteAlignment (in category 'external type') -----
- ----- Method: ExternalStructure class>>byteAlignment (in category 'field definition') -----
  byteAlignment
  ^ byteAlignment!

Item was changed:
+ ----- Method: ExternalStructure class>>byteSize (in category 'external type') -----
- ----- Method: ExternalStructure class>>byteSize (in category 'field definition') -----
  byteSize
  "Return the size in bytes of this structure."
  ^self compiledSpec first bitAnd: FFIStructSizeMask!

Item was removed:
- ----- Method: ExternalStructure class>>checkFieldLayoutChange (in category 'field definition') -----
- checkFieldLayoutChange
- "Recompile the spec and field accessors if the layout changed.
- Answer true if the layout changed.
- This is usefull at system startup if some structure are machine dependent.
- No provision is made for correct initialization order of nested structures.
- The correct order of invocation is left at upper responsibility."
-
- | newCompiledSpec oldCompiledSpec |
- oldCompiledSpec := compiledSpec.
- newCompiledSpec := self compileFields: self fields withAccessors: #never.
- oldCompiledSpec = newCompiledSpec ifTrue: [^false].
- "only regenerate the automatically generated fields: the others are under user responsibility"
- compiledSpec := self compileFields: self fields withAccessors: #generated.
- ExternalType noticeModificationOf: self.
- ^true!

Item was removed:
- ----- Method: ExternalStructure class>>compileAlias:withAccessors: (in category 'field definition') -----
- compileAlias: spec withAccessors: aSymbol
- "Define all the fields in the receiver.
- Return the newly compiled spec."
- | fieldName fieldTypeName isPointerField externalType newCompiledSpec |
- fieldName := spec first.
- fieldTypeName := spec second.
- isPointerField := fieldTypeName last = $*.
- fieldTypeName := fieldTypeName copyWithout: $*.
- externalType := (ExternalType typeNamed: fieldTypeName)
- ifNil: [self errorTypeNotFound: spec second].
- isPointerField ifTrue:[externalType := externalType asPointerType].
- (fieldName notNil and:[self shouldGenerate: fieldName policy: aSymbol]) ifTrue:[
- self defineAliasAccessorsFor: fieldName
- type: externalType].
- newCompiledSpec := isPointerField
- ifTrue:[WordArray with:
- (ExternalType structureSpec bitOr: ExternalType pointerSpec)]
- ifFalse:[externalType compiledSpec].
- byteAlignment := isPointerField
- ifTrue: [ExternalType pointerAlignment]
- ifFalse: [externalType byteAlignment].
- ^newCompiledSpec!

Item was changed:
+ ----- Method: ExternalStructure class>>compileAllFields (in category 'system startup') -----
- ----- Method: ExternalStructure class>>compileAllFields (in category 'field definition') -----
  compileAllFields
+ "
+ ExternalStructure compileAllFields
+ "
+ | priorAuthorInitials fieldSpec |
+ priorAuthorInitials := Utilities authorInitialsPerSe.
+ [Utilities setAuthorInitials: 'FFI'.
+
+ self allStructuresInCompilationOrder do: [:structClass |
+ fieldSpec := structClass fields.
+ self flag: #discuss. "mt: Why do we need that extra layout check? Performance gain is minimal..."
+ (structClass hasFieldLayoutChanged: fieldSpec)
+ ifTrue: [self compileFieldsSilently: fieldSpec].
+ structClass externalType "asNonPointerType"
+ compiledSpec: structClass compiledSpec;
+ byteAlignment: structClass byteAlignment].
+ "Compilation of fields only needs external types temporarily. Non-weak references to external types are only in methods with FFI calls."
+ ExternalType cleanupUnusedTypes.
+
+ ] ensure: [Utilities setAuthorInitials: priorAuthorInitials]!
- "ExternalStructure compileAllFields"
- self withAllSubclassesDo:[:cls|
- cls compileFields.
- ].!

Item was changed:
  ----- Method: ExternalStructure class>>compileFields (in category 'field definition') -----
  compileFields
+ "Public. Define all the fields in the receiver. Only re-generate changed field accessors if auto-generated in the first place."
+
+ self isSkipped ifTrue: [^ nil].
+ self compileFields: self fields.!
- "Compile the field definition of the receiver.
- Return the newly compiled spec."
- self isSkipped ifTrue: [^ self].
- ^self compileFields: self fields!

Item was changed:
  ----- Method: ExternalStructure class>>compileFields: (in category 'field definition') -----
  compileFields: fieldSpec
+ "Private. Use #compileFields."
+
+ self compileFieldsSilently: fieldSpec.
+ ExternalType noticeModificationOf: self.!
- "Compile the field definition of the receiver.
- Also regenerate auto-generated field accessors if their source changed.
- Return the newly compiled spec."
- compiledSpec := self compileFields: fieldSpec withAccessors: #generated.
- ExternalType noticeModificationOf: self.
- ^compiledSpec!

Item was changed:
  ----- Method: ExternalStructure class>>compileFields:withAccessors: (in category 'field definition') -----
  compileFields: specArray withAccessors: aSymbol
+ "Private. Use #compileFields or #defineFields. Compile a type specification for the FFI calls.
+
- "Compile a type specification for the FFI machinery.
- Return the newly compiled spec.
  Eventually generate the field accessors according to following rules:
  - aSymbol = #always always generate the accessors
  - aSymbol = #never never generate the accessors
  - aSymbol = #generated only generate the auto-generated accessors
  - aSymbol = #absent only generate the absent accessors"
- | newByteAlignment byteOffset typeSpec newCompiledSpec |
- (self isTypeAlias: specArray) ifTrue:
- [^ self compileAlias: specArray withAccessors: aSymbol].
- byteOffset := 0.
- newByteAlignment := self minStructureAlignment.
- typeSpec := WriteStream on: (WordArray new: 10).
- typeSpec nextPut: FFIFlagStructure.
- specArray do: [:spec |
- | fieldName fieldTypeName isPointerField externalType typeSize fieldAlignment |
- fieldName := spec first.
- fieldTypeName := spec second.
- isPointerField := fieldTypeName last = $*.
- fieldTypeName := (fieldTypeName findTokens: '*') first withBlanksTrimmed.
- externalType := (ExternalType typeNamed: fieldTypeName)
- ifNil: [self errorTypeNotFound: spec second].
- isPointerField ifTrue: [externalType := externalType asPointerType].
- typeSize := externalType byteSize.
- fieldAlignment := (externalType byteAlignment
- max: self minFieldAlignment)
- min: self maxFieldAlignment.
- byteOffset := byteOffset alignedTo: fieldAlignment.
- newByteAlignment := newByteAlignment max: fieldAlignment.
- spec size > 2 ifTrue: ["extra size"
- spec third < typeSize
- ifTrue: [^ self error: 'Explicit type size is less than expected'].
- typeSize := spec third.
- ].
- (fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
- self defineFieldAccessorsFor: fieldName startingAt: byteOffset + 1 type: externalType.
- ].
- typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
- byteOffset := byteOffset + typeSize.
- ].
 
+ (self isTypeAlias: specArray)
+ ifTrue: [self compileTypeAliasSpec: specArray withAccessors: aSymbol]
+ ifFalse: [self compileStructureSpec: specArray withAccessors: aSymbol]!
- newByteAlignment := newByteAlignment min: self maxStructureAlignment.
- byteOffset := byteOffset alignedTo: newByteAlignment.
- newCompiledSpec := typeSpec contents.
- newCompiledSpec at: 1 put: (byteOffset bitOr: FFIFlagStructure).
- byteAlignment := newByteAlignment.
- ^ newCompiledSpec!

Item was removed:
- ----- Method: ExternalStructure class>>compileFieldsSilently (in category 'field definition') -----
- compileFieldsSilently
-
- compiledSpec := self compileFields: self fields withAccessors: #generated.
- ^compiledSpec!

Item was added:
+ ----- Method: ExternalStructure class>>compileFieldsSilently: (in category 'field definition') -----
+ compileFieldsSilently: fieldSpec
+ "Private. Use #compileFields."
+
+ self compileFields: fieldSpec withAccessors: #generated.!

Item was added:
+ ----- Method: ExternalStructure class>>compileStructureSpec:withAccessors: (in category 'field definition - support') -----
+ compileStructureSpec: specArray withAccessors: aSymbol
+ "Compile a type specification for the FFI calls.
+ Return the newly compiled spec.
+
+ Eventually generate the field accessors according to following rules:
+ - aSymbol = #always always generate the accessors
+ - aSymbol = #never never generate the accessors
+ - aSymbol = #generated only generate the auto-generated accessors
+ - aSymbol = #absent only generate the absent accessors"
+
+ | newByteAlignment byteOffset typeSpec newCompiledSpec |
+ byteOffset := 0.
+ newByteAlignment := self minStructureAlignment.
+ typeSpec := WriteStream on: (WordArray new: 10).
+ typeSpec nextPut: FFIFlagStructure.
+ specArray do: [:spec |
+ | fieldName fieldTypeName externalType typeSize fieldAlignment |
+ fieldName := spec first.
+ fieldTypeName := spec second.
+ externalType := (ExternalType typeNamed: fieldTypeName)
+ ifNil: [self errorTypeNotFound: spec second].
+ typeSize := externalType byteSize.
+ fieldAlignment := (externalType byteAlignment
+ max: self minFieldAlignment)
+ min: self maxFieldAlignment.
+ byteOffset := byteOffset alignedTo: fieldAlignment.
+ newByteAlignment := newByteAlignment max: fieldAlignment.
+ spec size > 2 ifTrue: ["extra size"
+ spec third < typeSize
+ ifTrue: [^ self error: 'Explicit type size is less than expected'].
+ typeSize := spec third.
+ ].
+ (fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
+ self generateStructureFieldAccessorsFor: fieldName startingAt: byteOffset + 1 type: externalType.
+ ].
+ typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
+ byteOffset := byteOffset + typeSize.
+ ].
+ newByteAlignment := newByteAlignment min: self maxStructureAlignment.
+ byteOffset := byteOffset alignedTo: newByteAlignment.
+ newCompiledSpec := typeSpec contents.
+ newCompiledSpec at: 1 put: (byteOffset bitOr: FFIFlagStructure).
+ self
+ setCompiledSpec: newCompiledSpec
+ byteAlignment: newByteAlignment.!

Item was added:
+ ----- Method: ExternalStructure class>>compileTypeAliasSpec:withAccessors: (in category 'field definition - support') -----
+ compileTypeAliasSpec: spec withAccessors: aSymbol
+ "Define all the fields in the receiver.
+ Return the newly compiled spec."
+ | fieldName fieldTypeName externalType |
+ fieldName := spec first.
+ fieldTypeName := spec second.
+ externalType := (ExternalType typeNamed: fieldTypeName)
+ ifNil: [self errorTypeNotFound: spec second].
+ (fieldName notNil and:[self shouldGenerate: fieldName policy: aSymbol]) ifTrue:[
+ self generateTypeAliasAccessorsFor: fieldName type: externalType].
+ externalType isPointerType
+ ifTrue: ["Special case. Typedef for a pointer type, e.g., typedef char* LPSTR in Win32 API. Mark it as both structure and pointer. Note that #isPointerType will only answer true for the in-image pointer type, not the non-pointer alias for the pointer."
+ self
+ flag: #isTypeAliasToPointer;
+ setCompiledSpec: (WordArray with: (ExternalType structureSpec bitOr: ExternalType pointerSpec))
+ byteAlignment: ExternalType pointerAlignment]
+ ifFalse: ["Usual case. Typedef for another struct type. Just re-use compiled spec and extras from the aliased type."
+ self
+ flag: #isTypeAlias;
+ setCompiledSpec: externalType compiledSpec
+ byteAlignment: externalType byteAlignment].!

Item was changed:
+ ----- Method: ExternalStructure class>>compiledSpec (in category 'external type') -----
- ----- Method: ExternalStructure class>>compiledSpec (in category 'field definition') -----
  compiledSpec
  ^compiledSpec!

Item was removed:
- ----- Method: ExternalStructure class>>defineAliasAccessorsFor:type: (in category 'field definition') -----
- defineAliasAccessorsFor: fieldName type: type
- "Define read/write accessors for the given field"
- | code refClass argName |
- (type isVoid and:[type isPointerType not]) ifTrue:[^self].
- refClass := type referentClass.
- code := String streamContents:[:s|
- s
- nextPutAll: fieldName; crtab;
- nextPutAll:'"This method was automatically generated"'; crtab;
- nextPut: $<; nextPutAll: #generated; nextPut: $>; crtab.
- refClass == nil
- ifTrue:[(type isAtomic and:[type isPointerType not])
- ifTrue:[s nextPutAll:'^handle']
- ifFalse:[s nextPutAll:'^ExternalData fromHandle: handle'.
- type isPointerType ifTrue:[s nextPutAll:' asExternalPointer'].
- s nextPutAll:' type: ';
- nextPutAll: type asPointerType storeString]]
- ifFalse:[s nextPutAll:'^', refClass name,' fromHandle: handle'.
- type isPointerType ifTrue:[s nextPutAll:' asExternalPointer']]].
- self compile: code classified: 'accessing'.
-
- code := String streamContents:[:s|
- argName := refClass == nil
- ifTrue:[(type isAtomic and:[type isPointerType not])
- ifTrue:['anObject']
- ifFalse:['anExternalData']]
- ifFalse:['a',refClass name].
- s
- nextPutAll: fieldName,': '; nextPutAll: argName; crtab;
- nextPutAll:'"This method was automatically generated"'; crtab;
- nextPut: $<; nextPutAll: #generated; nextPut: $>; crtab.
- (refClass == nil and:[type isAtomic and:[type isPointerType not]])
- ifTrue:[s nextPutAll:'handle := ', argName]
- ifFalse:[s nextPutAll:'handle := ', argName,' getHandle'.
- type isPointerType ifTrue:[s nextPutAll:' asByteArrayPointer']]].
- self compile: code classified: 'accessing'.!

Item was added:
+ ----- Method: ExternalStructure class>>defineAllFields (in category 'system startup') -----
+ defineAllFields
+ "For convenience.
+ ExternalStructure defineAllFields
+ "
+ self allStructuresInCompilationOrder
+ do: [:structClass | structClass defineFields].!

Item was removed:
- ----- Method: ExternalStructure class>>defineFieldAccessorsFor:startingAt:type: (in category 'field definition') -----
- defineFieldAccessorsFor: fieldName startingAt: byteOffset type: type
- "Define read/write accessors for the given field"
- | comment |
- (type isVoid and: [type isPointerType not]) ifTrue:[^self].
- comment := String streamContents: [:strm |
- strm crtab; nextPutAll: '"This method was automatically generated. See '; nextPutAll: self class name; nextPutAll: '>>fields."'; crtab.
- strm nextPut: $<; nextPutAll: #generated; nextPut: $>; crtab.].
- self maybeCompileAccessor: fieldName, comment, (type readFieldAt: byteOffset)
- withSelector: fieldName asSymbol.
- self maybeCompileAccessor: fieldName,': anObject', comment, (type writeFieldAt: byteOffset with: 'anObject')
- withSelector: (fieldName, ':') asSymbol!

Item was changed:
  ----- Method: ExternalStructure class>>defineFields (in category 'field definition') -----
  defineFields
+ "Public. Define all the fields in the receiver. Always re-generate changed field accessors, even if not auto-generated in the first place."
+
+ self isSkipped ifTrue: [^ self].
- "Define all the fields in the receiver"
  self defineFields: self fields.!

Item was changed:
  ----- Method: ExternalStructure class>>defineFields: (in category 'field definition') -----
  defineFields: fieldSpec
+ "Private. Use #defineFields."
+
+ self compileFields: fieldSpec withAccessors: #always.
+ ExternalType noticeModificationOf: self.!
- "Define all the fields in the receiver"
- compiledSpec := self compileFields: fieldSpec withAccessors: #always.
- ExternalType noticeModificationOf: self.
- ^compiledSpec!

Item was changed:
+ ----- Method: ExternalStructure class>>errorTypeNotFound: (in category 'field definition - support') -----
- ----- Method: ExternalStructure class>>errorTypeNotFound: (in category 'field definition') -----
  errorTypeNotFound: typeName
 
  self error: ('Unknown external type ''{1}''. If it is a structure type, create a class for that structure first.' format: {typeName}).!

Item was changed:
+ ----- Method: ExternalStructure class>>externalType (in category 'external type') -----
- ----- Method: ExternalStructure class>>externalType (in category 'converting') -----
  externalType
  "Return an external type describing the receiver as a structure"
  ^ExternalType structTypeNamed: self name!

Item was added:
+ ----- Method: ExternalStructure class>>generateStructureFieldAccessorsFor:startingAt:type: (in category 'field definition - support') -----
+ generateStructureFieldAccessorsFor: fieldName startingAt: byteOffset type: type
+ "Define read/write accessors for the given field"
+ | comment argName |
+ (type isVoid and: [type isPointerType not]) ifTrue:[^self].
+ comment := String streamContents: [:strm |
+ strm crtab; nextPutAll: '"This method was automatically generated. See '; nextPutAll: self class name; nextPutAll: '>>fields."'; crtab.
+ strm nextPut: $<; nextPutAll: #generated; nextPut: $>; crtab.].
+ self maybeCompileAccessor: fieldName, comment, (type readFieldAt: byteOffset)
+ withSelector: fieldName asSymbol.
+
+ argName := type writeFieldArgName.
+
+ self maybeCompileAccessor: fieldName,': ', argName, comment, (type writeFieldAt: byteOffset with: argName)
+ withSelector: (fieldName, ':') asSymbol!

Item was added:
+ ----- Method: ExternalStructure class>>generateTypeAliasAccessorsFor:type: (in category 'field definition - support') -----
+ generateTypeAliasAccessorsFor: fieldName type: type
+ "Define read/write accessors for the given field"
+ | comment argName |
+ (type isVoid and:[type isPointerType not])
+ ifTrue:[^self error: 'Cannot read or write void fields'].
+
+ comment := String streamContents: [:strm |
+ strm crtab; nextPutAll: '"This method was automatically generated. See '; nextPutAll: self class name; nextPutAll: '>>fields."'; crtab.
+ strm nextPut: $<; nextPutAll: #generated; nextPut: $>; crtab.].
+
+ self
+ maybeCompileAccessor: fieldName, comment, type readAlias
+ withSelector: fieldName asSimpleGetter.
+
+ argName := type writeFieldArgName.
+ self
+ maybeCompileAccessor: fieldName, ': ', argName, comment, (type writeAliasWith: argName)
+ withSelector: fieldName asSimpleSetter.!

Item was added:
+ ----- Method: ExternalStructure class>>hasFieldLayoutChanged (in category 'system startup') -----
+ hasFieldLayoutChanged
+ "Answers whether all fields should be re-compiled (and hence accessors re-generated)."
+
+ ^ self hasFieldLayoutChanged: self fields!

Item was added:
+ ----- Method: ExternalStructure class>>hasFieldLayoutChanged: (in category 'system startup') -----
+ hasFieldLayoutChanged: fieldSpec
+ "Answers whether all fields should be re-compiled (and hence accessors re-generated). This is useful at system startup time if a platform change was detected, which can influence alignment and size of pointers.
+ !!!!!! Note that this method depends on all referenced types to be checked for field-layout changes first !!!!!!"
+
+ | oldCompiledSpec oldByteAlignment |
+ (oldCompiledSpec := self compiledSpec) ifNil: [^ true].
+ (oldByteAlignment := self byteAlignment) ifNil: [^ true].
+
+ self compileFields: fieldSpec withAccessors: #never.
+ self assert: [self isTypeAlias or: [oldCompiledSpec ~~ self compiledSpec]].
+
+ self flag: #bug. "mt: Changed type aliasing for pointers not noticed unless that alias hides a pointer type."
+ [^ oldCompiledSpec ~= self compiledSpec]
+ ensure: [
+ self
+ setCompiledSpec: oldCompiledSpec
+ byteAlignment: oldByteAlignment]!

Item was changed:
+ ----- Method: ExternalStructure class>>isTypeAlias (in category 'type alias') -----
- ----- Method: ExternalStructure class>>isTypeAlias (in category 'testing') -----
  isTypeAlias
 
  ^ self isTypeAlias: self fields!

Item was changed:
+ ----- Method: ExternalStructure class>>isTypeAlias: (in category 'type alias') -----
- ----- Method: ExternalStructure class>>isTypeAlias: (in category 'testing') -----
  isTypeAlias: specArray
  "Answer whether this structure is an alias for another C type, enum, etc."
  "Example: #( nil 'long' )"
 
  ^ (specArray size > 0 and: [specArray first class ~~ Array])!

Item was changed:
+ ----- Method: ExternalStructure class>>maybeCompileAccessor:withSelector: (in category 'field definition - support') -----
- ----- Method: ExternalStructure class>>maybeCompileAccessor:withSelector: (in category 'compiling') -----
  maybeCompileAccessor: aString withSelector: selector
  (self compiledMethodAt: selector ifAbsent: []) ifNotNil:
  [:existingMethod|
  existingMethod getSourceFromFile asString = aString ifTrue:
  [^self]].
  self compile: aString classified: #accessing!

Item was added:
+ ----- Method: ExternalStructure class>>originalTypeName (in category 'type alias') -----
+ originalTypeName
+
+ | fieldSpec |
+ fieldSpec := self fields.
+ (self isTypeAlias: fieldSpec)
+ ifFalse: [self error: 'This is not an alias.'].
+ ^ fieldSpec second!

Item was changed:
  ----- Method: ExternalStructure class>>platformChangedFrom:to: (in category 'system startup') -----
  platformChangedFrom: lastPlatform to: currentPlatform
  "The system is coming up on a new platform. Clear out the existing handles."
+ self compileAllFields.!
- self recompileStructures.!

Item was removed:
- ----- Method: ExternalStructure class>>recompileStructures (in category 'system startup') -----
- recompileStructures
- "Check and update the layout of all subclasses for host machine dependency.
- Arrange to check the inner nested structures first."
-
- "ExternalStructure recompileStructures"
- | sorted unsorted priorAuthorInitials |
- unsorted := self withAllSubclasses reject: [:ea | ea isSkipped].
- sorted := OrderedCollection new: unsorted size.
- self sortStructs: unsorted into: sorted.
- priorAuthorInitials := Utilities authorInitialsPerSe.
- Utilities setAuthorInitials: 'FFI'.
- [sorted do: [:struct | struct checkFieldLayoutChange ifFalse: [
- "Even if no layout change, communicate that result to the corresponding types."
- struct externalType
- compiledSpec: struct compiledSpec;
- byteAlignment: struct byteAlignment]]]
- ensure: [Utilities setAuthorInitials: priorAuthorInitials]!

Item was added:
+ ----- Method: ExternalStructure class>>referencedTypeNames (in category 'system startup') -----
+ referencedTypeNames
+ "Answer the set of type names my fields depend on, which can include names for pointer types, e.g., 'long*' or 'MyStruct*'."
+
+ | fieldSpec |
+ (fieldSpec := self fields) ifEmpty: [^ Set new].
+ (self isTypeAlias: fieldSpec) ifTrue: [^ Set with: self originalTypeName].
+ ^fieldSpec collect: [:e | e second] as: Set!

Item was added:
+ ----- Method: ExternalStructure class>>setCompiledSpec:byteAlignment: (in category 'external type') -----
+ setCompiledSpec: spec byteAlignment: alignment
+ "Store this structure's compiled spec and extras to be used when creating external types for this structure as required. See ExternalType class >> #newTypeNamed: and ExternalType >> #newReferentClass:."
+
+ compiledSpec := spec.
+ byteAlignment := alignment.!

Item was changed:
+ ----- Method: ExternalStructure class>>shouldGenerate:policy: (in category 'field definition - support') -----
- ----- Method: ExternalStructure class>>shouldGenerate:policy: (in category 'field definition') -----
  shouldGenerate: fieldname policy: aSymbol
  "Answer true if the field accessors must be compiled.
  Do so according to the following rules:
  - aSymbol = #always always generate the accessors
  - aSymbol = #never never generate the accessors
  - aSymbol = #generated only re-generate the auto-generated accessors
  - aSymbol = #absent only generate the absent accessors"
  aSymbol = #never ifTrue: [^ false].
  aSymbol = #always ifTrue: [^ true].
  aSymbol = #absent ifTrue: [^ (self methodDictionary includesKey: fieldname) not].
  aSymbol = #generated
  ifTrue: [^ (self methodDictionary includesKey: fieldname)
  and: [(self methodDictionary at: fieldname) pragmas
  anySatisfy: [:p | p keyword = #generated]]].
+ self error: 'unknown generation policy'!
- self error: 'unknow generation policy'!

Item was removed:
- ----- Method: ExternalStructure class>>sortStructs:into: (in category 'field definition') -----
- sortStructs: structureClasses into: sortedClasses
- "Sort the structure definitions so as to obtain a correct initialization order."
-
- [| structClass prevStructClass dependsOnOtherTypes |
- structureClasses isEmpty ifTrue: [^ self].
- structClass := structureClasses anyOne.
-
- [dependsOnOtherTypes := structClass typeNamesFromWhichIDepend.
- prevStructClass := structureClasses detect: [:c | c ~~ structClass and: [dependsOnOtherTypes includes: c name]] ifNone: [nil].
- prevStructClass isNil]
- whileFalse: [structClass := prevStructClass].
-
- "we found a structure/alias which does not depend on other structures/aliases
- add the corresponding class to the initialization list"
- sortedClasses add: (structureClasses remove: structClass)] repeat!

Item was removed:
- ----- Method: ExternalStructure class>>typeNamesFromWhichIDepend (in category 'field definition') -----
- typeNamesFromWhichIDepend
- "Answer the set of type names of my fields (including pointer stars)"
- | f |
- (f := self fields) isEmpty ifTrue: [^Set new].
- f first isArray ifFalse: [^Set with: f second].
- ^f collect: [:e | e second] as: Set!

Item was added:
+ ----- Method: ExternalStructure>>externalType (in category 'converting') -----
+ externalType
+
+ ^ self class externalType!

Item was added:
+ ----- Method: ExternalStructure>>isNull (in category 'testing') -----
+ isNull
+ self flag: #bug. "mt: We should not have (and use) #asByteArrayPointer and also think that #isNull cannot be implemented in ByteArray."
+
+ ^ super isNull or: [
+ self externalType isTypeAliasToPointer and: [
+ handle class == ByteArray
+ and: [ handle allSatisfy: [:byte | byte = 0 ]]]]!

Item was changed:
  Object subclass: #ExternalType
  instanceVariableNames: 'compiledSpec referentClass referencedType byteAlignment'
  classVariableNames: 'AtomicSelectors AtomicTypeNames AtomicTypes StructTypes'
  poolDictionaries: 'FFIConstants'
  category: 'FFI-Kernel'!
 
+ !ExternalType commentStamp: 'mt 6/5/2020 18:25' prior: 0!
- !ExternalType commentStamp: 'eem 6/25/2019 10:39' prior: 0!
  An external type represents the type of external objects.
 
  Instance variables:
  compiledSpec <WordArray> Compiled specification of the external type
  referentClass <Behavior | nil> Class type of argument required
  referencedType <ExternalType> Associated (non)pointer type with the receiver
- pointerSize <Integer | nil> The size of a pointer if the external type is a pointer or is a structure containing a pointer.
  byteAlignment <Integer | nil> The desired alignment for a field of the external type within a structure.  If nil it has yet to be computed.
 
  Compiled Spec:
  The compiled spec defines the type in terms which are understood by the VM. Each word is defined as:
  bits 0...15 - byte size of the entity
  bit 16 - structure flag (FFIFlagStructure)
   This flag is set if the following words define a structure
  bit 17 - pointer flag (FFIFlagPointer)
   This flag is set if the entity represents a pointer to another object
  bit 18 - atomic flag (FFIFlagAtomic)
   This flag is set if the entity represents an atomic type.
   If the flag is set the atomic type bits are valid.
  bits 19...23 - unused
  bits 24...27 - atomic type (FFITypeVoid ... FFITypeDoubleFloat)
  bits 28...31 - unused
 
  Note that all combinations of the flags FFIFlagPointer, FFIFlagAtomic, and FFIFlagStructure are invalid, EXCEPT from the following:
 
  FFIFlagPointer + FFIFlagAtomic:
  This defines a pointer to an atomic type (e.g., 'char*', 'int*').
  The actual atomic type is represented in the atomic type bits.
 
  FFIFlagPointer + FFIFlagStructure:
  This defines a structure which is a typedef of a pointer type as in
  typedef void* VoidPointer;
  typedef Pixmap* PixmapPtr;
  It requires a byte size of four or eight (e.g. a 32-bit or 64-bit pointer) to work correctly.
 
  [Note: Other combinations may be allowed in the future]
  !

Item was changed:
  ----- Method: ExternalType class>>atomicTypeNamed: (in category 'instance lookup') -----
+ atomicTypeNamed: typeName
+ "Supports pointer-type lookup such as for 'long*' and also 'long *'."
+
+ | isPointerType actualTypeName type |
+ (isPointerType := typeName endsWith: '*')
+ ifTrue: [actualTypeName := typeName allButLast withBlanksTrimmed]
+ ifFalse: [actualTypeName := typeName].
+ ^ (type := AtomicTypes at: actualTypeName ifAbsent: [nil])
+ ifNotNil: [isPointerType ifTrue: [type asPointerType] ifFalse: [type]]!
- atomicTypeNamed: aString
- ^AtomicTypes at: aString ifAbsent:[nil]!

Item was changed:
  ----- Method: ExternalType class>>cleanupUnusedTypes (in category 'housekeeping') -----
  cleanupUnusedTypes
  "ExternalType cleanupUnusedTypes"
  | value |
+ Smalltalk garbageCollect.
  StructTypes keys do:[:key|
  value := StructTypes at: key.
  value == nil ifTrue:[StructTypes removeKey: key ifAbsent:[]]].!

Item was changed:
  ----- Method: ExternalType class>>initializeDefaultTypes (in category 'class initialization') -----
  initializeDefaultTypes
  "ExternalType initialize"
  | type pointerType |
  AtomicTypes = nil ifTrue:[
  "Create new atomic types and setup the dictionaries"
  AtomicTypes := Dictionary new.
- StructTypes := WeakValueDictionary new.
  AtomicTypeNames valuesDo:[:k|
  type := self basicNew.
  pointerType := self basicNew.
  AtomicTypes at: k put: type.
  type setReferencedType: pointerType.
  pointerType setReferencedType: type.
  ].
  ].
  self initializeAtomicTypes.
  self initializeStructureTypes.
  "AtomicTypes := nil"!

Item was changed:
  ----- Method: ExternalType class>>initializeStructureTypes (in category 'class initialization') -----
  initializeStructureTypes
  "Reset all non-pointer struct types to zero and their pointer companions to the appropriate pointer size."
+
+ StructTypes ifNil: [
+ StructTypes := WeakValueDictionary new].
 
+ self cleanupUnusedTypes.
+
  StructTypes valuesDo:[:structType |
  structType "asNonPointerType"
  compiledSpec: (WordArray with: self structureSpec);
  byteAlignment: nil.
  structType asPointerType
  compiledSpec: (WordArray with: self pointerSpec);
  byteAlignment: nil].!

Item was changed:
  ----- Method: ExternalType class>>newTypeForStructureClass: (in category 'instance creation') -----
  newTypeForStructureClass: anExternalStructureClass
 
  | type referentClass |
  referentClass := anExternalStructureClass.
- self assert: [referentClass includesBehavior: ExternalStructure].
 
+ self
+ assert: [referentClass includesBehavior: ExternalStructure]
+ description: 'Wrong base class for structure'.
+
  type := self newTypeForUnknownNamed: referentClass name.
 
  referentClass compiledSpec
  ifNil: [ "First time. The referent class' fields are probably just compiled for the first time."
  type asNonPointerType setReferentClass: referentClass.
  type asPointerType setReferentClass: referentClass]
  ifNotNil: [
  type asNonPointerType newReferentClass: referentClass.
  type asPointerType newReferentClass: referentClass].
 
  ^ type!

Item was changed:
  ----- Method: ExternalType class>>newTypeForUnknownNamed: (in category 'instance creation') -----
  newTypeForUnknownNamed: typeName
 
  | type pointerType |
+ self
+ assert: [(StructTypes includesKey: typeName) not]
+ description: 'Structure type already exists. Use #typeNamed: to access it.'.
- self assert: [(StructTypes includesKey: typeName) not].
 
  type := self basicNew
  compiledSpec: (WordArray with: self structureSpec);
  yourself.
+ self assert: [type isEmptyStructureType].
 
  pointerType := self basicNew
  compiledSpec: (WordArray with: self pointerSpec);
  yourself.
+ self assert: [pointerType isPointerType].
 
  "Connect non-pointer type with pointer type."
  type setReferencedType: pointerType.
  pointerType setReferencedType: type.
 
  "Remember this new struct type."
- self flag: #discuss. "mt: Field definitions in external structures will usually have strings of the struct type, not symbols. At least, if it is a pointer to that struct type. Maybe we should always use strings instead of symbols?"
  StructTypes at: typeName asSymbol put: type.
 
  ^ type!

Item was changed:
  ----- Method: ExternalType class>>newTypeNamed: (in category 'instance creation') -----
  newTypeNamed: aTypeName
 
  | structClass |
+ self
+ assert: [aTypeName last ~~ $*]
+ description: 'Pointer type will be created automatically'.
+
  structClass := (self environment classNamed: aTypeName)
  ifNotNil: [:class | (class includesBehavior: ExternalStructure) ifTrue: [class]].
 
  ^ structClass
  ifNil: [self newTypeForUnknownNamed: aTypeName]
  ifNotNil: [self newTypeForStructureClass: structClass]!

Item was changed:
  ----- Method: ExternalType class>>platformChangedFrom:to: (in category 'system startup') -----
  platformChangedFrom: lastPlatform to: currentPlatform
  "Byte size or byte alignment for atomic types might be different on the new platform."
 
- self cleanupUnusedTypes.
-
  self initializeAtomicTypes.
  self initializeStructureTypes.!

Item was changed:
  ----- Method: ExternalType class>>pointerSpec (in category 'private') -----
  pointerSpec
+ "Answers a spec for pointers, which already includes the platform-specific pointer size."
  ^(FFIPlatformDescription current wordSize bitOr: FFIFlagPointer)!

Item was added:
+ ----- Method: ExternalType class>>resetAllStructureTypes (in category 'housekeeping') -----
+ resetAllStructureTypes
+ "Warning: This call is only required if you change the container for StructTypes!! Note that (2) and (3) can be swapped but that puts unnecessary pressure on the GC."
+
+ StructTypes := nil.
+
+ "1) Initialize the container for structure types."
+ self initializeStructureTypes.
+
+ "2) Recompile all FFI calls to create and persist structure types."
+ SystemNavigation default allSelectorsAndMethodsDo: [:behavior :selector :method |
+ method externalLibraryFunction ifNotNil: [behavior recompile: selector]].
+
+ "3) Update all structure types' spec and alignment."
+ ExternalStructure compileAllFields.
+ !

Item was changed:
  ----- Method: ExternalType class>>structTypeNamed: (in category 'instance lookup') -----
  structTypeNamed: typeName
  "Answers the external type for the struct named typeName. If there is no type yet, create a new one but only if typeName can be matched to an existing class in the system already. If you still need a type even if there is no such class present, use #newTypeNamed: to create a type with an unknown referent class."
+
+ "Supports pointer-type lookup such as for 'MyStruct*' and also 'MyStruct *'."
 
+ | isPointerType actualTypeName type |
+ (isPointerType := typeName last == $*)
+ ifTrue: [actualTypeName := typeName allButLast withoutTrailingBlanks]
+ ifFalse: [actualTypeName := typeName].
+
+ (Symbol lookup: actualTypeName)
+ ifNotNil: [:sym | actualTypeName := sym].
+
+ type := (StructTypes at: actualTypeName ifAbsent: [nil])
- ^ (StructTypes at: typeName ifAbsent: [nil])
  ifNil: [
+ (self environment classNamed: actualTypeName)
- (self environment classNamed: typeName)
  ifNotNil: [:cls | (cls includesBehavior: ExternalStructure) ifTrue: [
+ StructTypes removeKey: actualTypeName ifAbsent: [].
+ self newTypeNamed: actualTypeName]]].
+
+ ^ type ifNotNil: [isPointerType ifTrue: [type asPointerType] ifFalse: [type]]!
- StructTypes removeKey: typeName ifAbsent: [].
- self newTypeNamed: typeName]]]
- !

Item was changed:
  ----- Method: ExternalType class>>structureSpec (in category 'private') -----
  structureSpec
+ "Answers a spec for empty structures, which are 0 bytes in size."
  ^FFIFlagStructure!

Item was changed:
  ----- Method: ExternalType>>asPointerToPointerType (in category 'converting') -----
  asPointerToPointerType
  "char** etc."
+
+ self flag: #todo. "mt: We might want to cast this to something that holds multiple ExternalData. If null-terminated, that would be easy. But maybe also support extra arg for size as in main(argc int, char *argv[]) . Maybe we could add ExternalArray... I assume that such a type starts in the image anyway to be passed as argument in an FFI call. That is, can there be function that returns void** ?"
-
  ^ self asPointerType!

Item was added:
+ ----- Method: ExternalType>>atomicTypeName (in category 'accessing') -----
+ atomicTypeName
+
+ ^ AtomicTypeNames at: self atomicType!

Item was changed:
  ----- Method: ExternalType>>isTypeAlias (in category 'testing') -----
  isTypeAlias
 
+ ^ referentClass
+ ifNil: [false]
+ ifNotNil: [:structClass | structClass isTypeAlias]!
- | typeAlias |
- referentClass ifNil: [^ false].
- typeAlias := self asNonPointerType.
-
- AtomicTypes valuesDo: [:atomicType |
- atomicType compiledSpec == typeAlias compiledSpec ifTrue: [^ true]].
- (StructTypes keys
- collect: [:typeName | self class structTypeNamed: typeName])
- select: [:structType | structType notNil and: [structType ~~ typeAlias] and: [
- structType referentClass notNil and: [structType referentClass isTypeAlias not]]]
- thenDo: [:structType | structType compiledSpec == typeAlias compiledSpec ifTrue: [^ true]].
-
- ^ false!

Item was added:
+ ----- Method: ExternalType>>isTypeAliasToPointer (in category 'testing') -----
+ isTypeAliasToPointer
+ "Answer whether this type aliases a pointer type, e.g., typedef char_ptr char*"
+ ^ self isTypeAlias and: [self isStructureType and:[self headerWord anyMask: FFIFlagPointer]]!

Item was changed:
  ----- Method: ExternalType>>originalType (in category 'accessing') -----
  originalType
+ "Resolve original type for alias. Error if not a type alias."
- "Resolve type alias."
 
+ ^ ExternalType typeNamed: self originalTypeName!
- | typeAlias |
- referentClass ifNil: [^ nil].
- typeAlias := self asNonPointerType.
-
- AtomicTypes valuesDo: [:atomicType |
- (atomicType compiledSpec == typeAlias compiledSpec "and: [atomicType ~~ typeAlias]")
- ifTrue: [^ self isPointerType ifTrue: [atomicType asPointerType] ifFalse: [atomicType]]].
- (StructTypes keys
- collect: [:typeName | self class structTypeNamed: typeName])
- select: [:structType | structType notNil and: [structType ~~ typeAlias] and: [
- structType referentClass notNil and: [structType referentClass isTypeAlias not]]]
- thenDo: [:structType | structType compiledSpec == typeAlias compiledSpec
- ifTrue: [ ^ self isPointerType ifTrue: [structType asPointerType] ifFalse: [structType]]].
-
- ^ nil!

Item was added:
+ ----- Method: ExternalType>>originalTypeName (in category 'accessing') -----
+ originalTypeName
+ "Resolve original type for alias. Error if not a type alias."
+
+ ^ referentClass ifNotNil: [referentClass originalTypeName]!

Item was changed:
  ----- Method: ExternalType>>printOn: (in category 'printing') -----
  printOn: aStream
 
  self isTypeAlias ifTrue: [
+ "Note that a type alias cannot be atomic."
+ aStream nextPutAll: referentClass name.
+ self isPointerType ifTrue:[aStream nextPut: $*].
  aStream
+ nextPutAll: '~>';
+ print: self originalType.
+ self isEmptyStructureType
+ ifTrue: [aStream nextPutAll: ' ???'].
- nextPutAll: referentClass name;
- nextPut: $<;
- print: self originalType;
- nextPut: $>.
  ^ self].
 
  self isAtomic
+ ifTrue: [aStream nextPutAll: self atomicTypeName]
- ifTrue: [aStream nextPutAll: (AtomicTypeNames at: self atomicType)]
  ifFalse: [
  referentClass == nil
  ifTrue:[aStream nextPutAll: '<unknown struct type>']
  ifFalse:[
  aStream nextPutAll: referentClass name.
  self isEmptyStructureType
  ifTrue: [aStream nextPutAll: ' { void }']]].
  self isPointerType ifTrue:[aStream nextPut: $*].!

Item was added:
+ ----- Method: ExternalType>>readAlias (in category 'private') -----
+ readAlias
+
+ ^ String streamContents: [:s |
+ referentClass == nil
+ ifTrue:[(self isAtomic and:[self isPointerType not])
+ ifTrue:[s nextPutAll:'^handle object "', self readFieldArgName, '"']
+ ifFalse:[s nextPutAll:'^ExternalData fromHandle: handle'.
+ self isPointerType ifTrue:[s nextPutAll:' asExternalPointer'].
+ s nextPutAll:' type: ';
+ nextPutAll: self asPointerType storeString]]
+ ifFalse:[s nextPutAll:'^', referentClass name,' fromHandle: handle'.
+ self isPointerType ifTrue:[s nextPutAll:' asExternalPointer']]]!

Item was added:
+ ----- Method: ExternalType>>readFieldArgName (in category 'private') -----
+ readFieldArgName
+
+ ^ self writeFieldArgName!

Item was changed:
  ----- Method: ExternalType>>readFieldAt: (in category 'private') -----
  readFieldAt: byteOffset
  "Answer a string defining the accessor to an entity of the receiver type starting at the given byte offset.
  Private. Used for field definition only."
  self isPointerType ifTrue:
  [| accessor |
  self flag: #ffiLongVsInt. "mt: Here short means 'long', which is actually 'int', and long means 'longlong'. Sigh."
  accessor := self pointerSize caseOf: {
  [4] -> [#shortPointerAt:].
  [8] -> [#longPointerAt:] }.
  ^String streamContents:
  [:s|
  referentClass
  ifNil:
  [s nextPutAll: '^ExternalData fromHandle: (handle ', accessor, ' ';
  print: byteOffset;
  nextPutAll: ') type: ExternalType ';
+ nextPutAll: self atomicTypeName;
- nextPutAll: (AtomicTypeNames at: self atomicType);
  nextPutAll: ' asPointerType']
  ifNotNil:
  [s nextPutAll: '^';
  print: referentClass;
  nextPutAll: ' fromHandle: (handle ', accessor, ' ';
  print: byteOffset;
  nextPut: $)]]].
 
  self isAtomic ifFalse: "structure type"
  [^String streamContents:[:s|
  s nextPutAll:'^';
  print: referentClass;
  nextPutAll:' fromHandle: (handle structAt: ';
  print: byteOffset;
  nextPutAll:' length: ';
  print: self byteSize;
  nextPutAll:')']].
 
+ self isTypeAlias ifTrue: "alias to atomic type"
+ [^String streamContents:[:s |
+ s nextPutAll:'^';
+ print: referentClass;
+ nextPutAll:' fromHandle: (FFIObjectHandle on: (handle ';
+ nextPutAll: (AtomicSelectors at: self atomicType);
+ space; print: byteOffset;
+ nextPutAll:'))']].
+
  "Atomic non-pointer types"
  ^String streamContents:
  [:s|
  s nextPutAll:'^handle ';
  nextPutAll: (AtomicSelectors at: self atomicType);
  space; print: byteOffset].!

Item was changed:
  ----- Method: ExternalType>>storeOn: (in category 'printing') -----
  storeOn: aStream
 
  self isAtomic
+ ifTrue:[aStream nextPutAll: ExternalType name; space; nextPutAll: self atomicTypeName]
- ifTrue:[aStream nextPutAll: ExternalType name; space; nextPutAll: (AtomicTypeNames at: self atomicType)]
  ifFalse:[
  referentClass == nil
  ifTrue: [aStream nextPutAll: 'nil']
  ifFalse: [aStream nextPut: $(; nextPutAll: ExternalType name; space; nextPutAll: #structTypeNamed:; space;  store: referentClass name; nextPut: $)]].
  self isPointerType ifTrue: [aStream space; nextPutAll: #asPointerType].!

Item was added:
+ ----- Method: ExternalType>>writeAliasWith: (in category 'private') -----
+ writeAliasWith: valueName
+
+ ^ String streamContents: [:s |
+ (referentClass == nil and:[self isAtomic and:[self isPointerType not]])
+ ifTrue:[s nextPutAll:'handle := FFIObjectHandle on: ', valueName, '.']
+ ifFalse:[s nextPutAll:'handle := ', valueName,' getHandle'.
+ self isPointerType ifTrue:[s nextPutAll:' asByteArrayPointer']]]!

Item was added:
+ ----- Method: ExternalType>>writeFieldArgName (in category 'private') -----
+ writeFieldArgName
+
+ ^ referentClass == nil
+ ifTrue:[(self isAtomic and:[self isPointerType not])
+ ifTrue:[
+ self atomicTypeName caseOf: {
+ ['bool'] -> ['aBoolean'].
+ ['char'] -> ['aCharacter'].
+ ['schar'] -> ['aCharacter'].
+ ['float'] -> ['aFloat'].
+ ['double'] -> ['aFloat'].
+ } otherwise: ['anInteger']]
+ ifFalse:[
+ self = ExternalType string
+ ifTrue: ['aString']
+ ifFalse: ['someExternalData']]]
+ ifFalse:['a',referentClass name]!

Item was changed:
  ----- Method: ExternalType>>writeFieldAt:with: (in category 'private') -----
  writeFieldAt: byteOffset with: valueName
  "Answer a string defining the accessor to an entity of the receiver type starting at the given byte offset.
  Private. Used for field definition only."
  self isPointerType ifTrue:
  [| accessor |
  self flag: #ffiLongVsInt. "mt: Here short means 'long', which is actually 'int', and long means 'longlong'. Sigh."
  accessor := self pointerSize caseOf: {
  [4] -> [#shortPointerAt:].
  [8] -> [#longPointerAt:] }.
  ^String streamContents:
  [:s|
  s nextPutAll:'handle ', accessor, ' ';
  print: byteOffset;
  nextPutAll:' put: ';
  nextPutAll: valueName;
  nextPutAll:' getHandle.']].
 
+ self isAtomic ifFalse:[ "structure type"
- self isAtomic ifFalse:[
  ^String streamContents:[:s|
  s nextPutAll:'handle structAt: ';
  print: byteOffset;
  nextPutAll:' put: ';
  nextPutAll: valueName;
  nextPutAll:' getHandle';
  nextPutAll:' length: ';
  print: self byteSize;
  nextPutAll:'.']].
 
+ self isTypeAlias ifTrue:[ "alias to atomic type"
+ ^String streamContents:[:s|
+ s nextPutAll:'handle ';
+ nextPutAll: (AtomicSelectors at: self atomicType);
+ space; print: byteOffset;
+ nextPutAll:' put: ';
+ nextPutAll: valueName;
+ nextPutAll: ' getHandle object']].
+
  ^String streamContents:[:s|
  s nextPutAll:'handle ';
  nextPutAll: (AtomicSelectors at: self atomicType);
  space; print: byteOffset;
  nextPutAll:' put: ';
  nextPutAll: valueName].!

Item was changed:
  ExternalStructure subclass: #ExternalTypeAlias
  instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'FFI-Kernel'!
 
+ !ExternalTypeAlias commentStamp: 'mt 6/5/2020 18:42' prior: 0!
+ You can subclass from here to make type aliasing (i.e., "typedef long long_t" or "typdef long* long_ptr") more clear. My instances support MNU and #value to perform the "C type cast" equivalent to address the original type behind the alias.
+
+ Type aliasing works by re-using the compiledSpec of the original type. For pointer-type aliases, the compiledSpec will have flags for both structure and pointer raised BUT it will not appear as #isPointerType for the in-image FFI interface.!
- !ExternalTypeAlias commentStamp: 'mt 6/4/2020 19:02' prior: 0!
- You can subclass from here to make type aliasing more clear.!

Item was changed:
  ----- Method: ExternalTypeAlias class>>fields (in category 'field definition') -----
  fields
+ "Do not overwrite this method. Just implement #originalTypeName."
+ ^ { #value. self originalTypeName }!
-
- ^ { nil. self originalTypeName }!

Item was removed:
- ----- Method: ExternalTypeAlias class>>isTypeAlias (in category 'testing') -----
- isTypeAlias
-
- ^ true!

Item was added:
+ ----- Method: ExternalTypeAlias class>>isTypeAlias: (in category 'testing') -----
+ isTypeAlias: fieldSpec
+
+ ^ true!

Item was added:
+ ----- Method: ExternalTypeAlias class>>on: (in category 'instance creation') -----
+ on: externalObject
+
+ ^ self new
+ value: externalObject;
+ yourself!

Item was changed:
+ ----- Method: ExternalTypeAlias class>>originalTypeName (in category 'type alias') -----
- ----- Method: ExternalTypeAlias class>>originalTypeName (in category 'field definition') -----
  originalTypeName
+ "Answer the typeName this alias should be for, e.g., 'long', 'ulonglong*'. Provide a default here to make automated sends to #compileFields work."
- "Anser the typeName this alias should be for, e.g., 'long', 'ulonglong*', ..."
 
+ ^ 'void'!
- self subclassResponsibility.!

Item was added:
+ ----- Method: ExternalTypeAlias>>doesNotUnderstand: (in category 'proxy') -----
+ doesNotUnderstand: msg
+
+ ^ msg sendTo: self value!

Item was added:
+ ----- Method: ExternalTypeAlias>>printNullOn: (in category 'printing') -----
+ printNullOn: stream
+
+ handle ifNil: [^ stream nextPutAll: '<UNDEFINED>'].
+
+ self isNull ifTrue: [
+ stream nextPutAll: '<NULL>'].!

Item was added:
+ ----- Method: ExternalTypeAlias>>value (in category 'accessing') -----
+ value
+
+ self subclassResponsibility.!

Item was added:
+ ----- Method: ExternalTypeAlias>>value: (in category 'accessing') -----
+ value: externalObject
+
+ self subclassResponsibility.!

Item was removed:
- ----- Method: ExternalUnion class>>compileFields:withAccessors: (in category 'field definition') -----
- compileFields: specArray withAccessors: aSymbol
- "Compile a type specification for the FFI machinery.
- Return the newly compiled spec.
- Eventually generate the field accessors according to the policy defined in aSymbol."
- | byteOffset maxByteSize typeSpec newCompiledSpec newByteAlignment |
- (self isTypeAlias: specArray) ifTrue:
- [^ self error: 'Use ExternalStructure or ExternalTypeAlias to define a type alias, not ExternalUnion'].
- byteOffset := 1.
- newByteAlignment := 1.
- maxByteSize := 0.
- typeSpec := WriteStream on: (WordArray new: specArray size + 1).
- typeSpec nextPut: FFIFlagStructure.
- specArray do: [:spec |
- | fieldName fieldTypeName isPointerField externalType typeSize typeAlignment |
- fieldName := spec first.
- fieldTypeName := spec second.
- isPointerField := fieldTypeName last = $*.
- fieldTypeName := (fieldTypeName findTokens: '*') first withBlanksTrimmed.
- externalType := (ExternalType typeNamed: fieldTypeName)
- ifNil: [self errorTypeNotFound: spec second].
- isPointerField ifTrue: [externalType := externalType asPointerType].
- typeSize := externalType byteSize.
- typeAlignment := externalType byteAlignment.
- spec size > 2 ifTrue: ["extra size"
- spec third < typeSize
- ifTrue: [^ self error: 'Explicit type size is less than expected'].
- typeSize := spec third.
- ].
- (fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
- self defineFieldAccessorsFor: fieldName startingAt: byteOffset type: externalType.
- ].
- typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
- maxByteSize := maxByteSize max: typeSize.
- newByteAlignment := newByteAlignment max: typeAlignment
- ].
- maxByteSize := maxByteSize alignedTo: newByteAlignment.
- newCompiledSpec := typeSpec contents.
- newCompiledSpec at: 1 put: (maxByteSize bitOr: FFIFlagStructure).
- byteAlignment := newByteAlignment.
- ^ newCompiledSpec!

Item was added:
+ ----- Method: ExternalUnion class>>compileStructureSpec:withAccessors: (in category 'field definition - support') -----
+ compileStructureSpec: specArray withAccessors: aSymbol
+ "Compile a type specification for the FFI machinery.
+ Return the newly compiled spec.
+ Eventually generate the field accessors according to the policy defined in aSymbol."
+ | byteOffset maxByteSize typeSpec newCompiledSpec newByteAlignment |
+ byteOffset := 1.
+ newByteAlignment := 1.
+ maxByteSize := 0.
+ typeSpec := WriteStream on: (WordArray new: specArray size + 1).
+ typeSpec nextPut: FFIFlagStructure.
+ specArray do: [:spec |
+ | fieldName fieldTypeName externalType typeSize typeAlignment |
+ fieldName := spec first.
+ fieldTypeName := spec second.
+ externalType := (ExternalType typeNamed: fieldTypeName)
+ ifNil: [self errorTypeNotFound: spec second].
+ typeSize := externalType byteSize.
+ typeAlignment := externalType byteAlignment.
+ spec size > 2 ifTrue: ["extra size"
+ spec third < typeSize
+ ifTrue: [^ self error: 'Explicit type size is less than expected'].
+ typeSize := spec third.
+ ].
+ (fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
+ self generateStructureFieldAccessorsFor: fieldName startingAt: byteOffset type: externalType.
+ ].
+ typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
+ maxByteSize := maxByteSize max: typeSize.
+ newByteAlignment := newByteAlignment max: typeAlignment
+ ].
+ maxByteSize := maxByteSize alignedTo: newByteAlignment.
+ newCompiledSpec := typeSpec contents.
+ newCompiledSpec at: 1 put: (maxByteSize bitOr: FFIFlagStructure).
+ self
+ setCompiledSpec: newCompiledSpec
+ byteAlignment: newByteAlignment.!

Item was added:
+ ----- Method: ExternalUnion class>>compileTypeAliasSpec:withAccessors: (in category 'field definition - support') -----
+ compileTypeAliasSpec: spec withAccessors: aSymbol
+
+ self error: 'Use ExternalStructure or ExternalTypeAlias to define a type alias, not ExternalUnion'.!

Item was added:
+ Object subclass: #FFIObjectHandle
+ instanceVariableNames: 'object'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'FFI-Kernel'!
+
+ !FFIObjectHandle commentStamp: 'mt 6/6/2020 13:11' prior: 0!
+ I am a wrapper around an object and hence, in addition to ByteArray and ExternalAddress, the third kind of handle an external object can have. I am necessary to implement type aliasing.!

Item was added:
+ ----- Method: FFIObjectHandle class>>on: (in category 'instance creation') -----
+ on: anObject
+
+ ^ self new object: anObject!

Item was added:
+ ----- Method: FFIObjectHandle>>asByteArrayPointer (in category 'private') -----
+ asByteArrayPointer
+ "Return a ByteArray describing a pointer to the contents of the receiver."
+ ^self shouldNotImplement!

Item was added:
+ ----- Method: FFIObjectHandle>>isExternalAddress (in category 'testing') -----
+ isExternalAddress
+
+ ^ false!

Item was added:
+ ----- Method: FFIObjectHandle>>isNull (in category 'testing') -----
+ isNull
+
+ ^ self object isNil!

Item was added:
+ ----- Method: FFIObjectHandle>>object (in category 'accessing') -----
+ object
+
+ ^ object!

Item was added:
+ ----- Method: FFIObjectHandle>>object: (in category 'accessing') -----
+ object: anObject
+
+ object := anObject.!

Item was added:
+ ----- Method: FFIObjectHandle>>printOn: (in category 'as yet unclassified') -----
+ printOn: aStream
+
+ aStream
+ nextPutAll: '-> ';
+ print: self object.!