Squeak-dev April 2017

squeak-dev@lists.squeakfoundation.org

48 participants
221 discussions

The Inbox: Kernel-tpr.1075.mcz
by commits＠source.squeak.org 19 Apr '17

19 Apr '17

A new version of Kernel was added to project The Inbox: http://source.squeak.org/inbox/Kernel-tpr.1075.mcz ==================== Summary ==================== Name: Kernel-tpr.1075 Author: tpr Time: 19 April 2017, 1:56:03.426223 pm UUID: 70a65889-c052-4cb7-8766-9f84adebb338 Ancestors: Kernel-eem.1074 A simple approach to handling an absence of a writeable changes file when compiling code changes. NB - this does NOTNOTNOT address the other implementors of #acceptsLoggingOfCompilation such as UnscriptedPlayer etc that do ... odd things. This set of changes must of course be paired with Files-tpr.169 wherein lies the new code to test for a changes file =============== Diff against Kernel-eem.1074 =============== Item was changed: ----- Method: ClassDescription>>acceptsLoggingOfCompilation (in category 'compiling') ----- acceptsLoggingOfCompilation "weird name is so that it will come lexically before #compile, so that a clean build can make it through. 7/7/96 sw" + ^SourceFiles hasWriteableChangesFile! - ^ true!

1 0

64 bit specific hash multiply
by Bert Freudenberg 18 Apr '17

18 Apr '17

(moved from vm-dev) On Tue, Apr 18, 2017 at 10:27 AM, Nicolas Cellier < nicolas.cellier.aka.nice(a)gmail.com> wrote: > > 2017-04-18 4:02 GMT+02:00 Andres Valloud <avalloud@smalltalk. > comcastbiz.net>: > >> >> On 4/17/17 16:45 , Eliot Miranda wrote: >> >>> FYI, hash multiply is >>> hashMultiply >>> | low | >>> low := self bitAnd: 16383. >>> ^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) >>> bitAnd: 16383) * 16384)) >>> bitAnd: 16r0FFFFFFF >>> >> >> [...] that convoluted arithmetic is done this way in Smalltalk only to >> simulate a 32x32 multiplication bit-anded down to 28 bits without >> overflowing into large integers (the original code from August 2000 had my >> initials). >> >> At a sufficiently low level such as C, all that complexity is just an >> unsigned multiplication by 1664525. The image code should still have a >> comment to that effect, did it get lost? >> >> Andres. >> > > More: if it's a 64 bit image, then we have 60 bit long unsigned small int > since 1664525 highBit = 21, and self is a hash result not exceeding 30 > bits, we can implement hashMultiply as > ^self * 1664525 bitAnd: 16r0FFFFFFF > Yes I wondered about that too. How could we get different behavior in the 32 vs 64 bit image, while running the same code? One way would be to make SmallInteger abstract and have concrete SmallInteger32 and SmallInteger64 subclasses. In a 32 bit image you would only get SmallInteger32 instances, and in a 64 bit image only SmallInteger64 instances. Most methods would remain in SmallInteger, but 32 or 64 bit specific behavior could be implemented in the subclasses. Seems very clean, but sounds like overkill. A more hackish but less intrusive way would be to have a Monticello package with *overrides which would only be loaded in 64 bit images. Then again, we try to avoid overrides, and we want to use the same config map in both 32 and 64 bit images. Or how about a little compiler hack? Basically the code could read hashMultiply Smalltalk is64Bits ifTrue: [^self * 1664525 bitAnd: 16r0FFFFFFF] ifFalse: [ | low | low := self bitAnd: 16383. ^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF] and the compiler could recognize that "Smalltalk is64Bits" is constant and generate only one of the branches ... I actually quite like this idea, I think :) - Bert -

2 1

The Trunk: SystemReporter-eem.35.mcz
by commits＠source.squeak.org 18 Apr '17

18 Apr '17

Eliot Miranda uploaded a new version of SystemReporter to project The Trunk: http://source.squeak.org/trunk/SystemReporter-eem.35.mcz ==================== Summary ==================== Name: SystemReporter-eem.35 Author: eem Time: 18 April 2017, 11:43:09.35433 am UUID: 3fd6ab42-79ae-4e3a-b83b-bcdc4a8bba7b Ancestors: SystemReporter-eem.34 Better label for the system reporter's description of vm parameter #2 in Spur. =============== Diff against SystemReporter-eem.34 =============== Item was changed: ----- Method: SystemReporter>>reportVMParameters: (in category 'reporting') ----- reportVMParameters: aStream | vmParameters isStack isCog isSpur | self header: 'Virtual Machine Parameters' on: aStream. vmParameters := Smalltalk vm getVMParameters. isStack := (vmParameters at: 42 ifAbsent: [0]) ~= 0. "42 = number of stack pages available" isCog := isStack and: [(vmParameters at: 46) ~= 0]. "46 is machine code zone size" isSpur := isStack and: [(vmParameters at: 41) anyMask: 2r10000]. "41 is imageFormatVersion for the VM; bit 16 is the Spur bit" (isSpur ifFalse: [#( 1 'size of old space' 2 'size of young+old space' 3 'size of memory' 4 'allocationCount' 5 'allocations between GCs' 6 'survivor count tenuring threshold')] ifTrue: [#( 1 'size of old space' + 2 'used bytes in new space (used eden + used past space)' - 2 'size of new space' 3 'size of heap')]), #( 7 'full GCs since startup' 8 'total milliseconds in full GCs since startup'), (isSpur ifFalse: [#( 9 'incremental GCs since startup' 10 'total milliseconds in incremental GCs since startup' 11 'tenures of surving objects since startup'), {12 to: 19. 'specific to the translating VM'}] ifTrue: [#( 9 'scavenging GCs since startup' 10 'total milliseconds in scavenging GCs since startup' 11 'tenures of surving objects since startup'), {12 to: 15. 'reserved for future use'}, #( 16 'total microseconds in idle since startup' 17 'proportion of code zone available for use (Sista VMs only; read-write)' 18 'total milliseconds in full GC compaction since startup (a portion of parameter 8)' 19 'scavenge threshold; the effective size of eden')]), #( 20 'utc microseconds at startup (if non-zero)' 21 'root/remembered table size (occupancy)' 22 'root/remembered table overflows since startup' 23 'bytes of extra memory to reserve for VM buffers, plugins, etc.' 24 'free memory threshold above which object memory will be shrunk' 25 'memory headroom when growing object memory'), (isStack ifFalse: [#( 26 'interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image is not calling getNextEvent often')] ifTrue: [#( 26 'heartbeat period (ms; see #58)')]), (isSpur ifFalse: [#( 27 'number of times mark loop iterated for current IGC/FGC includes ALL marking' 28 'number of times sweep loop iterated for current IGC/FGC' 29 'number of times make forward loop iterated for current IGC/FGC' 30 'number of times compact move loop iterated for current IGC/FGC')] ifTrue: [#()]), #( 31 'number of grow memory requests' 32 'number of shrink memory requests'), (isSpur ifFalse: [#( 33 'number of root table entries used for current IGC/FGC' 34 'number of allocations done before current IGC/FGC' 35 'number of survivor objects after current IGC/FGC' 36 'millisecond clock when current IGC/FGC completed' 37 'number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC' 38 'milliseconds taken by current IGC' 39 'Number of finalization signals for Weak Objects pending when current IGC/FGC completed')] ifTrue: [#( 33 'number of root table entries at last scavenge' 35 'number of survivor objects at last scavenge (if non-zero)' 36 'millisecond clock when current scavenge completed' 38 'milliseconds taken by current scavenge' 39 'Number of finalization signals for Weak Objects pending when current SGC/FGC completed')]), #( 40 'VM word size - 4 or 8'), (isStack ifTrue: [#( 41 'imageFormatVersion for the VM' 42 'number of stack pages available' 43 'desired number of stack pages (stored in image file header, max 65535)' 44 'size of eden, in bytes' 45 'desired size of eden, in bytes (stored in image file header)' 46 'machine code zone size, in bytes (0 in Stack VM)' 47 'desired machine code zone size (0 => default 1Mb)' 48 'various header flags. See getCogVMFlags.' 49 'max size the image promises to grow the external semaphore table to'), (isSpur ifFalse: [{ 50 to: 51. 'reserved for VM parameters that persist in the image (such as size of eden above)'. 52 to: 56. 'specific to Spur' }] ifTrue: [{ 50 to: 51. 'reserved for VM parameters that persist in the image (such as size of eden above)' }, #( 52 'root/remembered table capacity' 53 'number of old space segments' 54 'total free old space' 55 'ratio of growth and image size at or above which a GC will be performed post scavenge')]), #( 56 'number of process switches since startup' 57 'number of ioProcessEvents calls since startup' 58 'number of forceInterruptCheck calls since startup' 59 'number of check event calls since startup' 60 'number of stack page overflows since startup' 61 'number of stack page divorces since startup' 62 'compiled code compactions since startup'), (isCog ifFalse: [#()] ifTrue: [#( 63 'total milliseconds in compiled code compactions since startup' 64 'the number of methods that currently have jitted machine-code')]), #( 65 'whether the VM supports MULTIPLE_BYTECODE_SETS or not.' 66 'the byte size of a stack page'), (isSpur ifFalse: [{ 67 to: 69. 'reserved for more Cog-related info' }] ifTrue: [#( 67 'the maximum allowed size of old space (if zero there is no limit)' 68 'the average number of live stack pages when scanned by scavenge/gc/become' 69 'the maximum number of live stack pages when scanned by scavenge/gc/become')]), #( 70 'the vmProxyMajorVersion (the interpreterProxy VM_MAJOR_VERSION)' 71 'the vmProxyMinorVersion (the interpreterProxy VM_MINOR_VERSION)')] ifFalse: [#()]) pairsDo: [:idx :desc | | value values | aStream nextPut: $#. idx isInteger ifTrue: [value := vmParameters at: idx. aStream print: idx; tab: (idx < 10 ifTrue: [2] ifFalse: [1]); nextPutAll: ((value isInteger and: [idx ~= 41]) ifTrue: [value asStringWithCommas] ifFalse: [value printString])] ifFalse: [value := vmParameters at: idx first. aStream print: idx first; next: 2 put: $.; print: idx last; tab. values := idx collect: [:i| vmParameters at: i]. values asSet size = 1 ifTrue: [aStream print: value] ifFalse: [values do: [:v| aStream print: v] separatedBy: [aStream nextPutAll: ', ']]]. aStream tab; nextPutAll: desc; cr]!

1 0

The Trunk: Kernel-eem.1097.mcz
by commits＠source.squeak.org 18 Apr '17

18 Apr '17

Eliot Miranda uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-eem.1097.mcz ==================== Summary ==================== Name: Kernel-eem.1097 Author: eem Time: 18 April 2017, 11:41:03.658215 am UUID: 716aef28-aea7-408d-9720-a0371de009d7 Ancestors: Kernel-dtl.1096 Add the primitive implementation to the two hashMultiply methods. =============== Diff against Kernel-dtl.1096 =============== Item was changed: ----- Method: LargePositiveInteger>>hashMultiply (in category 'bit manipulation') ----- hashMultiply + "This is a multiplication by by 1664525 mod 2^28 written to avoid overflowing into large integers. + The primitive is able to perform the operation with modulo arihmetic." + <primitive: 159> "Truncate to 28 bits and try again" - ^(self bitAnd: 16rFFFFFFF) hashMultiply! Item was changed: ----- Method: SmallInteger>>hashMultiply (in category 'bit manipulation') ----- hashMultiply + "This is a multiplication by by 1664525 mod 2^28 written to avoid overflowing into large integers. + The primitive is able to perform the operation with modulo arihmetic." + <primitive: 159> - "Multiply by 1664525 mod 2^28 without overflowing into large integers." | low | low := self bitAnd: 16383. ^(16r260D * low + ((16r260D * (self bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF!

1 0

The Trunk: Collections-eem.745.mcz
by commits＠source.squeak.org 18 Apr '17

18 Apr '17

Eliot Miranda uploaded a new version of Collections to project The Trunk: http://source.squeak.org/trunk/Collections-eem.745.mcz ==================== Summary ==================== Name: Collections-eem.745 Author: eem Time: 18 April 2017, 11:39:44.905833 am UUID: c26d3130-3164-4fdb-b302-858a554d8d8d Ancestors: Collections-eem.744 Clarify the two primitiveStringHash uses. The one in ByteArray class is translated to a primitive in MiscPrimitivePlugin. The one in ByteString class is not; it uses the translated primitive derived from ByteArray class>>hashBytes:startingWith:. (N.B. Requires a soon-to-be-committed change to VMMaker to accet the int decl for speciesHash.") =============== Diff against Collections-eem.744 =============== Item was changed: ----- Method: ByteArray class>>hashBytes:startingWith: (in category 'byte based hash') ----- hashBytes: aByteArray startingWith: speciesHash + "Answer the hash of a byte-indexed collection, using speciesHash as the initial value. + See SmallInteger>>hashMultiply. - "Answer the hash of a byte-indexed collection, - using speciesHash as the initial value. - See SmallInteger>>hashMultiply. + The primitive should be renamed at a suitable point in the future" - The primitive should be renamed at a - suitable point in the future" - - | byteArraySize hash low | <primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'> + | byteArraySize hash | + <var: 'aByteArray' type: #'unsigned char *'> + <var: 'speciesHash' type: #int> - <var: #aHash declareC: 'int speciesHash'> - <var: #aByteArray declareC: 'unsigned char *aByteArray'> byteArraySize := aByteArray size. hash := speciesHash bitAnd: 16rFFFFFFF. + 1 to: byteArraySize do: + [:pos | - 1 to: byteArraySize do: [:pos | hash := hash + (aByteArray basicAt: pos). + "Inlined hashMultiply, written this way for translation to C." + hash := hash * 1664525 bitAnd: 16r0FFFFFFF]. + ^hash! - "Begin hashMultiply" - low := hash bitAnd: 16383. - hash := (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. - ]. - ^ hash! Item was changed: ----- Method: ByteString class>>stringHash:initialHash: (in category 'primitives') ----- stringHash: aString initialHash: speciesHash + "Answer the hash of a byte-indexed string, using speciesHash as the initial value. + See SmallInteger>>hashMultiply." - - | stringSize hash low | <primitive: 'primitiveStringHash' module: 'MiscPrimitivePlugin'> + | hash | - - <var: #aHash declareC: 'int speciesHash'> - <var: #aString declareC: 'unsigned char *aString'> - - stringSize := aString size. hash := speciesHash bitAnd: 16rFFFFFFF. + 1 to: aString size do: + [:pos | + hash := (hash + (aString basicAt: pos)) hashMultiply]. + ^hash! - 1 to: stringSize do: [:pos | - hash := hash + (aString basicAt: pos). - "Begin hashMultiply" - low := hash bitAnd: 16383. - hash := (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. - ]. - ^ hash!

1 0

The Inbox: FFI-Win32-cbc.12.mcz
by commits＠source.squeak.org 17 Apr '17

17 Apr '17

A new version of FFI-Win32 was added to project The Inbox: http://source.squeak.org/inbox/FFI-Win32-cbc.12.mcz ==================== Summary ==================== Name: FFI-Win32-cbc.12 Author: cbc Time: 28 March 2017, 5:09:55.317402 pm UUID: 8f7957c1-d4e4-c942-a7c1-0763a354d89d Ancestors: FFI-Win32-tbn.11 Added ability to silently run a program in the background (no window) ==================== Snapshot ==================== SystemOrganization addCategory: #'FFI-Win32-Examples'! ExternalStructure subclass: #Win32Handle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Win32-Examples'! Win32Handle subclass: #Win32HDC instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Win32-Examples'! ----- Method: Win32HDC>>apiDeleteDC: (in category 'api calls') ----- apiDeleteDC: aHDC <apicall: bool 'DeleteDC' (Win32HDC) module:'gdi32.dll'> ^self externalCallFailed! ----- Method: Win32HDC>>apiDrawFocusRect:with: (in category 'api calls') ----- apiDrawFocusRect: aHDC with: lpRect "Draws a rectangle in the style used to indicate that the rectangle has the focus." <apicall: bool 'DrawFocusRect' (Win32HDC Win32Rectangle*) module: 'user32.dll'> ^ self externalCallFailed! ----- Method: Win32HDC>>apiDrawFrameControl:with:with:with: (in category 'api calls') ----- apiDrawFrameControl: aHDC with: lpRect with: type with: state "Draws a frame control of the specified type and style" <apicall: bool 'DrawFrameControl' (Win32HDC Win32Rectangle* ulong ulong) module: 'user32.dll'> ^ self externalCallFailed! ----- Method: Win32HDC>>apiEllipse:with:with:with:with: (in category 'api calls') ----- apiEllipse: aHDC with: left with: top with: right with: bottom <apicall: bool 'Ellipse' (Win32HDC long long long long) module: 'gdi32.dll'> ^self externalCallFailed! ----- Method: Win32HDC>>apiExtFloodFill:with:with:with:with: (in category 'api calls') ----- apiExtFloodFill: aHDC with: x with: y with: colorref with: fillType "fills an area of the display surface with the current brush" <apicall: bool 'ExtFloodFill' (Win32HDC long long ulong ulong) module: 'gdi32.dll'> ^ self externalCallFailed! ----- Method: Win32HDC>>apiFillRect:with:with: (in category 'api calls') ----- apiFillRect: aHDC with: lpRect with: brush "Fills a rectangle by using the specified brush. This function includes the left and top borders, but excludes the right and bottom borders of the rectangle. " <apicall: char 'FillRect' (Win32HDC Win32Rectangle* Win32HBrush) module: 'user32.dll'> ^ self externalCallFailed! ----- Method: Win32HDC>>apiFrameRect:with:with: (in category 'api calls') ----- apiFrameRect: aHDC with: lpRect with: brush "Draws a border around the specified rectangle by using the specified brush. The width and height of the border are always one logical unit." <apicall: char 'FrameRect' (Win32HDC Win32Rectangle* Win32HBrush) module: 'user32.dll'> ^ self externalCallFailed! ----- Method: Win32HDC>>apiLineTo:with:with: (in category 'api calls') ----- apiLineTo: aHDC with: x with: y <apicall: bool 'LineTo' (Win32HDC long long) module:'gdi32.dll'> ^self externalCallFailed! ----- Method: Win32HDC>>apiMoveToEx:with:with:with: (in category 'api calls') ----- apiMoveToEx: aHDC with: x with: y with: pt <apicall: bool 'MoveToEx' (Win32HDC long long Win32Point*) module: 'gdi32.dll'> ^self externalCallFailed! ----- Method: Win32HDC>>apiRectangle:with:with:with:with: (in category 'api calls') ----- apiRectangle: aHDC with: left with: top with: right with: bottom <apicall: bool 'Rectangle' (Win32HDC long long long long) module: 'gdi32.dll'> ^self externalCallFailed! ----- Method: Win32HDC>>apiRoundRect:with:with:with:with:with:with: (in category 'api calls') ----- apiRoundRect: aHDC with: left with: top with: right with: bottom with: width with: height "Draws a rectangle with rounded corners. The rectangle is outlined by using the current pen and filled by using the current brush" <apicall: bool 'RoundRect' (Win32HDC long long long long long long) module: 'gdi32.dll'> ^ self externalCallFailed! ----- Method: Win32HDC>>apiSelectObject:with: (in category 'api calls') ----- apiSelectObject: aHDC with: aHGDIOBJ <apicall: Win32HGDIObj 'SelectObject' (Win32HDC Win32HGDIObj) module: 'gdi32.dll'> ^self externalCallFailed! ----- Method: Win32HDC>>delete (in category 'initialize-release') ----- delete handle == nil ifFalse:[self apiDeleteDC: self]. handle := nil.! ----- Method: Win32HDC>>drawFocusRectangle: (in category 'drawing') ----- drawFocusRectangle: aRect "draws a rectangle in the style used to indicate that the rectangle has the focus" self apiDrawFocusRect: self with: (Win32Rectangle fromRectangle: aRect) ! ----- Method: Win32HDC>>drawFrameControl:type:style: (in category 'drawing') ----- drawFrameControl: aRect type: aType style: aStyle "Draws a frame control of the specified type and style (integer values)" self apiDrawFrameControl: self with: (Win32Rectangle fromRectangle: aRect) with: aType with: aStyle! ----- Method: Win32HDC>>ellipse: (in category 'drawing') ----- ellipse: aRect ^self apiEllipse: self with: aRect left with: aRect top with: aRect right with: aRect bottom! ----- Method: Win32HDC>>fillRectangle:color: (in category 'drawing') ----- fillRectangle: aRect color: aColor "fills an area of the display with the given color" | brush | brush := Win32HBrush createSolidBrush: aColor asColorref. self apiFillRect: self with: (Win32Rectangle fromRectangle: aRect) with: brush. brush delete! ----- Method: Win32HDC>>floodFillAt:boundaryColor:fillColor: (in category 'drawing') ----- floodFillAt: aPoint boundaryColor: aColor fillColor: anotherColor "fills an area of the display with the given color" | newBrush oldBrush | newBrush := Win32HBrush createSolidBrush: anotherColor asColorref. oldBrush := self selectObject: newBrush. (self apiExtFloodFill: self with: aPoint x with: aPoint y with: aColor asColorref with: 0) inspect. self selectObject: oldBrush. newBrush delete! ----- Method: Win32HDC>>frameRectangle:brush: (in category 'drawing') ----- frameRectangle: aRect brush: aBrush "Draws a border around the specified rectangle by using the specified brush. The width and height of the border are always one logical unit." self apiFrameRect: self with: (Win32Rectangle fromRectangle: aRect) with: aBrush. ! ----- Method: Win32HDC>>lineTo: (in category 'drawing') ----- lineTo: aPoint ^self apiLineTo: self with: aPoint x with: aPoint y! ----- Method: Win32HDC>>moveTo: (in category 'drawing') ----- moveTo: aPoint ^self apiMoveToEx: self with: aPoint x with: aPoint y with: nil! ----- Method: Win32HDC>>rectangle: (in category 'drawing') ----- rectangle: aRect ^self apiRectangle: self with: aRect left with: aRect top with: aRect right with: aRect bottom! ----- Method: Win32HDC>>roundRectangle:width:height: (in category 'drawing') ----- roundRectangle: aRect width: width height: height ^ self apiRoundRect: self with: aRect left with: aRect top with: aRect right with: aRect bottom with: width with: height! ----- Method: Win32HDC>>selectObject: (in category 'drawing') ----- selectObject: aHGDIOBJ ^self apiSelectObject: self with: aHGDIOBJ! Win32Handle subclass: #Win32HGDIObj instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Win32-Examples'! Win32HGDIObj subclass: #Win32HBrush instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Win32-Examples'! ----- Method: Win32HBrush class>>apiCreateHatchBrush:with: (in category 'api calls') ----- apiCreateHatchBrush: aStyle with: colorref "Creates a logical brush that has the specified hatch pattern and color" <apicall: Win32HBrush 'CreateHatchBrush' (long ulong) module: 'gdi32.dll'> ^ self externalCallFailed! ----- Method: Win32HBrush class>>backwardDiagonalWithColor: (in category 'hatch brushes') ----- backwardDiagonalWithColor: aColor "45-degree downward left-to-right hatch brush" ^ self createHatchBrush: 3 color: aColor! ----- Method: Win32HBrush class>>createHatchBrush:color: (in category 'instance creation') ----- createHatchBrush: aStyle color: aColor "Creates an instance of the receiver that has the specified hatch pattern and color" ^ self apiCreateHatchBrush: aStyle with: aColor asColorref! ----- Method: Win32HBrush class>>createSolidBrush: (in category 'instance creation') ----- createSolidBrush: aCOLORREF <apicall: Win32HBrush 'CreateSolidBrush' (ulong) module: 'gdi32.dll'> ^self externalCallFailed! ----- Method: Win32HBrush class>>crossWithColor: (in category 'hatch brushes') ----- crossWithColor: aColor "Horizontal and vertical crosshatch brush" ^ self createHatchBrush: 4 color: aColor! ----- Method: Win32HBrush class>>diagonalCrossWithColor: (in category 'hatch brushes') ----- diagonalCrossWithColor: aColor "45-degree crosshatch brush" ^ self createHatchBrush: 5 color: aColor! ----- Method: Win32HBrush class>>forwardDiagonalWithColor: (in category 'hatch brushes') ----- forwardDiagonalWithColor: aColor "45-degree upward left-to-right hatch brush" ^ self createHatchBrush: 2 color: aColor! ----- Method: Win32HBrush class>>horizontalWithColor: (in category 'hatch brushes') ----- horizontalWithColor: aColor "Horizontal hatch brush" ^ self createHatchBrush: 0 color: aColor! ----- Method: Win32HBrush class>>verticalWithColor: (in category 'hatch brushes') ----- verticalWithColor: aColor "Horizontal hatch brush" ^ self createHatchBrush: 1 color: aColor ! ----- Method: Win32HGDIObj>>apiDeleteObject: (in category 'api calls') ----- apiDeleteObject: aHGDIOBJ <apicall: bool 'DeleteObject' (Win32HGDIObj) module: 'gdi32.dll'> ^self externalCallFailed! ----- Method: Win32HGDIObj>>delete (in category 'initialize-release') ----- delete self apiDeleteObject: self! ----- Method: Win32Handle class>>fields (in category 'accessing') ----- fields "Win32Handle defineFields" "The following really means typedef void* Win32Handle; " ^#(nil 'ulong') "an opaque 32bit handle"! ExternalStructure subclass: #Win32Point instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Win32-Examples'! ----- Method: Win32Point class>>apiGetCursorPos: (in category 'api calls') ----- apiGetCursorPos: pt <apicall: bool 'GetCursorPos' (Win32Point*) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Point class>>fields (in category 'accessing') ----- fields "POINT defineFields" ^#( (x 'long') (y 'long') )! ----- Method: Win32Point class>>getCursorPos (in category 'instance creation') ----- getCursorPos | pt | pt := self new. self apiGetCursorPos: pt. ^pt! ----- Method: Win32Point>>asPoint (in category 'converting') ----- asPoint ^self x @ self y! ----- Method: Win32Point>>x (in category 'accessing') ----- x "This method was automatically generated" ^handle signedLongAt: 1! ----- Method: Win32Point>>x: (in category 'accessing') ----- x: anObject "This method was automatically generated" handle signedLongAt: 1 put: anObject! ----- Method: Win32Point>>y (in category 'accessing') ----- y "This method was automatically generated" ^handle signedLongAt: 5! ----- Method: Win32Point>>y: (in category 'accessing') ----- y: anObject "This method was automatically generated" handle signedLongAt: 5 put: anObject! ExternalStructure subclass: #Win32Rectangle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Win32-Examples'! ----- Method: Win32Rectangle class>>fields (in category 'accessing') ----- fields "Win32Rectangle defineFields" ^ #(#(#left 'long') #(#top 'long') #(#right 'long') #(#bottom 'long') )! ----- Method: Win32Rectangle class>>fromRectangle: (in category 'instance creation') ----- fromRectangle: rc "returns an instance of the receiver from the given smalltalk rectangle" ^ self new left: rc left top: rc top right: rc right bottom: rc bottom ! ----- Method: Win32Rectangle>>bottom (in category 'accessing') ----- bottom "This method was automatically generated" ^handle signedLongAt: 13! ----- Method: Win32Rectangle>>bottom: (in category 'accessing') ----- bottom: anObject "This method was automatically generated" handle signedLongAt: 13 put: anObject! ----- Method: Win32Rectangle>>left (in category 'accessing') ----- left "This method was automatically generated" ^handle signedLongAt: 1! ----- Method: Win32Rectangle>>left: (in category 'accessing') ----- left: anObject "This method was automatically generated" handle signedLongAt: 1 put: anObject! ----- Method: Win32Rectangle>>left:top:right:bottom: (in category 'accessing') ----- left: left top: top right: right bottom: bottom "sets the coordinates of the receiver" self left: left. self top: top. self right: right. self bottom: bottom ! ----- Method: Win32Rectangle>>right (in category 'accessing') ----- right "This method was automatically generated" ^handle signedLongAt: 9! ----- Method: Win32Rectangle>>right: (in category 'accessing') ----- right: anObject "This method was automatically generated" handle signedLongAt: 9 put: anObject! ----- Method: Win32Rectangle>>top (in category 'accessing') ----- top "This method was automatically generated" ^handle signedLongAt: 5! ----- Method: Win32Rectangle>>top: (in category 'accessing') ----- top: anObject "This method was automatically generated" handle signedLongAt: 5 put: anObject! Object subclass: #Win32Error instanceVariableNames: 'errorCode' classVariableNames: 'ErrorCodes' poolDictionaries: '' category: 'FFI-Win32-Examples'! ----- Method: Win32Error class>>initialize (in category 'as yet unclassified') ----- initialize "Win32Error initialize" ErrorCodes := Dictionary new. ErrorCodes at: 203 put: #('ERROR_ENVVAR_NOT_FOUND' 'There was no environment variable with that name'); yourself! ----- Method: Win32Error class>>lastError (in category 'as yet unclassified') ----- lastError ^(self new) initializeWithLastError! ----- Method: Win32Error class>>win32GetLastError (in category 'as yet unclassified') ----- win32GetLastError "DWORD WINAPI GetLastError(void);" <apicall: ulong 'GetLastError' () module:'kernel32.dll'> ^nil! ----- Method: Win32Error>>errorCode (in category 'as yet unclassified') ----- errorCode ^errorCode! ----- Method: Win32Error>>errorMessage (in category 'as yet unclassified') ----- errorMessage ^(ErrorCodes at: errorCode) at: 2 ifAbsent: ['Unknown Error: ' , errorCode]! ----- Method: Win32Error>>errorName (in category 'as yet unclassified') ----- errorName ^(ErrorCodes at: errorCode) at: 1 ifAbsent: ['ERROR_UNKNOWN_' , errorCode ]! ----- Method: Win32Error>>initializeWithLastError (in category 'as yet unclassified') ----- initializeWithLastError errorCode := self class win32GetLastError.! Object subclass: #Win32Utils instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Win32-Examples'! !Win32Utils commentStamp: 'tbn 8/22/2005 23:50' prior: 0! This is an utility class with helpfull methods for Win32 users. Note that it uses FFI and is platform dependent.! ----- Method: Win32Utils class>>apiFreeEnvironmentStrings: (in category 'api calls') ----- apiFreeEnvironmentStrings: extData "Win32Utils apiFreeEnvironmentStrings" <apicall: long 'FreeEnvironmentStrings' (void*) module: 'kernel32.dll'> ^self externalCallFailed! ----- Method: Win32Utils class>>apiGetEnvironmentStrings (in category 'api calls') ----- apiGetEnvironmentStrings "Win32Utils apiGetEnvironmentStrings" <apicall: byte* 'GetEnvironmentStrings' () module: 'kernel32.dll'> ^self externalCallFailed! ----- Method: Win32Utils class>>apiGetEnvironmentVariable:buffer:size: (in category 'api calls') ----- apiGetEnvironmentVariable: name buffer: buffer size: bufferSize "DWORD WINAPI GetEnvironmentVariable( __in_opt LPCTSTR lpName, __out_opt LPTSTR lpBuffer, __in DWORD nSize );" "http://msdn.microsoft.com/en-us/library/ms683188(VS.85).aspx" <apicall: ulong 'GetEnvironmentVariableA' ( char* byte* ulong) module: 'kernel32.dll'> ^self externalCallFailed! ----- Method: Win32Utils class>>apiSetCursorPosX:y: (in category 'api calls') ----- apiSetCursorPosX: x y: y "this is apparently how to control the mouse cursor pragmatically on windows: http://lists.squeakfoundation.org/pipermail/squeak-dev/2011-February/157676… " <apicall: bool 'SetCursorPos' (long long) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Utils class>>getCommonEnvironmentVariables (in category 'examples') ----- getCommonEnvironmentVariables "Returns a dictionary with common environment variables for Win32 systems" |map| map := Dictionary new. #('ALLUSERSPROFILE' 'APPDATA' 'COMPUTERNAME' 'COMSPEC' 'HOMEDRIVE' 'HOMEPATH' 'LOGONSERVER' 'SYSTEMDRIVE' 'OS' 'PATH' 'SYSTEMROOT' 'TEMP' 'TMP' 'USERDOMAIN' 'USERNAME' 'USERPROFILE' 'WINDIR') do: [:each | map at: each put: (self getEnvironmentVariable: each)]. ^map ! ----- Method: Win32Utils class>>getEnvironmentVariable: (in category 'accessing') ----- getEnvironmentVariable: aString "Win32Utils getEnvironmentVariable: 'windir'" ^ self getEnvironmentVariable: aString ifAbsent: [nil]! ----- Method: Win32Utils class>>getEnvironmentVariable:buffer:ifAbsent: (in category 'accessing') ----- getEnvironmentVariable: name buffer: buffer ifAbsent: block "Win32Utils getEnvironmentVariable: 'APPDATA' " "Win32Utils getEnvironmentVariable: 'APPDATAx' " "http://msdn.microsoft.com/en-us/library/ms683188(VS.85).aspx " | retval err | retval := self apiGetEnvironmentVariable: name buffer: buffer size: buffer byteSize. retval = 0 ifTrue: [ err := Win32Error lastError. ^(err errorName = 'ERROR_ENVVAR_NOT_FOUND') ifTrue: [block value] ifFalse: [ self error: 'Problem with retrieving env var ' , name , '. Code is ' , err errorName. nil ] ]. ^(retval < buffer byteSize) ifTrue: [( buffer copyFrom: 1 to: retval ) asString] ifFalse: [ self getEnvironmentVariable: name buffer: (ByteArray new: retval) ifAbsent: block ]. ! ----- Method: Win32Utils class>>getEnvironmentVariable:ifAbsent: (in category 'accessing') ----- getEnvironmentVariable: name ifAbsent: block "Win32Utils getEnvironmentVariable: 'APPDATA' ifAbsent: [nil]" "Win32Utils getEnvironmentVariable: 'APPDATAx' ifAbsent: [5]" ^self getEnvironmentVariable: name buffer: (ByteArray new: 256) ifAbsent: block! ----- Method: Win32Utils class>>getEnvironmentVariables (in category 'accessing') ----- getEnvironmentVariables "Win32Utils getEnvironmentVariables" | externalData strs | externalData := self apiGetEnvironmentStrings. strs := externalData fromCStrings. self apiFreeEnvironmentStrings: externalData. ^strs ! SharedPool subclass: #Win32Constants instanceVariableNames: '' classVariableNames: 'COLOR_ACTIVEBORDER COLOR_ACTIVECAPTION COLOR_APPWORKSPACE COLOR_BACKGROUND COLOR_BTNFACE COLOR_BTNHIGHLIGHT COLOR_BTNSHADOW COLOR_BTNTEXT COLOR_CAPTIONTEXT COLOR_GRAYTEXT COLOR_HIGHLIGHT COLOR_HIGHLIGHTTEXT COLOR_INACTIVEBORDER COLOR_INACTIVECAPTION COLOR_INACTIVECAPTIONTEXT COLOR_MENU COLOR_MENUTEXT COLOR_SCROLLBAR COLOR_WINDOW COLOR_WINDOWFRAME COLOR_WINDOWTEXT CS_BYTEALIGNCLIENT CS_BYTEALIGNWINDOW CS_CLASSDC CS_DBLCLKS CS_HREDRAW CS_NOCLOSE CS_OWNDC CS_PARENTDC CS_SAVEBITS CS_VREDRAW CW_USEDEFAULT GWL_STYLE HWND_BROADCAST WM_DESTROY WM_MOVE WS_BORDER WS_CAPTION WS_CHILD WS_CHILDWINDOW WS_CLIPCHILDREN WS_CLIPSIBLINGS WS_DISABLED WS_DLGFRAME WS_EX_ACCEPTFILES WS_EX_APPWINDOW WS_EX_CLIENTEDGE WS_EX_CONTEXTHELP WS_EX_CONTROLPARENT WS_EX_DLGMODALFRAME WS_EX_LEFT WS_EX_LEFTSCROLLBAR WS_EX_LTRREADING WS_EX_MDICHILD WS_EX_NOACTIVATE WS_EX_NOPARENTNOTIFY WS_EX_OVERLAPPEDWINDOW WS_EX_PALETTEWINDOW WS_EX_RIGHT WS_EX_RIGHTSCROLLBAR WS_EX_RTLREADING WS_EX_STATICEDGE WS_EX _TOOLWINDOW WS_EX_TOPMOST WS_EX_TRANSPARENT WS_EX_WINDOWEDGE WS_GROUP WS_HSCROLL WS_ICONIC WS_MAXIMIZE WS_MAXIMIZEBOX WS_MINIMIZE WS_MINIMIZEBOX WS_OVERLAPPED WS_OVERLAPPEDWINDOW WS_POPUP WS_POPUPWINDOW WS_SIZEBOX WS_SYSMENU WS_TABSTOP WS_THICKFRAME WS_TILED WS_TILEDWINDOW WS_VISIBLE WS_VSCROLL' poolDictionaries: '' category: 'FFI-Win32-Examples'! ----- Method: Win32Constants class>>initialize (in category 'pool initialization') ----- initialize "Win32Constants initialize" self initializeWindowConstants.! ----- Method: Win32Constants class>>initializeWindowConstants (in category 'pool initialization') ----- initializeWindowConstants GWL_STYLE := -16. WS_EX_ACCEPTFILES := 16r10. WS_EX_APPWINDOW := 16r40000. WS_EX_CLIENTEDGE := 16r200. WS_EX_CONTEXTHELP := 16r400. WS_EX_CONTROLPARENT := 16r10000. WS_EX_DLGMODALFRAME := 16r1. WS_EX_LEFT := 16r0. WS_EX_LEFTSCROLLBAR := 16r4000. WS_EX_LTRREADING := 16r0. WS_EX_MDICHILD := 16r40. WS_EX_NOACTIVATE := 16r8000000. WS_EX_NOPARENTNOTIFY := 16r4. WS_EX_OVERLAPPEDWINDOW := 16r300. WS_EX_PALETTEWINDOW := 16r188. WS_EX_RIGHT := 16r1000. WS_EX_RIGHTSCROLLBAR := 16r0. WS_EX_RTLREADING := 16r2000. WS_EX_STATICEDGE := 16r20000. WS_EX_TOOLWINDOW := 16r80. WS_EX_TOPMOST := 16r8. WS_EX_TRANSPARENT := 16r20. WS_EX_WINDOWEDGE := 16r100. WS_BORDER := 16r800000. WS_CAPTION := 16rC00000. WS_CHILD := 16r40000000. WS_CHILDWINDOW := 16r40000000. WS_CLIPCHILDREN := 16r2000000. WS_CLIPSIBLINGS := 16r4000000. WS_DISABLED := 16r8000000. WS_DLGFRAME := 16r400000. WS_GROUP := 16r20000. WS_HSCROLL := 16r100000. WS_ICONIC := 16r20000000. WS_MAXIMIZE := 16r1000000. WS_MAXIMIZEBOX := 16r10000. WS_MINIMIZE := 16r20000000. WS_MINIMIZEBOX := 16r20000. WS_OVERLAPPED := 16r0. WS_OVERLAPPEDWINDOW := 16rCF0000. WS_POPUP := 16r80000000. WS_POPUPWINDOW := 16r80880000. WS_SIZEBOX := 16r40000. WS_SYSMENU := 16r80000. WS_TABSTOP := 16r10000. WS_THICKFRAME := 16r40000. WS_TILED := 16r0. WS_TILEDWINDOW := 16rCF0000. WS_VISIBLE := 16r10000000. WS_VSCROLL := 16r200000. CS_BYTEALIGNCLIENT := 16r1000. CS_BYTEALIGNWINDOW := 16r2000. CS_CLASSDC := 16r40. CS_DBLCLKS := 16r8. CS_HREDRAW := 16r2. CS_NOCLOSE := 16r200. CS_OWNDC := 16r20. CS_PARENTDC := 16r80. CS_SAVEBITS := 16r800. CS_VREDRAW := 16r1. COLOR_ACTIVEBORDER := 10. COLOR_ACTIVECAPTION := 2. COLOR_APPWORKSPACE := 12. COLOR_BACKGROUND := 1. COLOR_BTNFACE := 15. COLOR_BTNHIGHLIGHT := 20. COLOR_BTNSHADOW := 16. COLOR_BTNTEXT := 18. COLOR_CAPTIONTEXT := 9. COLOR_GRAYTEXT := 17. COLOR_HIGHLIGHT := 13. COLOR_HIGHLIGHTTEXT := 14. COLOR_INACTIVEBORDER := 11. COLOR_INACTIVECAPTION := 3. COLOR_INACTIVECAPTIONTEXT := 19. COLOR_MENU := 4. COLOR_MENUTEXT := 7. COLOR_SCROLLBAR := 0. COLOR_WINDOW := 5. COLOR_WINDOWFRAME := 6. COLOR_WINDOWTEXT := 8. CW_USEDEFAULT := 16r80000000. HWND_BROADCAST := 16rFFFF. WM_DESTROY := 16r2. WM_MOVE := 16r3! Win32Handle subclass: #Win32Window instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'Win32Constants' category: 'FFI-Win32-Examples'! !Win32Window commentStamp: '<historical>' prior: 0! Here's a simple Win32 example: | hwnd dc dst | hwnd _ Win32Window getFocus. "fetch the window currently having the focus" dc _ hwnd getDC. "grab the dc or the window" dst _ 100. dc moveTo: 0@0. "draw a rect" dc lineTo: dst@0. dc lineTo: dst@dst. dc lineTo: 0@dst. dc lineTo: 0@0. "and a cross" dc lineTo: dst@dst. dc moveTo: dst@0. dc lineTo: 0@dst. hwnd releaseDC: dc.! ----- Method: Win32Window class>>coloredEllipses (in category 'examples') ----- coloredEllipses "Win32Window coloredEllipses" "Draw a bunch of ellipses" | rnd pt1 pt2 w h colors newBrush oldBrush | colors := Color colorNames collect:[:cName| (Color perform: cName)]. "convert to COLORREF" colors := colors collect:[:c| (c red * 255) asInteger + ((c green * 255) asInteger << 8) + ((c blue * 255) asInteger << 16)]. rnd := Random new. w := Display width. h := Display height. self getFocus getHDCDuring:[:hDC| [Sensor anyButtonPressed] whileFalse:[ newBrush := Win32HBrush createSolidBrush: colors atRandom. oldBrush := hDC selectObject: newBrush. pt1 := (rnd next * w) asInteger @ (rnd next * h) asInteger. pt2 := (rnd next * w) asInteger @ (rnd next * h) asInteger. hDC ellipse: (Rectangle encompassing: (Array with: pt1 with: pt2)). hDC selectObject: oldBrush. newBrush delete. ]. ]. Display forceToScreen.! ----- Method: Win32Window class>>coloredRectangles (in category 'examples') ----- coloredRectangles "Win32Window coloredRectangles" "Draw a bunch of ellipses" | rnd pt1 pt2 w h colors newBrush oldBrush n nPixels time r | colors := Color colorNames collect:[:cName| (Color perform: cName)]. "convert to COLORREF" colors := colors collect:[:c| (c red * 255) asInteger + ((c green * 255) asInteger << 8) + ((c blue * 255) asInteger << 16)]. rnd := Random new. w := Display width. h := Display height. self getFocus getHDCDuring:[:hDC| n := 0. nPixels := 0. time := Time millisecondClockValue. [Sensor anyButtonPressed] whileFalse:[ newBrush := Win32HBrush createSolidBrush: colors atRandom. oldBrush := hDC selectObject: newBrush. pt1 := (rnd next * w) asInteger @ (rnd next * h) asInteger. pt2 := (rnd next * w) asInteger @ (rnd next * h) asInteger. hDC rectangle: (r := Rectangle encompassing: (Array with: pt1 with: pt2)). hDC selectObject: oldBrush. newBrush delete. n := n + 1. nPixels := nPixels + ((r right - r left) * (r bottom - r top)). (n \\ 100) = 0 ifTrue:[ 'Pixel fillRate: ', (nPixels * 1000 // (Time millisecondClockValue - time)) asStringWithCommas displayAt: 0@0]. ]. ]. Display forceToScreen.! ----- Method: Win32Window class>>getDesktopWindow (in category 'accessing') ----- getDesktopWindow "Return the HWND describing the desktop" <apicall: Win32Window 'GetDesktopWindow' (void) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window class>>getFocus (in category 'accessing') ----- getFocus "Return the HWND currently having the input focus" <apicall: Win32Window 'GetFocus' (void) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window class>>getMainWindowText: (in category 'examples') ----- getMainWindowText: aString "Returns the window text of the main window" self new getWindowText: Win32Window getFocus ! ----- Method: Win32Window class>>getWindowLong:index: (in category 'private') ----- getWindowLong: hwnd index: index "Retrieves information about the specified window." <apicall: Win32Window 'GetWindowLongA' (long long) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window class>>getWindowStyle (in category 'private') ----- getWindowStyle "Returns the window style for the focus window" ^self getWindowLong: self getFocus index: GWL_STYLE ! ----- Method: Win32Window class>>setMainWindowText: (in category 'examples') ----- setMainWindowText: aString "Sets the window text of the main window" self new apiSetWindowText: Win32Window getFocus text: aString! ----- Method: Win32Window class>>setNonResizable (in category 'private') ----- setNonResizable " self setNonResizable " | newStyle | newStyle := self getWindowStyle bitClear: ((WS_SIZEBOX bitOr: WS_MINIMIZE) bitOr: WS_MAXIMIZE). self setWindowLong: self getFocus index: GWL_STYLE value: newStyle. ! ----- Method: Win32Window class>>setWindowLong:index:value: (in category 'private') ----- setWindowLong: hwnd index: index value: value "Sets information about the specified window." <apicall: Win32Window 'SetWindowLongA' (long long long) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window class>>win32Draw (in category 'examples') ----- win32Draw "Win32Window win32Draw" "Draw a bunch of lines using the Windows API" | hWnd hDC pt | hWnd := Win32Window getFocus. hDC := hWnd getDC. hDC moveTo: (hWnd screenToClient: Win32Point getCursorPos). [Sensor anyButtonPressed] whileFalse:[ pt := Win32Point getCursorPos. hWnd screenToClient: pt. hDC lineTo: pt. ]. hWnd releaseDC: hDC. Display forceToScreen.! ----- Method: Win32Window>>apiGetDC: (in category 'api calls') ----- apiGetDC: aHWND <apicall: Win32HDC 'GetDC' (Win32Window) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window>>apiGetParent: (in category 'api calls') ----- apiGetParent: aWindow <apicall: Win32Window 'GetParent' (Win32Window) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window>>apiGetWindowText:buffer:maxCount: (in category 'api calls') ----- apiGetWindowText: handleWindow buffer: aBuffer maxCount: aNumber <apicall: ulong 'GetWindowTextA' (Win32Window char* long) module: 'user32.dll'> self externalCallFailed! ----- Method: Win32Window>>apiMessageBox:text:title:flags: (in category 'api calls') ----- apiMessageBox: aHWND text: aString title: aTitle flags: flags <apicall: long 'MessageBoxA' (Win32Window char* char* ulong) module:'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window>>apiReleaseDC:with: (in category 'api calls') ----- apiReleaseDC: aHWND with: aHDC <apicall: long 'ReleaseDC' (Win32Window Win32HDC) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window>>apiScreenToClient:with: (in category 'api calls') ----- apiScreenToClient: aHWND with: aPOINT <apicall: bool 'ScreenToClient' (Win32Window Win32Point*) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window>>apiSetWindowPosition:insertAfter:x:y:cx:cy:flags: (in category 'api calls') ----- apiSetWindowPosition: handleWindow insertAfter: handleAfterWindow x: x y: y cx: cx cy: cy flags: flags <apicall: bool 'SetWindowPos' (Win32Window Win32Window ulong ulong ulong ulong ulong) module: 'user32.dll'> ^self primitiveFailed ! ----- Method: Win32Window>>apiSetWindowText:text: (in category 'api calls') ----- apiSetWindowText: handleWindow text: aString <apicall: long 'SetWindowTextA' (Win32Window char*) module: 'user32.dll'> ^self externalCallFailed! ----- Method: Win32Window>>getDC (in category 'accessing') ----- getDC "Return the DC associated with the window" ^self apiGetDC: self! ----- Method: Win32Window>>getHDCDuring: (in category 'accessing') ----- getHDCDuring: aBlock "Provide a Win32 HDC during the execution of aBlock" | hDC | hDC := self getDC. [aBlock value: hDC] ensure:[self releaseDC: hDC].! ----- Method: Win32Window>>getParent (in category 'accessing') ----- getParent | wnd | wnd := self apiGetParent: self. ^wnd handle = 0 ifTrue:[nil] ifFalse:[wnd]! ----- Method: Win32Window>>getWindowText: (in category 'api calls') ----- getWindowText: handleWindow "self new getWindowText: Win32Window getFocus" |buffer maxSize | maxSize := 255. buffer := ByteArray new: maxSize. self apiGetWindowText: handleWindow buffer: buffer maxCount: maxSize. ^buffer asString ! ----- Method: Win32Window>>messageBox: (in category 'accessing') ----- messageBox: aString "Win32Window getFocus messageBox:'Hello World'" ^self messageBox: aString title: 'Squeak'! ----- Method: Win32Window>>messageBox:title: (in category 'accessing') ----- messageBox: aString title: aTitle "Win32Window getFocus messageBox:'Hello World' title:'News from Squeak:'" ^self messageBox: aString title: aTitle flags: 0! ----- Method: Win32Window>>messageBox:title:flags: (in category 'accessing') ----- messageBox: aString title: aTitle flags: flags "Win32Window getFocus messageBox:'Are you ready???' title:'News from Squeak:' flags: 3" ^self apiMessageBox: self text: aString title: aTitle flags: flags! ----- Method: Win32Window>>releaseDC: (in category 'accessing') ----- releaseDC: aHDC "Release the given DC" self apiReleaseDC: self with: aHDC! ----- Method: Win32Window>>screenToClient: (in category 'accessing') ----- screenToClient: aPoint self apiScreenToClient: self with: aPoint. ^aPoint! ExternalObject subclass: #Win32File instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Win32-Examples'! ----- Method: Win32File class>>setReadOnly: (in category 'operations') ----- setReadOnly: fileString "Convenient shorthand." ^ (self new) setReadOnly: fileString! ----- Method: Win32File class>>setReadWrite: (in category 'operations') ----- setReadWrite: fileString "Convenient shorthand" ^ (self new) setReadWrite: fileString! ----- Method: Win32File>>getFileAttributes: (in category 'api calls') ----- getFileAttributes: fileString <apicall: ulong 'GetFileAttributesA' (char*) module: 'Kernel32.dll'> ^ self externalCallFailed! ----- Method: Win32File>>setFileAttributes:lpAttrs: (in category 'api calls') ----- setFileAttributes: fileString lpAttrs: aLong <apicall: ulong 'SetFileAttributesA' (char* ulong) module: 'Kernel32.dll'> ^ self externalCallFailed! ----- Method: Win32File>>setReadOnly: (in category 'operations') ----- setReadOnly: fileString "Set FILE_READ_ONLY (bit 1)" | attrs | attrs := (self getFileAttributes: fileString). attrs < 0 ifTrue: [ self error: 'Cannot get file attributes. System error.' ]. (self setFileAttributes: fileString lpAttrs: (attrs bitOr: 1)) = 0 ifTrue: [ self error: 'Cannot set file attributes. System error.' ].! ----- Method: Win32File>>setReadWrite: (in category 'operations') ----- setReadWrite: fileString "Clear FILE_READ_ONLY (bit 1)" | attrs | attrs := (self getFileAttributes: fileString). attrs < 0 ifTrue: [ self error: 'Cannot get file attributes. System error.' ]. (self setFileAttributes: fileString lpAttrs: (attrs bitClear: 1)) = 0 ifTrue: [ self error: 'Cannot set file attributes. System error.' ].! ExternalObject subclass: #Win32Shell instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Win32-Examples'! !Win32Shell commentStamp: '<historical>' prior: 0! This class wrappes the Windows 32 shell. Try Win32Shell new shellOpen: 'c:\image.bmp' to open a document Win32Shell new shellOpen: 'c:\myprogram.exe' to start an executable Win32Shell new shellExplore: 'c:\' to explore a directory Win32Shell new shellFind: 'c:\' to initiate a search Note that this class is platform specific. ! ----- Method: Win32Shell>>shellExecute: (in category 'operations') ----- shellExecute: aFileString "Opens (without opening a window) the file specified by aFileString. The file can be an executable file, a document file, or a folder." | result fileUrlString | "@@@@ CHECKME - jrd - Hackity, hack, hack, hack. Apparently the Win32 url parser doesn't handle %-encoded colons in file paths properly. So we do the conversion ourselves. I'm not sure if the real problem is that we shouldnt be encoding the colons in the first place." fileUrlString := (aFileString asLowercase beginsWith: 'file:') ifTrue: [(aFileString copyReplaceAll: '%3A' with: ':') copyReplaceAll: '%3a' with: ':' ] ifFalse: [aFileString]. result := self shellExecute: nil lpOperation: 'open' lpFile: fileUrlString lpParameters: nil lpDirectory: nil nShowCmd: 0. result <= 32 ifTrue: [self error: 'system error, code:', result printString]! ----- Method: Win32Shell>>shellExecute:lpOperation:lpFile:lpParameters:lpDirectory:nShowCmd: (in category 'api calls') ----- shellExecute: hwnd lpOperation: opString lpFile: fileString lpParameters: parmString lpDirectory: dirString nShowCmd: anInteger "Opens or prints the specified file, which can be an executable or document file. HINSTANCE ShellExecute( HWND hwnd, // handle to parent window LPCTSTR lpOperation, // pointer to string that specifies operation to perform LPCTSTR lpFile, // pointer to filename or folder name string LPCTSTR lpParameters, // pointer to string that specifies executable-file parameters LPCTSTR lpDirectory, // pointer to string that specifies default directory INT nShowCmd // whether file is shown when opened );" <apicall: long 'ShellExecuteA' (long char* char* char* char* ulong) module:'shell32.dll'>! ----- Method: Win32Shell>>shellExplore: (in category 'operations') ----- shellExplore: aPathString "Explores the folder specified by aPathString" | result | result := self shellExecute: nil lpOperation: 'explore' lpFile: aPathString lpParameters: nil lpDirectory: nil nShowCmd: 1. result <= 32 ifTrue: [self error: 'system error, code:', result printString]! ----- Method: Win32Shell>>shellFind: (in category 'operations') ----- shellFind: aPathString "Initiates a search starting from the specified directory." | result | result := self shellExecute: nil lpOperation: 'find' lpFile: nil lpParameters: nil lpDirectory: aPathString nShowCmd: 1. result <= 32 ifTrue: [self error: 'system error, code:', result printString]! ----- Method: Win32Shell>>shellOpen: (in category 'operations') ----- shellOpen: aFileString "Opens the file specified by aFileString. The file can be an executable file, a document file, or a folder." | result fileUrlString | "@@@@ CHECKME - jrd - Hackity, hack, hack, hack. Apparently the Win32 url parser doesn't handle %-encoded colons in file paths properly. So we do the conversion ourselves. I'm not sure if the real problem is that we shouldnt be encoding the colons in the first place." fileUrlString := (aFileString asLowercase beginsWith: 'file:') ifTrue: [(aFileString copyReplaceAll: '%3A' with: ':') copyReplaceAll: '%3a' with: ':' ] ifFalse: [aFileString]. result := self shellExecute: nil lpOperation: 'open' lpFile: fileUrlString lpParameters: nil lpDirectory: nil nShowCmd: 1. result <= 32 ifTrue: [self error: 'system error, code:', result printString]!

1 0

The Inbox: EToys-cbc.294.mcz
by commits＠source.squeak.org 17 Apr '17

17 Apr '17

A new version of EToys was added to project The Inbox: http://source.squeak.org/inbox/EToys-cbc.294.mcz ==================== Summary ==================== Name: EToys-cbc.294 Author: cbc Time: 17 April 2017, 12:55:17.506773 pm UUID: 57edc4cd-53b4-7f4f-8f30-e8037bc062d3 Ancestors: EToys-cbc.293 Remove ExternalForm (and ExternalScreen) since they are not used by EToys, or, indeed, anything in Squeak. =============== Diff against EToys-cbc.293 =============== Item was changed: SystemOrganization addCategory: #'Etoys-Buttons'! SystemOrganization addCategory: #'Etoys-CustomEvents'! SystemOrganization addCategory: #'Etoys-Experimental'! SystemOrganization addCategory: #'Etoys-Outliner'! SystemOrganization addCategory: #'Etoys-Protocols'! SystemOrganization addCategory: #'Etoys-Protocols-Type Vocabularies'! SystemOrganization addCategory: #'Etoys-Scripting'! SystemOrganization addCategory: #'Etoys-Scripting Support'! SystemOrganization addCategory: #'Etoys-Scripting Tiles'! SystemOrganization addCategory: #'Etoys-Squeakland-BroomMorphs-Base'! SystemOrganization addCategory: #'Etoys-Squeakland-BroomMorphs-Connectors'! SystemOrganization addCategory: #'Etoys-Squeakland-EToys-Kedama'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-Buttons'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-Calendar'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-Debugger'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-Help'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-Input'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-Scripting'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-Scripting Support'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-Scripting Tiles'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-SpeechBubbles'! SystemOrganization addCategory: #'Etoys-Squeakland-Etoys-Tile Scriptors'! - SystemOrganization addCategory: #'Etoys-Squeakland-Graphics-External'! SystemOrganization addCategory: #'Etoys-Squeakland-Graphics-Text'! SystemOrganization addCategory: #'Etoys-Squeakland-Graphics-Tools-Intersection'! SystemOrganization addCategory: #'Etoys-Squeakland-Graphics-Tools-Simplification'! SystemOrganization addCategory: #'Etoys-Squeakland-Graphics-Tools-Triangulation'! SystemOrganization addCategory: #'Etoys-Squeakland-MorphicExtras-AdditionalMorphs'! SystemOrganization addCategory: #'Etoys-Squeakland-MorphicExtras-Charts'! SystemOrganization addCategory: #'Etoys-Squeakland-MorphicExtras-Postscript Filters'! SystemOrganization addCategory: #'Etoys-Squeakland-MorphicExtras-WebCam'! SystemOrganization addCategory: #'Etoys-Squeakland-MorphicExtras-Widgets'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Basic'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Books'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Components'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Demo'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Experimental'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Games'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Games-Chess'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-GeeMail'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Kernel'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Mentoring'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Navigators'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-PartsBin'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-PDA'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Support'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Widgets'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Windows'! SystemOrganization addCategory: #'Etoys-Squeakland-Morphic-Worlds'! SystemOrganization addCategory: #'Etoys-Squeakland-Multilingual-Languages'! SystemOrganization addCategory: #'Etoys-Squeakland-Multilingual-TextConversion'! SystemOrganization addCategory: #'Etoys-Squeakland-Network-HTML-Formatter'! SystemOrganization addCategory: #'Etoys-Squeakland-Network-HTML-Forms'! SystemOrganization addCategory: #'Etoys-Squeakland-Network-HTML-Parser'! SystemOrganization addCategory: #'Etoys-Squeakland-Network-HTML-Parser Entities'! SystemOrganization addCategory: #'Etoys-Squeakland-Network-HTML-Tokenizer'! SystemOrganization addCategory: #'Etoys-Squeakland-Network-MIME'! SystemOrganization addCategory: #'Etoys-Squeakland-Network-TelNet WordNet'! SystemOrganization addCategory: #'Etoys-Squeakland-Network-UI'! SystemOrganization addCategory: #'Etoys-Squeakland-Network-Url'! SystemOrganization addCategory: #'Etoys-Squeakland-Protocols-Type Vocabularies'! SystemOrganization addCategory: #'Etoys-Squeakland-Sound-Interface'! SystemOrganization addCategory: #'Etoys-Squeakland-Sound-Ogg'! SystemOrganization addCategory: #'Etoys-Squeakland-Sound-Scores'! SystemOrganization addCategory: #'Etoys-Squeakland-ST80-Morphic'! SystemOrganization addCategory: #'Etoys-Squeakland-SUnit'! SystemOrganization addCategory: #'Etoys-Squeakland-Sugar'! SystemOrganization addCategory: #'Etoys-Squeakland-System-Clipboard-Extended'! SystemOrganization addCategory: #'Etoys-Squeakland-System-Compiler'! SystemOrganization addCategory: #'Etoys-Squeakland-System-Exceptions Kernel'! SystemOrganization addCategory: #'Etoys-Squeakland-System-Support'! SystemOrganization addCategory: #'Etoys-Squeakland-Tools-Changes'! SystemOrganization addCategory: #'Etoys-Squeakland-Tools-Explorer'! SystemOrganization addCategory: #'Etoys-Squeakland-Tools-File Contents Browser'! SystemOrganization addCategory: #'Etoys-Squeakland-Tools-Process Browser'! SystemOrganization addCategory: #'Etoys-Squeakland-Tweak-Kedama-ObjectVectors'! SystemOrganization addCategory: #'Etoys-Squeakland-Tweak-Kedama-ParseTreeTransformer'! SystemOrganization addCategory: #'Etoys-Squeakland-Tweak-Kedama-ParseTree-AttributeDefinition'! SystemOrganization addCategory: #'Etoys-Stacks'! SystemOrganization addCategory: #'Etoys-StarSqueak'! SystemOrganization addCategory: #'Etoys-Support'! SystemOrganization addCategory: #'Etoys-Tests'! SystemOrganization addCategory: #'Etoys-Tile Scriptors'! SystemOrganization addCategory: #'Etoys-Widgets'! SystemOrganization addCategory: #'Etoys-Squeakland-Support'! SystemOrganization addCategory: #'Etoys-Squeakland-SISS-Serialization'! SystemOrganization addCategory: #'Etoys-OLPC-Display'! SystemOrganization addCategory: #'Etoys-ReleaseBuilder'! SystemOrganization addCategory: #'Etoys-UserInterfaceTheme'! Item was removed: - TestCase subclass: #EtoysExternalFormTest - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Etoys-Tests'! Item was removed: - ----- Method: EtoysExternalFormTest>>testBlitToAndFromExternalForm (in category 'as yet unclassified') ----- - testBlitToAndFromExternalForm - "Ensure that we can blit to/from all 4 permutatations of Form and ExternalForm." - | source external1 external2 destination | - source := Cursor wait asCursorForm asFormOfDepth: 32. - destination := Form extent: source extent depth: 32. - external1 := ExternalForm extent: source extent depth: 32. - external2 := ExternalForm extent: source extent depth: 32. - self shouldnt: [source bits = destination bits]. - source displayOn: external1. - external1 displayOn: external2. - external2 displayOn: destination. - self should: [source bits = destination bits].! Item was removed: - Form subclass: #ExternalForm - instanceVariableNames: 'display argbMap' - classVariableNames: '' - poolDictionaries: '' - category: 'Etoys-Squeakland-Graphics-External'! - - !ExternalForm commentStamp: '<historical>' prior: 0! - An ExternalForm is just like any other form. It's only difference is that it is allocated on a specific display and can be used for accelerated blts on the particular display. - - Upon shutdown of the system ExternalForms will be deallocated from the display and be kept in their internalized form.! Item was removed: - ----- Method: ExternalForm>>colormapFromARGB (in category 'accessing') ----- - colormapFromARGB - "Return a ColorMap mapping from canonical ARGB pixel values into the receiver" - ^argbMap ifNil:[argbMap := ColorMap mappingFromARGB: self rgbaBitMasks].! Item was removed: - ----- Method: ExternalForm>>colormapFromARGB: (in category 'accessing') ----- - colormapFromARGB: aMap - "Set the ColorMap mapping from canonical ARGB pixel values into the receiver" - argbMap := aMap! Item was removed: - ----- Method: ExternalForm>>destroy (in category 'initialize-release') ----- - destroy - "Destroy the receiver" - display ifNotNil:[display destroyForm: self]! Item was removed: - ----- Method: ExternalForm>>displayScreen (in category 'accessing') ----- - displayScreen - "Return the display screen the receiver is allocated on." - ^display! Item was removed: - ----- Method: ExternalForm>>getExternalHandle (in category 'private') ----- - getExternalHandle - "Private. Return the virtual handle used to represent the receiver" - ^bits! Item was removed: - ----- Method: ExternalForm>>hasNonStandardPalette (in category 'testing') ----- - hasNonStandardPalette - "Quite possible." - ^display notNil or:[argbMap notNil]! Item was removed: - ----- Method: ExternalForm>>isExternalForm (in category 'testing') ----- - isExternalForm - "I am an external form but only as long as I'm allocated on a display" - ^display notNil! Item was removed: - ----- Method: ExternalForm>>rgbaBitMasks (in category 'accessing') ----- - rgbaBitMasks - "Return the masks for specifying the R,G,B, and A components in the receiver" - display - ifNil:[^super rgbaBitMasks] - ifNotNil:[^display rgbaBitMasksOfForm: self]! Item was removed: - ----- Method: ExternalForm>>setExternalHandle:on: (in category 'private') ----- - setExternalHandle: aHandle on: aDisplay - "Initialize the receiver from the given external handle" - display := aDisplay. - bits := aHandle.! Item was removed: - ----- Method: ExternalForm>>shutDown (in category 'initialize-release') ----- - shutDown - "System is going down. Internalize my bits and be finished." - | copy | - copy := Form extent: self extent depth: self depth. - self displayOn: copy. - copy hibernate. "compact bits of copy" - self destroy. "Release my external handle" - bits := copy bits. "Now compressed" - display := nil. "No longer allocated" - argbMap := nil. "No longer external"! Item was removed: - WeakKeyDictionary subclass: #ExternalFormRegistry - instanceVariableNames: 'lockFlag' - classVariableNames: '' - poolDictionaries: '' - category: 'Etoys-Squeakland-Graphics-External'! - - !ExternalFormRegistry commentStamp: '<historical>' prior: 0! - The ExternalFormRegistry needs to be synchronized with rendering to prevent forms from being destroyed during rendering. Only at certain points (that is after a rendering cycle is completed) the texture registry may be cleaned up.! Item was removed: - ----- Method: ExternalFormRegistry>>finalizeValues (in category 'finalization') ----- - finalizeValues - "This message is sent when an element has gone away." - lockFlag == true ifTrue:[^self]. - self forceFinalization.! Item was removed: - ----- Method: ExternalFormRegistry>>forceFinalization (in category 'finalization') ----- - forceFinalization - self associationsDo:[:assoc| - assoc key isNil ifTrue:[assoc value destroy]. - ]. - super finalizeValues.! Item was removed: - ----- Method: ExternalFormRegistry>>lock (in category 'accessing') ----- - lock - lockFlag := true! Item was removed: - ----- Method: ExternalFormRegistry>>unlock (in category 'accessing') ----- - unlock - lockFlag := false.! Item was removed: - DisplayScreen subclass: #ExternalScreen - instanceVariableNames: 'argbMap allocatedForms' - classVariableNames: '' - poolDictionaries: '' - category: 'Etoys-Squeakland-Graphics-External'! - - !ExternalScreen commentStamp: '<historical>' prior: 0! - I represent a DisplayScreen that is not part of the Squeak universe. Subclasses must implement the appropriate primitives for creating, destroying and allocating the appropriate external objects. - - Note: It is assumed that all external display surfaces are accessible by FXBlt, meaning that any support code must register the surfaces with the surface plugin. This requires that the support code will have a way of accessing the bits of the surface. Although this can be terribly expensive (such as on X where a roundtrip to the server might be required or for an OpenGL display where glReadPixels usually is slow as hell) the appropriate methods should be implemented. This allows for a gradual transition to less expensive model (such as implementing an X11Canvas supporting the drawing primitives of X) and is therefore the preferred solution. - - In the eventual case that it's known that BitBlt/FXBlt will *never* be used in conjunction with a particular drawing surface, the support code should return a handle that is a) not a SmallInteger (these are used by the surface plugin) and b) not of the 'bitsSize' of a Form. One possible representation for such a handle would be a ByteArray of a non-integral word size (e.g., a ByteArray of size 5,6, or 7). In this case, all attempts to use FXBlt with the drawing surface will simply fail. - ! Item was removed: - ----- Method: ExternalScreen>>allocateForm: (in category 'form support') ----- - allocateForm: extentPoint - "Allocate a new form which is similar to the receiver and can be used for accelerated blts" - | formHandle displayForm | - formHandle := self primAllocateForm: self depth width: extentPoint x height: extentPoint y. - formHandle = nil ifTrue:[^super allocateForm: extentPoint]. - displayForm := (ExternalForm extent: extentPoint depth: self depth bits: nil) - setExternalHandle: formHandle on: self. - allocatedForms at: displayForm put: displayForm executor. - ^displayForm! Item was removed: - ----- Method: ExternalScreen>>colormapFromARGB (in category 'accessing') ----- - colormapFromARGB - "Return a ColorMap mapping from canonical ARGB pixel values into the receiver" - ^argbMap ifNil:[argbMap := ColorMap mappingFromARGB: self rgbaBitMasks].! Item was removed: - ----- Method: ExternalScreen>>copyBits:from:at:clippingBox:rule:fillColor:map: (in category 'blitting support') ----- - copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: hf map: map - "Attempt to accelerate blts to the receiver" - | r | - ((self isBltAccelerated: rule for: sourceForm) and:[map == nil and:[hf == nil]]) ifTrue:[ - "Try an accelerated blt" - r := (destOrigin extent: sourceRect extent) intersect: (clipRect intersect: clippingBox). - r area <= 0 ifTrue:[^self]. - (self primBltFast: bits from: sourceForm getExternalHandle - at: r origin from: sourceRect origin - extent: r extent) ifNotNil:[^self]. - ]. - ^super copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: hf map: map! Item was removed: - ----- Method: ExternalScreen>>destroy (in category 'initialize-release') ----- - destroy - "Destroy the receiver" - allocatedForms ifNotNil:[ - allocatedForms lock. "Make sure we don't get interrupted" - allocatedForms forceFinalization. "Clean up all lost references" - allocatedForms keys do:[:stillValid| stillValid shutDown]. - "All remaining references are simply destroyed" - allocatedForms associationsDo:[:assoc| assoc key: nil]. - allocatedForms forceFinalization. "destroy all others" - allocatedForms := nil. - ]. - bits ifNotNil:[self primDestroyDisplaySurface: bits]. - bits := nil.! Item was removed: - ----- Method: ExternalScreen>>destroyForm: (in category 'form support') ----- - destroyForm: anExternalForm - "Destroy the given external form" - self primDestroyForm: anExternalForm getExternalHandle. - anExternalForm setExternalHandle: nil on: nil. - allocatedForms removeKey: anExternalForm ifAbsent:[].! Item was removed: - ----- Method: ExternalScreen>>displayOn:at:clippingBox:rule:fillColor: (in category 'blitting support') ----- - displayOn: destForm at: destOrigin clippingBox: clipRect rule: rule fillColor: hf - "Attempt to accelerate blts to aDisplayMedium" - | sourceRect | - ((self isBltAccelerated: rule for: destForm) and:[hf = nil]) ifTrue:[ - "Try an accelerated blt" - sourceRect := (clipRect translateBy: destOrigin negated) intersect: clippingBox. - (self primBltFast: bits to: destForm getExternalHandle - at: 0@0 from: sourceRect origin - extent: sourceRect extent) ifNotNil:[^self]]. - destForm copyBits: self boundingBox - from: self - at: destOrigin + self offset - clippingBox: clipRect - rule: rule - fillColor: hf - map: (self colormapIfNeededFor: destForm). - ! Item was removed: - ----- Method: ExternalScreen>>fill:rule:fillColor: (in category 'blitting support') ----- - fill: aRectangle rule: anInteger fillColor: aColor - "Replace a rectangular area of the receiver with the pattern described by aForm - according to the rule anInteger." - | rect | - (self isFillAccelerated: anInteger for: aColor) ifTrue:[ - rect := aRectangle intersect: clippingBox. - (self primFill: bits - color: (self pixelWordFor: aColor) - x: rect left - y: rect top - w: rect width - h: rect height) ifNotNil:[^self]]. - ^super fill: aRectangle rule: anInteger fillColor: aColor! Item was removed: - ----- Method: ExternalScreen>>finish (in category 'initialize-release') ----- - finish - "Flush the receiver" - self primFinish: bits. - "Now is the time to do some cleanup" - allocatedForms unlock. - allocatedForms finalizeValues.! Item was removed: - ----- Method: ExternalScreen>>flush (in category 'initialize-release') ----- - flush - "Flush the receiver" - self primFlush: bits.! Item was removed: - ----- Method: ExternalScreen>>hasNonStandardPalette (in category 'testing') ----- - hasNonStandardPalette - "Quite possible." - ^true! Item was removed: - ----- Method: ExternalScreen>>isBltAccelerated:for: (in category 'blitting support') ----- - isBltAccelerated: ruleInteger for: aForm - "Return true if the receiver can perform accelerated blt operations by itself. - It is assumed that blts of forms allocated on the receiverusing Form>>over - may be accelerated. - Although some hardware may allow source-key blts (that is, Form>>paint or similar) - this is usually questionable and the additional effort for allocating and - maintaining the OS form doesn't quite seem worth the effort." - ^aForm displayScreen == self and:[ruleInteger = Form over]! Item was removed: - ----- Method: ExternalScreen>>isExternalForm (in category 'testing') ----- - isExternalForm - "Sorta. Kinda." - ^true! Item was removed: - ----- Method: ExternalScreen>>isFillAccelerated:for: (in category 'blitting support') ----- - isFillAccelerated: ruleInteger for: aColor - "Return true if the receiver can perform accelerated fill operations by itself. - It is assumed that the hardware can accelerate plain color fill operations." - ^ruleInteger = Form over and:[aColor isColor]! Item was removed: - ----- Method: ExternalScreen>>primAllocateForm:width:height: (in category 'primitives-forms') ----- - primAllocateForm: d width: w height: h - "Primitive. Allocate a form with the given parameters" - ^nil! Item was removed: - ----- Method: ExternalScreen>>primBltFast:from:at:from:extent: (in category 'primitives-display') ----- - primBltFast: displayHandle from: sourceHandle at: destOrigin from: sourceOrigin extent: extent - "Primitive. Perform a fast blt operation. Return the receiver if successful." - ^nil! Item was removed: - ----- Method: ExternalScreen>>primBltFast:to:at:from:extent: (in category 'primitives-display') ----- - primBltFast: displayHandle to: dstHandle at: destOrigin from: sourceOrigin extent: extent - "Primitive. Perform a fast blt operation. Return the receiver if successful." - ^nil! Item was removed: - ----- Method: ExternalScreen>>primCreateDisplaySurface:width:height: (in category 'primitives-display') ----- - primCreateDisplaySurface: d width: w height: h - "Primitive. Create a new external display surface. Return the handle used to identify the receiver. Fail if the surface cannot be created." - ^nil! Item was removed: - ----- Method: ExternalScreen>>primDestroyDisplaySurface: (in category 'primitives-display') ----- - primDestroyDisplaySurface: aHandle - "Primitive. Destroy the display surface associated with the given handle." - ^nil! Item was removed: - ----- Method: ExternalScreen>>primDestroyForm: (in category 'primitives-forms') ----- - primDestroyForm: aHandle - "Primitive. Destroy the form associated with the given handle." - ^nil! Item was removed: - ----- Method: ExternalScreen>>primDisplay:colorMasksInto: (in category 'primitives-display') ----- - primDisplay: aHandle colorMasksInto: anArray - "Primitive. Store the bit masks for each color into the given array." - ^nil! Item was removed: - ----- Method: ExternalScreen>>primFill:color:x:y:w:h: (in category 'primitives-display') ----- - primFill: handle color: pixelWord x: x y: y w: w h: h - "Primitive. Perform an accelerated fill operation on the receiver." - ^nil! Item was removed: - ----- Method: ExternalScreen>>primFinish: (in category 'primitives-display') ----- - primFinish: aHandle - "Primitive. Finish all rendering operations on the receiver. - Do not return before all rendering operations have taken effect." - ^nil! Item was removed: - ----- Method: ExternalScreen>>primFlush: (in category 'primitives-display') ----- - primFlush: aHandle - "Primitive. If any rendering operations are pending, force them to be executed. - Do not wait until they have taken effect." - ^nil! Item was removed: - ----- Method: ExternalScreen>>primForm:colorMasksInto: (in category 'primitives-forms') ----- - primForm: aHandle colorMasksInto: anArray - "Primitive. Store the bit masks for each color into the given array." - ^nil! Item was removed: - ----- Method: ExternalScreen>>release (in category 'initialize-release') ----- - release - "I am no longer Display. Release any resources if necessary" - self destroy! Item was removed: - ----- Method: ExternalScreen>>rgbaBitMasks (in category 'accessing') ----- - rgbaBitMasks - "Return the masks for specifying the R,G,B, and A components in the receiver" - | rgbaBitMasks | - rgbaBitMasks := Array new: 4. - self primDisplay: bits colorMasksInto: rgbaBitMasks. - ^rgbaBitMasks! Item was removed: - ----- Method: ExternalScreen>>rgbaBitMasksOfForm: (in category 'form support') ----- - rgbaBitMasksOfForm: anExternalForm - | rgbaBitMasks | - rgbaBitMasks := Array new: 4. - self primForm: anExternalForm getExternalHandle colorMasksInto: rgbaBitMasks. - ^rgbaBitMasks! Item was removed: - ----- Method: ExternalScreen>>setExtent:depth: (in category 'private') ----- - setExtent: aPoint depth: bitsPerPixel - "Create a 3D accelerated display screen" - | screen | - (bits isInteger and:[depth == bitsPerPixel and: [aPoint = self extent and: - [self supportsDisplayDepth: bitsPerPixel]]]) ifFalse: [ - bits ifNotNil:[self primDestroyDisplaySurface: bits]. - bits := nil. "Free up old bitmap in case space is low" - DisplayChangeSignature := (DisplayChangeSignature ifNil: [0]) + 1. - (self supportsDisplayDepth: bitsPerPixel) - ifTrue:[depth := bitsPerPixel] - ifFalse:["Search for a suitable depth" - depth := self findAnyDisplayDepthIfNone:[nil]]. - depth == nil ifFalse:[ - bits := self primCreateDisplaySurface: depth - width: aPoint x height: aPoint y]. - "Bail out if surface could not be created" - (bits == nil) ifTrue:[ - screen := DisplayScreen extent: aPoint depth: bitsPerPixel. - self == Display ifTrue:[ - Display := screen. - Display beDisplay]. - ^screen]. - width := aPoint x. - height := aPoint y. - ]. - clippingBox := super boundingBox. - allocatedForms ifNil:[ - allocatedForms := ExternalFormRegistry new. - WeakArray addWeakDependent: allocatedForms]. - ! Item was removed: - ----- Method: ExternalScreen>>shutDown (in category 'initialize-release') ----- - shutDown - "Minimize Display memory saved in image" - self destroy. - width := 240. - height := 120. - bits := Bitmap new: self bitsSize.! Item was removed: - ----- Method: ExternalScreen>>supportsDisplayDepth: (in category 'primitives-display') ----- - supportsDisplayDepth: pixelDepth - "Return true if this pixel depth is supported on the current host platform." - ^false!

1 0

Crashes on snapshot with the new compactor
by Eliot Miranda 17 Apr '17

17 Apr '17

Hi All, a number of people are being affected by crashes on snapshotting the image, the worst possible time for a crash. There is a bug in the new compactor that unfortunately bites when saving. The compactor is invoked as part of a full garbage collect after the garbage collector has feed unreachable objects. Normally the new compactor makes only a single pass through the heap, which may not move all the objects that are possible to move. (The amount of objects that can be moved in a single pass is limited by available free space.) But on snapshot the compactor makes as may passes as are necessary to slide all movable objects down as far as possible. Unfortunately there is a bug in this second pass. Fixing this bug is now my priority. I have an example image from Esteban Lorenzano to test. I am asking anyone else that can provide an image that reliably crashes when trying to save it to make the image and changes available to me for testing if possible. In the mean time one may be able to work around the problem by doing a full garbage collect before snapshot. This should do a GC with a single compaction pass which should not fail, and then make it much more likely that the GC during snapshot will do a single compaction pass, since fewer objects should be mobile after the single pass compaction in the explicit GC. To do this in Pharo I would put a full gc here: SessionManager>>snapshot: save andQuit: quit | isImageStarting snapshotResult | ChangesLog default logSnapshot: save andQuit: quit. >> SmalltalkImage current primitiveGarbageCollect. self currentSession stop: quit. "Image not usable from here until the session is restarted!" ... In Squeak I would put a full GC here: snapshot: save andQuit: quit withExitCode: exitCode embedded: embeddedFlag "Mark the changes file and close all files as part of #processShutdownList. If save is true, save the current state of this Smalltalk in the image file. If quit is true, then exit to the outer OS shell. If exitCode is not nil, then use it as exit code. The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." | resuming msg | Object flushDependents. Object flushEvents. ... Smalltalk processShutDownList: quit. >> SmalltalkImage current primitiveGarbageCollect. Cursor write show. save ifTrue: [resuming := embeddedFlag ifTrue: [self snapshotEmbeddedPrimitive] ifFalse: [self snapshotPrimitive]] "<-- PC frozen here on image file" ifFalse: [resuming := false]. I do apologise for the bug. I hope it will be fixed within a few days. _,,,^..^,,,_ best, Eliot

6 9

The Inbox: FFI-Tests-cbc.9.mcz
by commits＠source.squeak.org 17 Apr '17

17 Apr '17

A new version of FFI-Tests was added to project The Inbox: http://source.squeak.org/inbox/FFI-Tests-cbc.9.mcz ==================== Summary ==================== Name: FFI-Tests-cbc.9 Author: cbc Time: 17 April 2017, 9:40:36.880187 am UUID: 00985020-cc08-fc49-a7fd-7279da9180c0 Ancestors: FFI-Tests-EstebanLorenzano.8 Remove test on ExternalForm (since it was removed from FFI package - and it was wrong, now, too). Currently in EToys tests. ==================== Snapshot ==================== SystemOrganization addCategory: #'FFI-Tests'! ExternalStructure subclass: #FFISmallStruct1 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Tests'! ----- Method: FFISmallStruct1 class>>fields (in category 'as yet unclassified') ----- fields "FFITestPoint2 defineFields" ^#( (x 'byte') (y 'byte') )! ----- Method: FFISmallStruct1>>x (in category 'accessing') ----- x "This method was automatically generated" ^handle unsignedByteAt: 1! ----- Method: FFISmallStruct1>>x: (in category 'accessing') ----- x: anObject "This method was automatically generated" handle unsignedByteAt: 1 put: anObject! ----- Method: FFISmallStruct1>>y (in category 'accessing') ----- y "This method was automatically generated" ^handle unsignedByteAt: 2! ----- Method: FFISmallStruct1>>y: (in category 'accessing') ----- y: anObject "This method was automatically generated" handle unsignedByteAt: 2 put: anObject! ExternalStructure subclass: #FFITestPoint2 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Tests'! !FFITestPoint2 commentStamp: 'ar 8/14/2006 23:06' prior: 0! A class used for testing structures as arguments for the FFI.! ----- Method: FFITestPoint2 class>>fields (in category 'field definition') ----- fields "FFITestPoint2 defineFields" ^#( (x 'long') (y 'long') )! ----- Method: FFITestPoint2>>x (in category 'accessing') ----- x "This method was automatically generated" ^handle signedLongAt: 1! ----- Method: FFITestPoint2>>x: (in category 'accessing') ----- x: anObject "This method was automatically generated" handle signedLongAt: 1 put: anObject! ----- Method: FFITestPoint2>>y (in category 'accessing') ----- y "This method was automatically generated" ^handle signedLongAt: 5! ----- Method: FFITestPoint2>>y: (in category 'accessing') ----- y: anObject "This method was automatically generated" handle signedLongAt: 5 put: anObject! ExternalStructure subclass: #FFITestPoint4 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Tests'! !FFITestPoint4 commentStamp: 'ar 8/14/2006 23:06' prior: 0! A class used for testing structures as arguments for the FFI.! ----- Method: FFITestPoint4 class>>fields (in category 'field definition') ----- fields "FFITestPoint4 defineFields" ^#( (x 'long') (y 'long') (z 'long') (w 'long') )! ----- Method: FFITestPoint4>>w (in category 'accessing') ----- w "This method was automatically generated" ^handle signedLongAt: 13! ----- Method: FFITestPoint4>>w: (in category 'accessing') ----- w: anObject "This method was automatically generated" handle signedLongAt: 13 put: anObject! ----- Method: FFITestPoint4>>x (in category 'accessing') ----- x "This method was automatically generated" ^handle signedLongAt: 1! ----- Method: FFITestPoint4>>x: (in category 'accessing') ----- x: anObject "This method was automatically generated" handle signedLongAt: 1 put: anObject! ----- Method: FFITestPoint4>>y (in category 'accessing') ----- y "This method was automatically generated" ^handle signedLongAt: 5! ----- Method: FFITestPoint4>>y: (in category 'accessing') ----- y: anObject "This method was automatically generated" handle signedLongAt: 5 put: anObject! ----- Method: FFITestPoint4>>z (in category 'accessing') ----- z "This method was automatically generated" ^handle signedLongAt: 9! ----- Method: FFITestPoint4>>z: (in category 'accessing') ----- z: anObject "This method was automatically generated" handle signedLongAt: 9 put: anObject! TestCase subclass: #FFIPluginTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Tests'! !FFIPluginTests commentStamp: '<historical>' prior: 0! SUnitized tests for the FFI (mostly the plugin side)! ----- Method: FFIPluginTests>>testConstructedCharCall (in category 'simple tests') ----- testConstructedCharCall "Test using generic FFI spec" | result meth | meth := ExternalLibraryFunction name:'ffiTestChars' module: FFITestLibrary moduleName callType: 0 returnType: ExternalType char argumentTypes: ((1 to: 4) collect:[:i| ExternalType char]). result := meth invokeWith: $A with: 65 with: 65.0 with: true. self assert: result isCharacter. self assert: result asciiValue = 130.! ----- Method: FFIPluginTests>>testConstructedDoubleCall (in category 'simple tests') ----- testConstructedDoubleCall "Test using generic FFI spec" | result meth | meth := ExternalLibraryFunction name:'ffiTestDoubles' module: FFITestLibrary moduleName callType: 0 returnType: ExternalType double argumentTypes: ((1 to: 2) collect:[:i| ExternalType double]). result := meth invokeWithArguments: (Array with: 41 with: true). self assert: result = 42.0! ----- Method: FFIPluginTests>>testConstructedFloatCall (in category 'simple tests') ----- testConstructedFloatCall "Test using generic FFI spec" | result meth | meth := ExternalLibraryFunction name:'ffiTestFloats' module: FFITestLibrary moduleName callType: 0 returnType: ExternalType float argumentTypes: ((1 to: 2) collect:[:i| ExternalType float]). result := meth invokeWith: $A with: 65.0. self assert: result = 130.0! ----- Method: FFIPluginTests>>testConstructedIntCall (in category 'simple tests') ----- testConstructedIntCall "Test using generic FFI spec" | result meth | meth := ExternalLibraryFunction name:'ffiTestInts' module: FFITestLibrary moduleName callType: 0 returnType: ExternalType long argumentTypes: ((1 to: 4) collect:[:i| ExternalType long]). result := meth invokeWith: $A with: 65 with: 65.0 with: true. self assert: result = 130.! ----- Method: FFIPluginTests>>testConstructedPrintString (in category 'simple tests') ----- testConstructedPrintString "Test using generic FFI spec" | result meth | meth := ExternalLibraryFunction name:'ffiPrintString' module: FFITestLibrary moduleName callType: 0 returnType: ExternalType string argumentTypes: ((1 to: 1) collect:[:i| ExternalType string]). result := meth invokeWith:'Hello World!!'. self assert: result = 'Hello World!!'.! ----- Method: FFIPluginTests>>testConstructedShortCall (in category 'simple tests') ----- testConstructedShortCall "Test using generic FFI spec" | result meth | meth := ExternalLibraryFunction name:'ffiTestShorts' module: FFITestLibrary moduleName callType: 0 returnType: ExternalType short argumentTypes: ((1 to: 4) collect:[:i| ExternalType short]). result := meth invokeWithArguments: (Array with: $A with: 65 with: 65.0 with: true). self assert: result = 130.! ----- Method: FFIPluginTests>>testGenericCharCall (in category 'simple tests') ----- testGenericCharCall "Test using generic FFI spec" | result | result := FFITestLibrary ffiTestChar: $A with: 65 with: 65.0 with: true. self assert: result isCharacter. self assert: result asciiValue = 130.! ----- Method: FFIPluginTests>>testGenericDoubleCall (in category 'simple tests') ----- testGenericDoubleCall "Test using generic FFI spec" | result | result := FFITestLibrary ffiTestDoubles: $A with: 65.0. self assert: result = 130.0! ----- Method: FFIPluginTests>>testGenericDoubleCall2 (in category 'simple tests') ----- testGenericDoubleCall2 "Test using generic FFI spec" | result | result := FFITestLibrary ffiTestDoubles9: 1.0 d: 2.0 d: 3.0 d: 4.0 d: 5.0 d: 6.0 d: 7.0 d: 8.0 d: 9.0. self assert: result = 45.0! ----- Method: FFIPluginTests>>testGenericFloatCall (in category 'simple tests') ----- testGenericFloatCall "Test using generic FFI spec" | result | result := FFITestLibrary ffiTestFloats: $A with: 65.0. self assert: result = 130.0! ----- Method: FFIPluginTests>>testGenericIntCall (in category 'simple tests') ----- testGenericIntCall "Test using generic FFI spec" | result | result := FFITestLibrary ffiTestInt: $A with: 65 with: 65.0 with: true. self assert: result = 130.! ----- Method: FFIPluginTests>>testGenericMixedDoublesIntAndStruct (in category 'simple tests') ----- testGenericMixedDoublesIntAndStruct "Test using generic FFI spec" | result i struct | i := 42. struct := FFITestPoint4 new. struct x: 1. struct y: 2. struct z: 3. struct w: 4. result := FFITestLibrary ffiTestMixedDoublesIntAndStruct: 1.0 d: 2.0 d: 3.0 d: 4.0 d: 5.0 d: 6.0 d: 7.0 d: 8.0 d: 9.0 i: 42 s: struct. self assert: (result closeTo: 45.0 + 42 + 10) ! ----- Method: FFIPluginTests>>testGenericMixedFloatsAndDouble (in category 'simple tests') ----- testGenericMixedFloatsAndDouble "Test using generic FFI spec" | result | result := FFITestLibrary ffiTestMixedFloatsAndDouble: 1.2 with: 3.4 with: 5.6 with: 7.8. self assert: (result closeTo: 1.2 + 3.4 + 5.6 + 7.8) ! ----- Method: FFIPluginTests>>testGenericPrintString (in category 'simple tests') ----- testGenericPrintString "Test using generic FFI spec" | result | result := FFITestLibrary ffiPrintString:'Hello World!!'. self assert: result = 'Hello World!!'.! ----- Method: FFIPluginTests>>testGenericShortCall (in category 'simple tests') ----- testGenericShortCall "Test using generic FFI spec" | result | result := FFITestLibrary ffiTestShort: $A with: 65 with: 65.0 with: true. self assert: result = 130.! ----- Method: FFIPluginTests>>testLibraryCharCall (in category 'simple tests') ----- testLibraryCharCall "Test using call from ExternalLibrary" | result | result := FFITestLibrary new ffiTestChar: $A with: 65 with: 65.0 with: true. self assert: result isCharacter. self assert: result asciiValue = 130.! ----- Method: FFIPluginTests>>testLibraryDoubleCall (in category 'simple tests') ----- testLibraryDoubleCall "Test using call from ExternalLibrary" | result | result := FFITestLibrary new ffiTestDoubles: $A with: 65.0. self assert: result = 130.0! ----- Method: FFIPluginTests>>testLibraryFloatCall (in category 'simple tests') ----- testLibraryFloatCall "Test using call from ExternalLibrary" | result | result := FFITestLibrary new ffiTestFloats: $A with: 65.0. self assert: result = 130.0! ----- Method: FFIPluginTests>>testLibraryIntCall (in category 'simple tests') ----- testLibraryIntCall "Test using call from ExternalLibrary" | result | result := FFITestLibrary new ffiTestInt: $A with: 65 with: 65.0 with: true. self assert: result = 130.! ----- Method: FFIPluginTests>>testLibraryPrintString (in category 'simple tests') ----- testLibraryPrintString "Test using call from ExternalLibrary" | result | result := FFITestLibrary new ffiPrintString:'Hello World!!'. self assert: result = 'Hello World!!'.! ----- Method: FFIPluginTests>>testLoadSymbolFromModule (in category 'other tests') ----- testLoadSymbolFromModule | address | "Ok" address := ExternalAddress loadSymbol: 'ffiTestFloats' module: FFITestLibrary moduleName. self deny: address isNil. self deny: address isNull. "Symbol does not exists" self should: [ ExternalAddress loadSymbol: 'ffi_does_not_exist' module: FFITestLibrary moduleName ] raise: Error. "Module does not exists" self should: [ ExternalAddress loadSymbol: 'ffiTestFloats' module: 'NonExistingModule' ] raise: Error. ! ----- Method: FFIPluginTests>>testLongLongA1 (in category 'simple tests') ----- testLongLongA1 "Test passing a char and two longlongs." | byte long1 long2 long3 | byte := 42. long1 := 16r123456789012. long2 := (-1 << 31). long3 := FFITestLibrary ffiTestLongLongA1: byte with: long1 with: long2. self assert: long3 = (byte + long1 + long2)! ----- Method: FFIPluginTests>>testLongLongA3 (in category 'simple tests') ----- testLongLongA3 "Test passing a char, a longlong, and another char." | byte1 long1 byte2 long2 | byte1 := 3. long1 := 16r123456789012. byte2 := 4. long2 := FFITestLibrary ffiTestLongLongA3: byte1 with: long1 with: byte2. self assert: long2 = (byte1 + long1 + byte2)! ----- Method: FFIPluginTests>>testLongLongs (in category 'simple tests') ----- testLongLongs "Test passing and returning longlongs" | long1 long2 long3 | long1 := 16r123456789012. long2 := (-1 << 31). long3 := FFITestLibrary ffiTestLongLong: long1 with: long2. self assert: long3 = (long1 + long2)! ----- Method: FFIPluginTests>>testMixedIntAndStruct (in category 'structure tests') ----- testMixedIntAndStruct "Test passing an integer and two structures." | i1 pt1 pt2 result | i1 := 42. pt1 := FFITestPoint2 new. pt1 x: 3. pt1 y: 4. pt2 := FFITestPoint2 new. pt2 x: 5. pt2 y: 6. result := FFITestLibrary ffiTestMixedIntAndStruct: i1 with: pt1 with: pt2. self assert: result = 60.! ----- Method: FFIPluginTests>>testMixedIntAndStruct2 (in category 'structure tests') ----- testMixedIntAndStruct2 "Test passing an integer and two structures." | i1 pt1 result | i1 := 42. pt1 := FFITestPoint4 new. pt1 x: 3. pt1 y: 4. pt1 z: 5. pt1 w: 6. result := FFITestLibrary ffiTestMixedIntAndStruct2: i1 with: pt1. self assert: result = 60.! ----- Method: FFIPluginTests>>testMixedIntAndStruct3 (in category 'structure tests') ----- testMixedIntAndStruct3 "Test passing an integer and a small structure." | i1 pt1 result | i1 := 42. pt1 := FFISmallStruct1 new. pt1 x: 3. pt1 y: 4. result := FFITestLibrary ffiTestMixedIntAndStruct3: i1 with: pt1. self assert: result = 49! ----- Method: FFIPluginTests>>testPoint2 (in category 'structure tests') ----- testPoint2 "Test passing and returning up of structures >32bit and <= 64 bit" | pt1 pt2 pt3 | pt1 := FFITestPoint2 new. pt1 x: 1. pt1 y: 2. pt2 := FFITestPoint2 new. pt2 x: 3. pt2 y: 4. pt3 := FFITestLibrary ffiTestPoint2: pt1 with: pt2. self assert: pt3 x = 4. self assert: pt3 y = 6.! ----- Method: FFIPluginTests>>testPoint4 (in category 'structure tests') ----- testPoint4 "Test passing and returning up of structures > 64 bit" | pt1 pt2 pt3 | pt1 := FFITestPoint4 new. pt1 x: 1. pt1 y: 2. pt1 z: 3. pt1 w: 4. pt2 := FFITestPoint4 new. pt2 x: 5. pt2 y: 6. pt2 z: 7. pt2 w: 8. pt3 := FFITestLibrary ffiTestPoint4: pt1 with: pt2. self assert: pt3 x = 6. self assert: pt3 y = 8. self assert: pt3 z = 10. self assert: pt3 w = 12.! ----- Method: FFIPluginTests>>testPointers (in category 'structure tests') ----- testPointers "Test passing and returning of pointers to structs" | pt1 pt2 pt3 | pt1 := FFITestPoint4 new. pt1 x: 1. pt1 y: 2. pt1 z: 3. pt1 w: 4. pt2 := FFITestPoint4 new. pt2 x: 5. pt2 y: 6. pt2 z: 7. pt2 w: 8. pt3 := FFITestLibrary ffiTestPointers: pt1 with: pt2. self assert: pt3 x = 6. self assert: pt3 y = 8. self assert: pt3 z = 10. self assert: pt3 w = 12.! ----- Method: FFIPluginTests>>testSmallStructureReturn (in category 'structure tests') ----- testSmallStructureReturn "Test returning small structures (<4 bytes) which are returned in a register on some platforms." | pt1 | pt1 := FFITestLibrary ffiTestSmallStructReturn. self assert: pt1 x = 3. self assert: pt1 y = 4.! ----- Method: FFIPluginTests>>testUlongRange (in category 'simple tests') ----- testUlongRange "Simple test for making sure the FFI can call certain numbers in the ulong range" | result | self shouldnt:[result := FFITestLibrary ffiTestUlong: 3103854339 with: 3103854339 with: 3103854339 with: 3103854339] raise: Error. self should: result = 1912741382.! ExternalLibrary subclass: #FFITestLibrary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Tests'! !FFITestLibrary commentStamp: 'ar 8/14/2006 23:06' prior: 0! ExternalLibrarty used in FFI tests! ----- Method: FFITestLibrary class>>ffiPrintString: (in category 'primitives') ----- ffiPrintString: aString "FFITestLibrary ffiPrintString: 'Hello'" <cdecl: char* 'ffiPrintString' (char *) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestChar:with:with:with: (in category 'primitives') ----- ffiTestChar: c1 with: c2 with: c3 with: c4 "FFITestLibrary ffiTestChar: $A with: 65 with: 65.0 with: true" <cdecl: char 'ffiTestChars' (char char char char) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestDoubles9:d:d:d:d:d:d:d:d: (in category 'primitives') ----- ffiTestDoubles9: f1 d: f2 d: f3 d: f4 d: f5 d: f6 d: f7 d: f8 d: f9 "FFITestLibrary ffiTestDoubles9: 1.0 d: 2.0 d: 3.0 d: 4.0 d: 5.0 d: 6.0 d: 7.0 d: 8.0 d: 9.0" <cdecl: double 'ffiTestDoubles9' (double double double double double double double double double) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestDoubles:with: (in category 'primitives') ----- ffiTestDoubles: f1 with: f2 "FFITestLibrary ffiTestDoubles: $A with: 65.0" <cdecl: double 'ffiTestDoubles' (double double) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestFloats:with: (in category 'primitives') ----- ffiTestFloats: f1 with: f2 "FFITestLibrary ffiTestFloats: $A with: 65.0" <cdecl: float 'ffiTestFloats' (float float) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestInt:with:with:with: (in category 'primitives') ----- ffiTestInt: c1 with: c2 with: c3 with: c4 "FFITestLibrary ffiTestInt: $A with: 65 with: 65.0 with: true" <cdecl: long 'ffiTestInts' (long long long long) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestLongLong:with: (in category 'primitives') ----- ffiTestLongLong: long1 with: long2 "FFITestLibrary ffiTestLongLong: 3 with: 4" <cdecl: longlong 'ffiTestLongLong' (longlong longlong) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestLongLongA1:with:with: (in category 'primitives') ----- ffiTestLongLongA1: byte with: long1 with: long2 "FFITestLibrary ffiTestLongLongA1: 3 with: 4 with: 5" <cdecl: longlong 'ffiTestLongLonga1' (char longlong longlong) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestLongLongA3:with:with: (in category 'primitives') ----- ffiTestLongLongA3: byte1 with: long1 with: byte2 "FFITestLibrary ffiTestLongLongA3: 3 with: 4 with: 5" <cdecl: longlong 'ffiTestLongLonga3' (char longlong char) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestMixedDoublesIntAndStruct:d:d:d:d:d:d:d:d:i:s: (in category 'primitives') ----- ffiTestMixedDoublesIntAndStruct: f1 d: f2 d: f3 d: f4 d: f5 d: f6 d: f7 d: f8 d: f9 i: i1 s: s1 "FFITestLibrary ffiTestMixedDoublesIntAndStruct: 1.0 d: 2.0 d: 3.0 d: 4.0 d: 5.0 d: 6.0 d: 7.0 d: 8.0 d: 9.0 i: 42 s: (FFITestPoint4 new x: 3; y: 4; z: 5; w:6)" <cdecl: double 'ffiTestMixedDoublesIntAndStruct' (double double double double double double double double double long FFITestPoint4) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestMixedFloatsAndDouble:with:with:with: (in category 'primitives') ----- ffiTestMixedFloatsAndDouble: f1 with: d1 with: f2 with: f3 "FFITestLibrary ffiTestMixedFloatsAndDouble: 1.2 with: 3.4 with: 5.6 with: 7.8" <cdecl: double 'ffiTestMixedFloatsAndDouble' (float double float float) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestMixedIntAndStruct2:with: (in category 'primitives') ----- ffiTestMixedIntAndStruct2: i with: pt4 "FFITestLibrary ffiTestMixedIntAndStruct2: 2 with: (FFITestPoint4 new x: 3; y: 4; z: 5; w:6)" <cdecl: long 'ffiTestMixedIntAndStruct2' (long FFITestPoint4) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestMixedIntAndStruct3:with: (in category 'primitives') ----- ffiTestMixedIntAndStruct3: i with: anFFISmallStruct1 "FFITestLibrary ffiTestMixedIntAndStruct3: 2 with: (FFISmallStruct1 new x: 3; y: 4)" <cdecl: long 'ffiTestMixedIntAndStruct3' (long FFISmallStruct1) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestMixedIntAndStruct:with:with: (in category 'primitives') ----- ffiTestMixedIntAndStruct: i with: pt1 with: pt2 "FFITestLibrary ffiTestMixedIntAndStruct: 2 with: (FFITestPoint2 new x: 3; y: 4) with: (FFITestPoint2 new x: 5; y: 6)" <cdecl: long 'ffiTestMixedIntAndStruct' (long FFITestPoint2 FFITestPoint2) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestPoint2:with: (in category 'primitives') ----- ffiTestPoint2: pt1 with: pt2 <cdecl: FFITestPoint2 'ffiTestStruct64' (FFITestPoint2 FFITestPoint2) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestPoint4:with: (in category 'primitives') ----- ffiTestPoint4: pt1 with: pt2 <cdecl: FFITestPoint4 'ffiTestStructBig' (FFITestPoint4 FFITestPoint4) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestPointers:with: (in category 'primitives') ----- ffiTestPointers: pt1 with: pt2 <cdecl: FFITestPoint4* 'ffiTestPointers' (FFITestPoint4* FFITestPoint4*) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestShort:with:with:with: (in category 'primitives') ----- ffiTestShort: c1 with: c2 with: c3 with: c4 "FFITestLibrary ffiTestShort: $A with: 65 with: 65.0 with:1" <cdecl: short 'ffiTestShorts' (short short short short) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestSmallStructReturn (in category 'primitives') ----- ffiTestSmallStructReturn "FFITestLibrary ffiTestSmallStructReturn" <cdecl: FFISmallStruct1 'ffiTestSmallStructReturn' (void) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>ffiTestUlong:with:with:with: (in category 'primitives') ----- ffiTestUlong: c1 with: c2 with: c3 with: c4 "FFITestLibrary ffiTestUlong: 3103854339 with: 3103854339 with: 3103854339 with: 3103854339" <cdecl: long 'ffiTestInts' (ulong ulong ulong ulong) module:'SqueakFFIPrims'> ^self externalCallFailed! ----- Method: FFITestLibrary class>>moduleName (in category 'accessing') ----- moduleName "Use the fully qualified VM name so we ensure testing loading a library" ^'SqueakFFIPrims'! ----- Method: FFITestLibrary>>ffiPrintString: (in category 'primitives') ----- ffiPrintString: aString "FFITestLibrary new ffiPrintString: 'Hello'" <cdecl: char* 'ffiPrintString' (char *)> ^self externalCallFailed! ----- Method: FFITestLibrary>>ffiTestChar:with:with:with: (in category 'primitives') ----- ffiTestChar: c1 with: c2 with: c3 with: c4 "FFITestLibrary new ffiTestChar: $A with: 65 with: 65.0 with: true" <cdecl: char 'ffiTestChars' (char char char char)> ^self externalCallFailed! ----- Method: FFITestLibrary>>ffiTestDoubles:with: (in category 'primitives') ----- ffiTestDoubles: f1 with: f2 "FFITestLibrary new ffiTestDoubles: $A with: 65.0" <cdecl: double 'ffiTestDoubles' (double double)> ^self externalCallFailed! ----- Method: FFITestLibrary>>ffiTestFloats:with: (in category 'primitives') ----- ffiTestFloats: f1 with: f2 "FFITestLibrary new ffiTestFloats: $A with: 65.0" <cdecl: float 'ffiTestFloats' (float float)> ^self externalCallFailed! ----- Method: FFITestLibrary>>ffiTestInt:with:with:with: (in category 'primitives') ----- ffiTestInt: c1 with: c2 with: c3 with: c4 "FFITestLibrary new ffiTestInt: $A with: 65 with: 65.0 with: $A" <cdecl: long 'ffiTestInts' (long long long long)> ^self externalCallFailed! ----- Method: FFITestLibrary>>ffiTestShort:with:with:with: (in category 'primitives') ----- ffiTestShort: c1 with: c2 with: c3 with: c4 "FFITestLibrary new ffiTestShort: $A with: 65 with: 65.0 with: $A" <cdecl: short 'ffiTestShorts' (short short short short)> ^self externalCallFailed!

1 0

UK Smalltalk User Group meeting - Monday, 24th April
by Giovanni Corriga 17 Apr '17

17 Apr '17

The next meeting of the UK Smalltalk User Group Meeting will be on Monday, 24th April. We'll meet at our usual venue The Counting House ( http://www.the-counting-house.com/) at 7pm. If you'd like to join us, you can just show up at the pub. You can also sign up in advance at the meeting's Meetup page: https://www.meetup.com/UKSTUG/events/238935668/ . See you there!

1 0

← Newer
1
...
10
11
12
13
14
15
16
...
23
Older →

Jump to page: