FFI: FFI-Kernel-mt.97.mcz
Locked
 
|
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.! |
«
Return to Squeak - Dev
|
1 view|%1 views
| Free forum by Nabble | Edit this page |