Packages May 2021

packages@lists.squeakfoundation.org

1 participants
169 discussions

FFI: FFI-Libraries-mt.1.mcz
by commits＠source.squeak.org 27 May '21

27 May '21

Marcel Taeumel uploaded a new version of FFI-Libraries to project FFI: http://source.squeak.org/FFI/FFI-Libraries-mt.1.mcz ==================== Summary ==================== Name: FFI-Libraries-mt.1 Author: mt Time: 27 May 2021, 9:37:20.525843 am UUID: a4ac2929-b61c-af4b-bfde-aba6092bec57 Ancestors: New package that provides a base layer for FFI-backed system functions. For now, there are only some rough sketches for platform-specific I/O and an excerpt from LibC to be used in tests. Another candidate for this package could be the interface to SDL2. Note that future development might reveal the need to split up this package. For now, we are fine, I suppose, since its contents only resemble a construction site. :-D ==================== Snapshot ==================== SystemOrganization addCategory: #'FFI-Libraries-LibC'! SystemOrganization addCategory: #'FFI-Libraries-MacOS'! SystemOrganization addCategory: #'FFI-Libraries-Win32'! SystemOrganization addCategory: #'FFI-Libraries-X11'! 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-Libraries-Win32'! ----- 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! SharedPool subclass: #Win32ShellErrors instanceVariableNames: 'errorNumber description' classVariableNames: 'ERROR_BAD_FORMAT ERROR_FILE_NOT_FOUND ERROR_PATH_NOT_FOUND OUT_OF_MEMORY_OR_RESOURCES SE_ERR_ACCESSDENIED SE_ERR_ACCOSINCOMPLETE SE_ERR_DDEBUSY SE_ERR_DDEFAIL SE_ERR_DDETIMEOUT SE_ERR_DDLNOTFOUND SE_ERR_FNF SE_ERR_NOASSOC SE_ERR_OOM SE_ERR_PNF SE_ERR_SHARE' poolDictionaries: '' category: 'FFI-Libraries-Win32'! Win32ShellErrors class instanceVariableNames: 'errors'! Win32ShellErrors class instanceVariableNames: 'errors'! ----- Method: Win32ShellErrors class>>initialize (in category 'as yet unclassified') ----- initialize self initializeWindowConstants! ----- Method: Win32ShellErrors class>>initializeWindowConstants (in category 'as yet unclassified') ----- initializeWindowConstants OUT_OF_MEMORY_OR_RESOURCES := self new errorNumber: 0; description: 'The operating system is out of memory or resources'. SE_ERR_FNF := self new errorNumber: 2; description: 'The specified file was not found'. SE_ERR_PNF := self new errorNumber: 3; description: 'The specified path was not found'. SE_ERR_ACCESSDENIED := self new errorNumber: 5; description: 'The operating system denied access to the specified file'. SE_ERR_OOM := self new errorNumber: 8; description: 'There was not enough memory to complete the operation'. ERROR_BAD_FORMAT := self new errorNumber: 11; description: 'The .EXE file is invalid (non-Win32 .EXE or error in .EXE image)'. SE_ERR_SHARE := self new errorNumber: 26; description: 'A sharing violation occurred'. SE_ERR_ACCOSINCOMPLETE := self new errorNumber: 27; description: 'The filename association is incomplete or invalid'. SE_ERR_DDETIMEOUT := self new errorNumber: 28; description: 'The DDE transaction could not be completed because the request timed out'. SE_ERR_DDEFAIL := self new errorNumber: 29; description: 'The DDE transaction failed'. SE_ERR_DDEBUSY := self new errorNumber: 30; description: 'The DDE transaction could not be completed because other DDE transactions were being processed'. SE_ERR_NOASSOC := self new errorNumber: 31; description: 'There is no application associated with the given filename extension'. SE_ERR_DDLNOTFOUND := self new errorNumber: 32; description: 'The specified dynamic-link library was not found'. errors := Dictionary new: (self allInstances size). self allInstances do: [:err| errors at: err errorNumber put: err ].! ----- Method: Win32ShellErrors class>>signal: (in category 'as yet unclassified') ----- signal: code | err | err := errors at: code ifAbsent: [Error signal: 'system error, code:', code]. Error signal: err errorString! ----- Method: Win32ShellErrors>>description (in category 'accessing') ----- description ^ description ! ----- Method: Win32ShellErrors>>description: (in category 'accessing') ----- description: anObject description := anObject. ! ----- Method: Win32ShellErrors>>errorNumber (in category 'accessing') ----- errorNumber ^ errorNumber ! ----- Method: Win32ShellErrors>>errorNumber: (in category 'accessing') ----- errorNumber: anObject errorNumber := anObject. ! ----- Method: Win32ShellErrors>>errorString (in category 'accessing') ----- errorString ^'system error, code: ', errorNumber, ' "', description, '"'! Object subclass: #Win32Error instanceVariableNames: 'errorCode' classVariableNames: 'ErrorCodes' poolDictionaries: '' category: 'FFI-Libraries-Win32'! ----- 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-Libraries-Win32'! !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>>apiGetUserBuffer:size: (in category 'api calls') ----- apiGetUserBuffer: buffer size: bufferSize "BOOL WINAPI GetUserNameA( __out_opt LPSTR lpBuffer, __in LPDWORD pcbBuffer );" "https://docs.microsoft.com/en-us/windows/desktop/api/winbase/nf-winbase-get…" <apicall: ulong 'GetUserNameA' ( byte* long* ) module: 'Advapi32.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>>getCurrentUser (in category 'accessing') ----- getCurrentUser " Win32Utils getCurrentUser " | nm sz | sz := (ByteArray new: 8). sz longAt: 1 put: 256 bigEndian: false. self apiGetUserBuffer: (nm := ByteArray new: 256) size: sz. ^(nm copyUpTo: 0) asString! ----- 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 ! ExternalPool subclass: #Win32Pool instanceVariableNames: '' classVariableNames: 'WIN32_WINNT_VISTA WIN32_WINNT_WIN10 WIN32_WINNT_WIN7 WIN32_WINNT_WIN8 WIN32_WINNT_WINXP' poolDictionaries: '' category: 'FFI-Libraries-Win32'! ----- Method: Win32Pool class>>winver (in category 'definitions') ----- winver " self winver writePoolData. self winver readPoolData. " <ffiExternalPool> <ffiPoolDataStorage: #methodSource> <ffiPlatformName: 'Win32'> <ffiCHeaders: #('<sdkddkver.h>')> <ffiVariable: #_WIN32_WINNT_WINXP> <ffiVariable: #_WIN32_WINNT_VISTA> <ffiVariable: #_WIN32_WINNT_WIN7> <ffiVariable: #_WIN32_WINNT_WIN8> <ffiVariable: #_WIN32_WINNT_WIN10> ^ self poolDefinition! ----- Method: Win32Pool class>>winverData (in category 'definitions - data') ----- winverData "Automatically generated." <ffiPoolReadWriter: #ExternalPoolST1ReadWriter> <ffiPoolDataStorage: #methodSource> " Win32Pool winver readPoolDataFrom: #methodSource. Win32Pool winver writePoolDataTo: #methodSource. " ^ { (FFIPlatformDescription name: 'Win32' osVersion: '10.0' subtype: 'IX86' wordSize: 4). Dictionary new at: #WIN32_WINNT_WIN7 put: 16r00000601; at: #WIN32_WINNT_WINXP put: 16r00000501; at: #WIN32_WINNT_VISTA put: 16r00000600; at: #WIN32_WINNT_WIN8 put: 16r00000602; at: #WIN32_WINNT_WIN10 put: 16r00000A00; yourself. } ! ExternalObject subclass: #MacOSShell instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-MacOS'! !MacOSShell commentStamp: 'spd 5/16/2010 22:33' prior: 0! I show how system functions can be called from within the image. WARNING: Under Snow Leopard, the VM (as of 4.2.4 beta) only searches its Resources folder for external libraries. See http://wiki.squeak.org/squeak/5846 for workarounds.! ----- Method: MacOSShell class>>escapeFileName: (in category 'utilities') ----- escapeFileName: aFileName "Try to make the argument suitable for use in 'system'. Just the simple stuff - backlash-prefix for obvious problems - quotes and white space." ^ String streamContents: [ : stream | aFileName do: [ : char | ('''" ()[]{}$&' includes: char) ifTrue: [ stream nextPut: $\ ]. stream nextPut: char. ]].! ----- Method: MacOSShell>>getenv: (in category 'basics') ----- getenv: aString <apicall: char* 'getenv' (char*) module: 'libSystem.dylib'> self externalCallFailed! ----- Method: MacOSShell>>system: (in category 'basics') ----- system: aString "Note that the command will foreground-block the VM unless it ends with &" <apicall: long 'system' (char*) module: 'libSystem.dylib'> self externalCallFailed.! ExternalObject subclass: #Win32File instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-Win32'! ----- 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-Libraries-Win32'! !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>>error: (in category 'operations') ----- error: code Win32ShellErrors signal: code! ----- 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 and: [result >= 0]) ifTrue: [self error: result]! ----- Method: Win32Shell>>shellExecute:arguments:toPath: (in category 'operations') ----- shellExecute: aFileString arguments: arguments toPath: outputPath "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: arguments lpDirectory: outputPath nShowCmd: 0. (result <= 32 and: [result >= 0]) ifTrue: [self error: result]! ----- 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 and: [result >= 0]) ifTrue: [self error: result]! ----- 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 and: [result >= 0]) ifTrue: [self error: result]! ----- 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 and: [result >= 0]) ifTrue: [self error: result]! ----- Method: Win32Shell>>shellOpen:arguments:toPath: (in category 'operations') ----- shellOpen: aFileString arguments: arguments toPath: outputPath "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: arguments lpDirectory: outputPath nShowCmd: 1. (result <= 32 and: [result >= 0]) ifTrue: [self error: result]! ExternalLibrary subclass: #CStandardLibrary instanceVariableNames: '' classVariableNames: 'CheckCStandardLibraryOnStartUp ModuleName' poolDictionaries: '' category: 'FFI-Libraries-LibC'! !CStandardLibrary commentStamp: 'mt 5/26/2021 10:08' prior: 0! The ISO C standard library, also known as "CRT" and "libc." Further reading: https://www.gnu.org/software/libc/ https://docs.microsoft.com/en-us/cpp/c-runtime-library https://www.cplusplus.com/reference/clibrary/ https://www.iso.org/standard/82075.html! ----- Method: CStandardLibrary class>>checkCStandardLibrary (in category 'preferences') ----- checkCStandardLibrary "Try to use C Standard Library. Warn if not possible." [ [self assert: [(self default abs: -5) = 5] ] ifError: [:msg | self notify: 'C standard library not available. Please check module name in preferences.', String cr, String cr, msg] ] fork. "Do not interrupt the startup list."! ----- Method: CStandardLibrary class>>checkCStandardLibraryOnStartUp (in category 'preferences') ----- checkCStandardLibraryOnStartUp <preference: 'Check C standard library on start-up' categoryList: #('FFI Libraries') description: 'When enabled, performs a simple check of the C standard library when Squeak is resuming.' type: #Boolean> ^ CheckCStandardLibraryOnStartUp ifNil: [true]! ----- Method: CStandardLibrary class>>checkCStandardLibraryOnStartUp: (in category 'preferences') ----- checkCStandardLibraryOnStartUp: aBoolean CheckCStandardLibraryOnStartUp := aBoolean.! ----- Method: CStandardLibrary class>>guessModuleName (in category 'preferences') ----- guessModuleName "The the platform's module name for the C library." | platform | platform := FFIPlatformDescription current. platform isMacOS ifTrue: [ ^ platform osVersionMajor >= 11 "Big Sur and beyond" ifTrue:['libSystem.dylib'] ifFalse: [platform osVersionMajor >= 10 ifFalse: ['libc.dylib' "Mac OS 9"] ifTrue: [platform osVersionMinor >= 7 "at least OS X 10.7 (Lion)" ifTrue: ['libobjc.dylib'] ifFalse: [platform osVersionMinor >= 5 "at least Mac OS X 10.5 (Leopard)" ifTrue: ['libgcc_s.1.dylib'] ifFalse: ['libc.dylib']]]]]. platform isWindows ifTrue: [ ^ 'msvcrt.dll']. platform isUnix ifTrue: [ ^ platform osVersion = 'linux-gnu' ifTrue: ['libc.so.6'] ifFalse: ['libc.so']]. ^ nil! ----- Method: CStandardLibrary class>>initialize (in category 'class initialization') ----- initialize " self initialize " Smalltalk addToStartUpList: self after: (Smalltalk classNamed: #FFIPlatformDescription).! ----- Method: CStandardLibrary class>>moduleName (in category 'preferences') ----- moduleName <preference: 'C runtime/standard library (aka. CRT and libc)' categoryList: #('FFI Libraries') description: 'Name for or path to the ISO/IEC 9899 C standard library.' type: #String> ^ ModuleName ifNil: [self guessModuleName]! ----- Method: CStandardLibrary class>>moduleName: (in category 'preferences') ----- moduleName: nameOrNil ModuleName := nameOrNil = String empty ifFalse: [nameOrNil = self guessModuleName ifFalse: [nameOrNil]]. self clearAllCaches. "Check the provided name only if overwritten by clients." ModuleName ifNotNil: [self checkCStandardLibrary].! ----- Method: CStandardLibrary class>>startUp: (in category 'system startup') ----- startUp: resuming resuming ifTrue: [ self checkCStandardLibraryOnStartUp ifTrue: [ self checkCStandardLibrary]].! ----- Method: CStandardLibrary class>>unload (in category 'class initialization') ----- unload Smalltalk removeFromStartUpList: self.! ----- Method: CStandardLibrary>>abs: (in category 'stdlib.h - integer arithmetics') ----- abs: n "Returns the absolute value of parameter n" <cdecl: int32_t abs (int32_t)> ^ self externalCallFailed ! ----- Method: CStandardLibrary>>bsearch:with:with:with:with: (in category 'stdlib.h - searching and sorting') ----- bsearch: key with: base with: num with: size with: compar <cdecl: void* bsearch (const void*, const void*, size_t, size_t, void*)> ^ self externalCallFailed ! ----- Method: CStandardLibrary>>qsort:with:with:with: (in category 'stdlib.h - searching and sorting') ----- qsort: base with: num with: size with: compar <cdecl: void qsort (void*, size_t, size_t, void*)> ^ self externalCallFailed ! CStandardLibrary subclass: #LibC instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-LibC'! !LibC commentStamp: 'mt 5/26/2021 10:09' prior: 0! Just a synonym for convenient reference.! ExternalTypeAlias subclass: #Win32Handle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-Win32'! Win32Handle subclass: #Win32HDC instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-Win32'! ----- 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-Libraries-Win32'! Win32HGDIObj subclass: #Win32HBrush instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-Win32'! ----- 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>>originalTypeName (in category 'accessing') ----- originalTypeName "Win32Handle defineFields" "The following really means typedef void* Win32Handle; " ^ 'uintptr_t'! Win32Handle subclass: #Win32Window instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'Win32Constants' category: 'FFI-Libraries-Win32'! !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! ExternalTypeAlias subclass: #X11ID instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-X11'! !X11ID commentStamp: 'mt 6/4/2020 19:16' prior: 0! I am an opaque handle in X11.! X11ID subclass: #X11Drawable instanceVariableNames: 'display xid' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-X11'! ----- Method: X11Drawable class>>display: (in category 'instance creation') ----- display: aX11Display ^ self new display: aX11Display! ----- Method: X11Drawable>>display (in category 'accessing') ----- display ^display! ----- Method: X11Drawable>>display: (in category 'accessing') ----- display: aDisplay display := aDisplay! ----- Method: X11Drawable>>printOn: (in category 'printing') ----- printOn: aStream aStream nextPutAll: self class name; nextPut: $(; nextPutAll: self xid printStringHex; nextPut: $) ! ----- Method: X11Drawable>>xid (in category 'accessing') ----- xid ^ xid! ----- Method: X11Drawable>>xid: (in category 'accessing') ----- xid: anUnsignedInteger xid := anUnsignedInteger! ----- Method: X11ID class>>originalTypeName (in category 'field definition') ----- originalTypeName " self defineFields " ^ 'size_t' "or always uint32_t ??"! X11ID subclass: #X11Window instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-X11'! ExternalStructure subclass: #MacPixPatPtr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-MacOS'! !MacPixPatPtr commentStamp: 'spd 5/16/2010 22:32' prior: 0! See class comment for MacRect.! ----- Method: MacPixPatPtr class>>fields (in category 'field definition') ----- fields "MacPixPatPtr defineFields" "The following really means typedef void* MacPixPatPtr; " ^#(nil 'void*') "For now this is just an opaque handle"! ----- Method: MacPixPatPtr class>>newPixPat (in category 'instance creation') ----- newPixPat <apicall: MacPixPatPtr* 'NewPixPat' (void) module:'ApplicationServices'> ^self externalCallFailed! ----- Method: MacPixPatPtr>>apiDisposePixPat: (in category 'api calls') ----- apiDisposePixPat: aPixPat <apicall: void 'DisposePixPat' (MacPixPatPtr*) module:'ApplicationServices'> ^self externalCallFailed! ----- Method: MacPixPatPtr>>apiMakeRGBPat:with: (in category 'api calls') ----- apiMakeRGBPat: aPixPat with: aRGBColor <apicall: void 'MakeRGBPat' (MacPixPatPtr* MacRGBColor*) module: 'ApplicationServices'> ^self externalCallFailed! ----- Method: MacPixPatPtr>>dispose (in category 'initialize-release') ----- dispose handle == nil ifFalse:[ self apiDisposePixPat: self. handle := nil. ].! ----- Method: MacPixPatPtr>>makeRGBPattern: (in category 'accessing') ----- makeRGBPattern: aColor ^self apiMakeRGBPat: self with: (MacRGBColor fromColor: aColor)! ExternalStructure subclass: #MacPoint instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-MacOS'! !MacPoint commentStamp: 'spd 5/16/2010 22:32' prior: 0! See class comment for MacRect.! ----- Method: MacPoint class>>apiLineTo:with: (in category 'api calls') ----- apiLineTo: x with: y <apicall: void 'LineTo' (short short) module:'ApplicationServices'> ^self externalCallFailed! ----- Method: MacPoint class>>apiMoveTo:with: (in category 'api calls') ----- apiMoveTo: x with: y <apicall: void 'MoveTo' (short short) module:'ApplicationServices'> ^self externalCallFailed! ----- Method: MacPoint class>>fields (in category 'field definition') ----- fields "MacPoint defineFields" ^#( (v 'short') (h 'short') )! ----- Method: MacPoint class>>lineTo: (in category 'examples') ----- lineTo: aPoint "MacPoint moveTo: 0@0; lineTo: 100@100" ^self apiLineTo: aPoint x with: aPoint y ! ----- Method: MacPoint class>>macDraw (in category 'examples') ----- macDraw "MacPoint macDraw" | pt | pt := self new. pt getMousePoint. self moveTo: pt. [Sensor anyButtonPressed] whileFalse:[ pt getMousePoint. self lineTo: pt. ]. Display forceToScreen.! ----- Method: MacPoint class>>moveTo: (in category 'examples') ----- moveTo: aPoint "MacPoint moveTo: 0@0; lineTo: 100@100" ^self apiMoveTo: aPoint x with: aPoint y ! ----- Method: MacPoint>>apiGetMousePoint: (in category 'api calls') ----- apiGetMousePoint: aMacPoint <apicall: void 'GetMouse' (MacPoint*) module:'Carbon.framework'> ^self externalCallFailed! ----- Method: MacPoint>>getMousePoint (in category 'accessing') ----- getMousePoint ^self apiGetMousePoint: self! ----- Method: MacPoint>>x (in category 'accessing') ----- x ^self h! ----- Method: MacPoint>>x: (in category 'accessing') ----- x: anObject ^self h: anObject! ----- Method: MacPoint>>y (in category 'accessing') ----- y ^self v! ----- Method: MacPoint>>y: (in category 'accessing') ----- y: anObject ^self v: anObject! ExternalStructure subclass: #MacRGBColor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-MacOS'! !MacRGBColor commentStamp: 'spd 5/16/2010 22:31' prior: 0! See class comment for MacRect.! ----- Method: MacRGBColor class>>fields (in category 'field definition') ----- fields "MacRGBColor defineFields" ^#( (red 'ushort') (green 'ushort') (blue 'ushort') )! ----- Method: MacRGBColor class>>fromColor: (in category 'instance creation') ----- fromColor: aColor ^(self new) red: (aColor red * 16rFFFF) rounded; green: (aColor green * 16rFFFF) rounded; blue: (aColor blue * 16rFFFF) rounded; yourself! ExternalStructure subclass: #MacRect instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-MacOS'! !MacRect commentStamp: 'spd 5/16/2010 22:42' prior: 0! I, with my friends (MacPixPatPtr, MacPoint and MacRGBColor), show how to make calls into a Mac OS framework. The particular library I use in my examples, QuickDraw, is depreciated in OS X 10.4, but the examples still run as of OS X 10.6.2 See http://developer.apple.com/legacy/mac/library/documentation/Carbon/Referenc… for more information. WARNING: for Snow Leopard, see warning in MacOSShell! ----- Method: MacRect class>>apiFillCOval:with: (in category 'api calls') ----- apiFillCOval: r with: pat <apicall: void 'FillCOval' (MacRect* MacPixPatPtr*) module:'ApplicationServices'> ^self externalCallFailed! ----- Method: MacRect class>>apiFillCRect:with: (in category 'api calls') ----- apiFillCRect: r with: pat <apicall: void 'FillCRect' (MacRect* MacPixPatPtr*) module:'ApplicationServices'> ^self externalCallFailed! ----- Method: MacRect class>>apiFrameOval: (in category 'api calls') ----- apiFrameOval: r <apicall: void 'FrameOval' (MacRect*) module:'ApplicationServices'> ^self externalCallFailed! ----- Method: MacRect class>>apiFrameRect: (in category 'api calls') ----- apiFrameRect: r <apicall: void 'FrameRect' (MacRect*) module:'ApplicationServices'> ^self externalCallFailed! ----- Method: MacRect class>>coloredEllipses (in category 'examples') ----- coloredEllipses "MacRect coloredEllipses" | rnd w h colors n r pat v0 v1 | colors := Color colorNames collect:[:cName| (Color perform: cName)]. "convert to PixPats" colors := colors collect:[:c| MacPixPatPtr newPixPat makeRGBPattern: c]. rnd := Random new. w := Display width. h := Display height. n := 0. r := MacRect new. [Sensor anyButtonPressed] whileFalse:[ pat := colors atRandom. v0 := (rnd next * w) asInteger. v1 := (rnd next * w) asInteger. v0 < v1 ifTrue:[r left: v0; right: v1] ifFalse:[r left: v1; right: v0]. v0 := (rnd next * h) asInteger. v1 := (rnd next * h) asInteger. v0 < v1 ifTrue:[r top: v0; bottom: v1] ifFalse:[r top: v1; bottom: v0]. self apiFillCOval: r with: pat. self apiFrameOval: r. n := n + 1. (n \\ 10) = 0 ifTrue:[n printString displayAt: 0@0]. ]. colors do:[:c| c dispose]. Display forceToScreen.! ----- Method: MacRect class>>coloredRectangles (in category 'examples') ----- coloredRectangles "MacRect coloredRectangles" | rnd w h colors n r pat v0 v1 nPixels time | colors := Color colorNames collect:[:cName| (Color perform: cName)]. "convert to PixPats" colors := colors collect:[:c| MacPixPatPtr newPixPat makeRGBPattern: c]. rnd := Random new. w := Display width. h := Display height. n := 0. r := MacRect new. nPixels := 0. time := Time millisecondClockValue. [Sensor anyButtonPressed] whileFalse:[ pat := colors atRandom. v0 := (rnd next * w) asInteger. v1 := (rnd next * w) asInteger. v0 < v1 ifTrue:[r left: v0; right: v1] ifFalse:[r left: v1; right: v0]. v0 := (rnd next * h) asInteger. v1 := (rnd next * h) asInteger. v0 < v1 ifTrue:[r top: v0; bottom: v1] ifFalse:[r top: v1; bottom: v0]. self apiFillCRect: r with: pat. self apiFrameRect: r. 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]. ]. colors do:[:c| c dispose]. Display forceToScreen.! ----- Method: MacRect class>>fields (in category 'field definition') ----- fields "MacRect defineFields" ^#( (top 'short') (left 'short') (bottom 'short') (right 'short') )! ----- Method: MacRect class>>macDraw (in category 'examples') ----- macDraw "MacRect macDraw" ^MacPoint macDraw! ExternalStructure subclass: #Win32Point instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-Win32'! ----- 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! ExternalStructure subclass: #Win32Rectangle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-Win32'! ----- 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>>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 ! ExternalStructure subclass: #X11Display instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-X11'! ----- Method: X11Display class>>XOpenDisplay: (in category 'instance creation') ----- XOpenDisplay: displayName "X11Display XOpenDisplay: nil" <cdecl: X11Display* 'XOpenDisplay' (char*) module:'X11'> ^self externalCallFailed! ----- Method: X11Display class>>coloredEllipses (in category 'examples') ----- coloredEllipses "X11Display coloredEllipses" | display window gc colors rnd w h pt1 pt2 r | display := X11Display XOpenDisplay: nil. window := display ourWindow. gc := X11GC on: window. colors := Color colorNames collect:[:n| (Color perform: n) pixelWordForDepth: 32]. rnd := Random new. w := Display width. h := Display height. [Sensor anyButtonPressed] whileFalse:[ pt1 := (rnd next * w) asInteger @ (rnd next * h) asInteger. pt2 := (rnd next * w) asInteger @ (rnd next * h) asInteger. r := Rectangle encompassing: (Array with: pt1 with: pt2). gc foreground: colors atRandom. gc fillOval: r. gc foreground: 0. gc drawOval: r. display sync. ]. gc free. display closeDisplay. Display forceToScreen.! ----- Method: X11Display class>>coloredRectangles (in category 'examples') ----- coloredRectangles "X11Display coloredRectangles" | display window gc colors rnd w h pt1 pt2 r nPixels time n | display := X11Display XOpenDisplay: nil. window := display ourWindow. gc := X11GC on: window. colors := Color colorNames collect:[:cn| (Color perform: cn) pixelWordForDepth: 32]. rnd := Random new. w := Display width. h := Display height. n := 0. nPixels := 0. time := Time millisecondClockValue. [Sensor anyButtonPressed] whileFalse:[ pt1 := (rnd next * w) asInteger @ (rnd next * h) asInteger. pt2 := (rnd next * w) asInteger @ (rnd next * h) asInteger. r := Rectangle encompassing: (Array with: pt1 with: pt2). gc foreground: colors atRandom. gc fillRectangle: r. gc foreground: 0. gc drawRectangle: r. display sync. 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]. ]. gc free. display closeDisplay. Display forceToScreen.! ----- Method: X11Display class>>fields (in category 'field definition') ----- fields "X11Display defineFields" "Note: The structure of Display is internal and only pointers to X11Display are used" ^#()! ----- Method: X11Display class>>new (in category 'instance creation') ----- new ^ self on: nil! ----- Method: X11Display class>>on: (in category 'instance creation') ----- on: aStringOrNil ^ self XOpenDisplay: aStringOrNil! ----- Method: X11Display class>>x11Draw (in category 'examples') ----- x11Draw "X11Display x11Draw" | display window gc nextPt lastPt ptr | display := X11Display XOpenDisplay: nil. window = display ourWindow. gc := X11GC on: window. gc foreground: 0. lastPt := nil. [ptr := display queryPointer: window. "{root. child. root pos. win pos. mask}" ptr last anyMask: 256] whileFalse:[ nextPt := ptr fourth. nextPt = lastPt ifFalse:[ lastPt ifNotNil: [ gc drawLineFrom: lastPt to: nextPt. display sync]. lastPt := nextPt]. ]. gc free. display closeDisplay. Display forceToScreen.! ----- Method: X11Display>>None (in category 'xlib calls') ----- None ^ 0! ----- Method: X11Display>>XCloseDisplay: (in category 'xlib calls') ----- XCloseDisplay: aDisplay <cdecl: void 'XCloseDisplay' (X11Display*) module:'X11'> ^self externalCallFailed! ----- Method: X11Display>>XDisplayString: (in category 'xlib calls') ----- XDisplayString: aDisplay <cdecl: char* 'XDisplayString' (X11Display*) module:'X11'> ^self externalCallFailed! ----- Method: X11Display>>XFlush: (in category 'xlib calls') ----- XFlush: xDisplay <cdecl: void 'XFlush' (X11Display*) module:'X11'> ^self externalCallFailed! ----- Method: X11Display>>XGetInputFocus:with:with: (in category 'xlib calls') ----- XGetInputFocus: display with: focus with: revert <cdecl: void 'XGetInputFocus' (X11Display* ulong* long*) module: 'X11'> ^self externalCallFailed! ----- Method: X11Display>>XQueryPointer:window:returnRoot:child:rootX:rootY:winX:winY:mask: (in category 'xlib calls') ----- XQueryPointer: display window: w returnRoot: root child: child rootX: rootX rootY: rootY winX: winX winY: winY mask: mask <cdecl: bool 'XQueryPointer' (X11Display* ulong ulong* ulong* long* long* long* long* long*) module: 'X11'> ^self externalCallFailed! ----- Method: X11Display>>XSync: (in category 'xlib calls') ----- XSync: xDisplay <cdecl: void 'XSync' (X11Display*) module:'X11'> ^self externalCallFailed! ----- Method: X11Display>>XWarpPointer:sourceWindow:destWindow:sourceX:sourceY:sourceWidth:sourceHeight:destX:destY: (in category 'xlib calls') ----- XWarpPointer: display sourceWindow: srcWindowID destWindow: destWindowID sourceX: srcX sourceY: srcY sourceWidth: srcWidth sourceHeight: srcHeight destX: destX destY: destY <cdecl: bool 'XWarpPointer' (X11Display* ulong ulong long long ulong ulong long long) module: 'X11'> ^self externalCallFailed! ----- Method: X11Display>>closeDisplay (in category 'initialize-release') ----- closeDisplay handle == nil ifFalse:[ self XCloseDisplay: self. handle := nil].! ----- Method: X11Display>>displayString (in category 'accessing') ----- displayString ^self XDisplayString: self! ----- Method: X11Display>>flush (in category 'initialize-release') ----- flush self XFlush: self! ----- Method: X11Display>>getInputFocus (in category 'accessing') ----- getInputFocus | focus revert | focus := WordArray new: 1. revert := WordArray new: 1. self XGetInputFocus: self with: focus with: revert. ^ X11Window new xid: focus first! ----- Method: X11Display>>ourWindow (in category 'accessing') ----- ourWindow "Guess the window to draw on." | window ptr child | window := self getInputFocus. ptr := self queryPointer: window. "{root. child. root pos. win pos. mask}" child := ptr second. child xid = 0 ifTrue: [^ window]. ^ child! ----- Method: X11Display>>queryPointer: (in category 'accessing') ----- queryPointer: aX11Window | root child rootX rootY winX winY mask | root := WordArray new: 1. child := WordArray new: 1. rootX := WordArray new: 1. rootY := WordArray new: 1. winX := WordArray new: 1. winY := WordArray new: 1. mask := WordArray new: 1. self XQueryPointer: self window: aX11Window xid returnRoot: root child: child rootX: rootX rootY: rootY winX: winX winY: winY mask: mask. ^{ X11Window new xid: root first. X11Window new xid: child first. rootX first @ rootY first. winX first @ winY first. mask first}! ----- Method: X11Display>>sync (in category 'initialize-release') ----- sync ^self XSync: self! ----- Method: X11Display>>warpPointerBy: (in category 'accessing') ----- warpPointerBy: aPoint "Moves the mouse pointer from its current location to its current location + aPoint. Generates a mouse move event if the squeak window is active" ^ self XWarpPointer: self sourceWindow: self None destWindow: self None sourceX: 0 sourceY: 0 sourceWidth: 0 sourceHeight: 0 destX: aPoint x destY: aPoint y! ----- Method: X11Display>>warpPointerFrom:in:To:in: (in category 'accessing') ----- warpPointerFrom: aRectangle in: sourceWindow To: aPoint in: destWindow "Moves the mouse pointer to aPoint relative to the top-left corner of a window" ^ self XWarpPointer: self sourceWindow: sourceWindow xid destWindow: destWindow xid sourceX: aRectangle left sourceY: aRectangle top sourceWidth: aRectangle width sourceHeight: aRectangle height destX: aPoint x destY: aPoint y! ----- Method: X11Display>>warpPointerTo:in: (in category 'accessing') ----- warpPointerTo: aPoint in: aWindow "Moves the mouse pointer to aPoint relative to the top-left corner of a window" ^ self XWarpPointer: self sourceWindow: self None destWindow: aWindow xid sourceX: 0 sourceY: 0 sourceWidth: 0 sourceHeight: 0 destX: aPoint x destY: aPoint y! ExternalStructure subclass: #X11GC instanceVariableNames: 'drawable' classVariableNames: '' poolDictionaries: '' category: 'FFI-Libraries-X11'! ----- Method: X11GC class>>XCreateGC:with:with:with: (in category 'xlib calls') ----- XCreateGC: xDisplay with: aDrawable with: valueMask with: values <cdecl: X11GC 'XCreateGC' (X11Display* X11Drawable ulong long*) module: 'X11'> ^self externalCallFailed! ----- Method: X11GC class>>fields (in category 'field definition') ----- fields "X11GC defineFields" ^#( nil 'void*' )! ----- Method: X11GC class>>on: (in category 'instance creation') ----- on: aDrawable | xgc | xgc := self XCreateGC: aDrawable display with: aDrawable with: 0 with: nil. xgc drawable: aDrawable. ^xgc! ----- Method: X11GC>>XDrawArc:with:with:with:with:with:with:with:with: (in category 'xlib calls') ----- XDrawArc: xDisplay with: xDrawable with: xGC with: x with: y with: w with: h with: a1 with: a2 <cdecl: void 'XDrawArc' (X11Display* X11Drawable X11GC long long ulong ulong long long) module: 'X11'> ^self externalCallFailed! ----- Method: X11GC>>XDrawLine:with:with:with:with:with:with: (in category 'xlib calls') ----- XDrawLine: xDisplay with: aDrawable with: xGC with: x0 with: y0 with: x1 with: y1 <cdecl: long 'XDrawLine' (X11Display* X11Drawable X11GC long long long long) module: 'X11'> ^self externalCallFailed! ----- Method: X11GC>>XDrawRectangle:with:with:with:with:with:with: (in category 'xlib calls') ----- XDrawRectangle: xDisplay with: xDrawable with: xGC with: x with: y with: w with: h <cdecl: void 'XDrawRectangle' (X11Display* X11Drawable X11GC long long ulong ulong) module: 'X11'> ^self externalCallFailed! ----- Method: X11GC>>XFillArc:with:with:with:with:with:with:with:with: (in category 'xlib calls') ----- XFillArc: xDisplay with: xDrawable with: xGC with: x with: y with: w with: h with: a1 with: a2 <cdecl: void 'XFillArc' (X11Display* X11Drawable X11GC long long ulong ulong long long) module: 'X11'> ^self externalCallFailed! ----- Method: X11GC>>XFillRectangle:with:with:with:with:with:with: (in category 'xlib calls') ----- XFillRectangle: xDisplay with: xDrawable with: xGC with: x with: y with: w with: h <cdecl: void 'XFillRectangle' (X11Display* X11Drawable X11GC long long ulong ulong) module: 'X11'> ^self externalCallFailed! ----- Method: X11GC>>XFreeGC:with: (in category 'xlib calls') ----- XFreeGC: xDisplay with: xGC <cdecl: long 'XFreeGC' (X11Display* X11GC) module: 'X11'> ^self externalCallFailed! ----- Method: X11GC>>XSetBackground:with:with: (in category 'xlib calls') ----- XSetBackground: xDisplay with: xGC with: bg <cdecl: void 'XSetBackground' (X11Display* X11GC long) module: 'X11'> ^self externalCallFailed! ----- Method: X11GC>>XSetForeground:with:with: (in category 'xlib calls') ----- XSetForeground: xDisplay with: xGC with: fg <cdecl: void 'XSetForeground' (X11Display* X11GC long) module: 'X11'> ^self externalCallFailed! ----- Method: X11GC>>background: (in category 'drawing') ----- background: pixelValue self XSetBackground: self display with: self with: pixelValue! ----- Method: X11GC>>display (in category 'accessing') ----- display ^drawable display! ----- Method: X11GC>>drawLineFrom:to: (in category 'drawing') ----- drawLineFrom: pt1 to: pt2 self XDrawLine: self display with: drawable with: self with: pt1 x with: pt1 y with: pt2 x with: pt2 y! ----- Method: X11GC>>drawOval: (in category 'drawing') ----- drawOval: aRectangle self XDrawArc: self display with: drawable with: self with: aRectangle left with: aRectangle top with: aRectangle width with: aRectangle height with: 0 with: 64*360! ----- Method: X11GC>>drawRectangle: (in category 'drawing') ----- drawRectangle: aRectangle self XDrawRectangle: self display with: drawable with: self with: aRectangle left with: aRectangle top with: aRectangle width with: aRectangle height! ----- Method: X11GC>>drawable (in category 'accessing') ----- drawable ^drawable! ----- Method: X11GC>>drawable: (in category 'accessing') ----- drawable: aDrawable drawable := aDrawable! ----- Method: X11GC>>fillOval: (in category 'drawing') ----- fillOval: aRectangle self XFillArc: self display with: drawable with: self with: aRectangle left with: aRectangle top with: aRectangle width with: aRectangle height with: 0 with: 64*360! ----- Method: X11GC>>fillRectangle: (in category 'drawing') ----- fillRectangle: aRectangle self XFillRectangle: self display with: drawable with: self with: aRectangle left with: aRectangle top with: aRectangle width with: aRectangle height! ----- Method: X11GC>>foreground: (in category 'drawing') ----- foreground: pixelValue self XSetForeground: self display with: self with: pixelValue ! ----- Method: X11GC>>free (in category 'initialize-release') ----- free handle == nil ifFalse:[ self XFreeGC: self display with: self. handle := nil. ].!

1 0

FFI: FFI-Pools-mt.30.mcz
by commits＠source.squeak.org 27 May '21

27 May '21

Marcel Taeumel uploaded a new version of FFI-Pools to project FFI: http://source.squeak.org/FFI/FFI-Pools-mt.30.mcz ==================== Summary ==================== Name: FFI-Pools-mt.30 Author: mt Time: 27 May 2021, 9:31:42.419843 am UUID: 4ea34330-670f-f844-833b-349561dc6e3a Ancestors: FFI-Pools-mt.29 Complements FFI-Kernel-mt.174 =============== Diff against FFI-Pools-mt.29 =============== Item was removed: - ----- Method: Parser>>apicall (in category '*FFI-Pools') ----- - apicall - <pragmaParser> - ^ self externalFunctionDeclaration! Item was removed: - ----- Method: Parser>>callback (in category '*FFI-Pools') ----- - callback - <pragmaParser> - - | descriptorClass retType externalName args argType | - descriptorClass := self environment classNamed: #ExternalFunction. - "Parse return type" - self advance. - retType := self externalType: descriptorClass. - retType == nil ifTrue:[^self expected:'return type']. - "Parse function name or index" - externalName := here. - - (self match: #leftParenthesis) ifFalse:[^self expected:'function pointer (*)']. - (self matchToken: #*) ifFalse:[^self expected:'function pointer (*)']. - (self match: #rightParenthesis) ifFalse:[^self expected:'function pointer (*)']. - - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: Array new. - [self match: #rightParenthesis] whileFalse:[ - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - - self addPragma: (Pragma keyword: #callback: arguments: {{retType}, args contents}). - ^true! Item was removed: - ----- Method: Parser>>cdecl (in category '*FFI-Pools') ----- - cdecl - <pragmaParser> - ^ self externalFunctionDeclaration! Item was removed: - ----- Method: Parser>>externalFunctionDeclaration (in category '*FFI-Pools') ----- - externalFunctionDeclaration - "Parse the function declaration for a call to an external library. - - (1) Create an instance of ExternalLibraryFunction and install it as first literal. - (2) Add a pragma to primitive call 120. - " - | descriptorClass callType modifier retType externalName args argType module fn | - descriptorClass := cue environment - valueOf: #ExternalFunction - ifAbsent: [^ false]. - callType := descriptorClass callingConventionFor: here. - callType == nil ifTrue:[^false]. - [modifier := descriptorClass callingConventionModifierFor: token. - modifier notNil] whileTrue: - [self advance. - callType := callType bitOr: modifier]. - "Parse return type" - self advance. - retType := self externalType: descriptorClass. - retType == nil ifTrue:[^self expected:'return type']. - "Parse function name or index" - externalName := here. - (self match: #number) - ifFalse: [ "Consume all tokens as function name" - self advance. - externalName := externalName asSymbol]. - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: Array new. - [self match: #rightParenthesis] whileFalse:[ - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - (self matchToken: 'module:') ifTrue:[ - module := here. - (self match: #string) ifFalse:[^self expected: 'String']. - module := module asSymbol]. - - self environment at: #ExternalLibraryFunction ifPresent:[:xfn| - fn := xfn name: externalName - module: module - callType: callType - returnType: retType - argumentTypes: args contents. - self allocateLiteral: fn. - fn beWritableObject. "Undo the read-only setting in litIndex:"]. - (self matchToken: 'error:') - ifTrue: - [| errorCodeVariable | - errorCodeVariable := here. - (hereType == #string - or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. - self advance. - self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). - fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] - ifFalse: - [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. - ^true! Item was removed: - ----- Method: Parser>>externalType: (in category '*FFI-Pools') ----- - externalType: descriptorClass - "Parse and return an external type. Ignore leading comma and 'const'." - - | xType typeName isArrayType tokenString | - self matchToken: ','. - self matchToken: 'const'. - typeName := here. "Note that pointer token is not yet parsed!!" - self advance. - (isArrayType := self matchToken: $[) - ifTrue: [ - (self matchToken: $]) - ifTrue: [typeName := typeName, '[]'] - ifFalse: [ - typeName := typeName, '[', here, ']'. - self advance. - (self matchToken: $]) ifFalse: [^ self expected: 'closing bracket']]]. - (xType := descriptorClass typeNamed: typeName) - ifNil: [ - "Raise an error if user is there" - self interactive ifTrue: [^nil]. - "otherwise go over it silently -- use an unknown struct type" - xType := descriptorClass newTypeNamed: typeName]. - isArrayType ifTrue: [ - xType := xType asPointerType]. - self flag: #todo. "mt: Extra commas are currently merged with pointer indicator as a single token." - tokenString := here asString. - ^ (tokenString first == $*) - ifTrue: [self advance. xType asPointerType] - ifFalse:[(tokenString beginsWith: '**') - ifTrue: [self advance. xType asPointerToPointerType] - ifFalse: [xType]]!

1 0

FFI: FFI-Kernel-mt.174.mcz
by commits＠source.squeak.org 27 May '21

27 May '21

Marcel Taeumel uploaded a new version of FFI-Kernel to project FFI: http://source.squeak.org/FFI/FFI-Kernel-mt.174.mcz ==================== Summary ==================== Name: FFI-Kernel-mt.174 Author: mt Time: 27 May 2021, 9:31:07.812843 am UUID: 13aff407-23c6-a04d-a83d-6d8abf6f524d Ancestors: FFI-Kernel-mt.173 Clean up yesterday's dependency hick-up. Sorry for the inconvenience. :-/ =============== Diff against FFI-Kernel-mt.173 =============== Item was removed: - ExternalLibrary subclass: #CStandardLibrary - instanceVariableNames: '' - classVariableNames: 'ModuleName' - poolDictionaries: '' - category: 'FFI-Kernel-Support'! - - !CStandardLibrary commentStamp: 'mt 5/26/2021 10:08' prior: 0! - The ISO C standard library, also known as "CRT" and "libc." - - Further reading: - https://www.gnu.org/software/libc/ - https://docs.microsoft.com/en-us/cpp/c-runtime-library - https://www.cplusplus.com/reference/clibrary/ - https://www.iso.org/standard/82075.html! Item was removed: - ----- Method: CStandardLibrary class>>guessModuleName (in category 'preferences') ----- - guessModuleName - "The the platform's module name for the C library." - - | platform | - platform := FFIPlatformDescription current. - - platform isMacOS ifTrue: [ - ^ platform osVersionMajor >= 11 "Big Sur and beyond" - ifTrue:['libSystem.dylib'] - ifFalse: [platform osVersionMajor >= 10 - ifFalse: ['libc.dylib' "Mac OS 9"] - ifTrue: [platform osVersionMinor >= 7 "at least OS X 10.7 (Lion)" - ifTrue: ['libobjc.dylib'] - ifFalse: [platform osVersionMinor >= 5 "at least Mac OS X 10.5 (Leopard)" - ifTrue: ['libgcc_s.1.dylib'] - ifFalse: ['libc.dylib']]]]]. - - platform isWindows ifTrue: [ - ^ 'msvcrt.dll']. - - platform isUnix ifTrue: [ - ^ platform osVersion = 'linux-gnu' - ifTrue: ['libc.so.6'] - ifFalse: ['libc.so']]. - - ^ nil! Item was removed: - ----- Method: CStandardLibrary class>>moduleName (in category 'preferences') ----- - moduleName - <preference: 'C runtime/standard library (aka. CRT and libc)' - categoryList: #('FFI Kernel') - description: 'Name for or path to the ISO/IEC 9899 C standard library.' - type: #String> - ^ ModuleName ifNil: [self guessModuleName]! Item was removed: - ----- Method: CStandardLibrary class>>moduleName: (in category 'preferences') ----- - moduleName: nameOrNil - - ModuleName := nameOrNil = String empty ifFalse: [nameOrNil]. - self clearAllCaches. - - "Check the provided name only if overwritten by clients. See #guessModuleName and FFIPlatformDescription class>> #startUp:." - ModuleName ifNotNil: [FFIPlatformDescription checkCStandardLibrary].! Item was removed: - ----- Method: CStandardLibrary class>>resetDefault (in category 'instance creation') ----- - resetDefault - "Overwritten to release all function handles." - - super resetDefault. - CStandardLibrary methodsDo: [:m | m externalLibraryName: nil].! Item was removed: - ----- Method: CStandardLibrary>>abs: (in category 'stdlib.h - integer arithmetics') ----- - abs: n - "Returns the absolute value of parameter n" - - <cdecl: int32_t abs (int32_t)> - ^ self externalCallFailed ! Item was removed: - ----- Method: CStandardLibrary>>bsearch:with:with:with:with: (in category 'stdlib.h - searching and sorting') ----- - bsearch: key with: base with: num with: size with: compar - - <cdecl: void* bsearch (const void*, const void*, size_t, size_t, void*)> - ^ self externalCallFailed ! Item was removed: - ----- Method: CStandardLibrary>>qsort:with:with:with: (in category 'stdlib.h - searching and sorting') ----- - qsort: base with: num with: size with: compar - - <cdecl: void qsort (void*, size_t, size_t, void*)> - ^ self externalCallFailed ! Item was changed: ----- Method: ExternalLibrary class>>resetDefault (in category 'instance creation') ----- resetDefault + default := nil. + self methodsDo: [:m | m externalLibraryName: nil].! - default := nil.! Item was changed: Object subclass: #FFIPlatformDescription instanceVariableNames: 'name osVersion subtype wordSize endianness' + classVariableNames: 'CheckFFIOnStartUp LastPlatform' - classVariableNames: 'CheckCStandardLibraryOnStartUp CheckFFIOnStartUp LastPlatform' poolDictionaries: '' category: 'FFI-Kernel-Support'! !FFIPlatformDescription commentStamp: 'mt 6/2/2020 15:18' prior: 0! This class stores the information about the current (host) platform. It supports testing instances for platform compatibility and specificity. The entire FFI machinery should go through here, when making platform-specific decisions such as when figuring out the #wordSize for pointers to external memory (i.e., ExternalAddress class >> #new) or when looking up compatible definitions for external pools (i.e., ExternalPool class >> #compatibleResolvedDefinitions). 1. DETECT PLATFORM CHANGE ON STARTUP This class is registered for system startup. It then checks whether the current platform is different from the last one. In that case, a selection of FFI classes gets notified such as ExternalObject and ExternalType. 2. PLATFORM SPECIFICITY Platform descriptions may be unspecific, that is, some of their values may be undefined. For example, (FFIPlatformDescription name: 'unix') creates a valid description but is not specific about #osVersion or #wordSize. When comparing such descriptions, precedence of the platform values are: platform name > osVersion > subtype > wordSize So, if one description has a #name and the other does not, the first one is more specific. If both have #name but only the second one has #osVersion, the second one is more specific. If one has only #wordSize and another one has only #subtype, the second one is more specific because #subtype has a higher precedence than #wordSize. 3. PLATFORM COMPATIBILITY Platform descriptions implement a notion of compatibility, which is coupled to its notion of specificity as mentioned before. Using the same rules of precedence, compatibility is checked by comparing the description's values. If not specificed, compatibility is assumed. If specified, values must match via #= to be regarded compatible. Here is an interesting edge case of two compatible platform descriptions: | p1 p2 | p1 := FFIPlatformDescription name: 'Win32' osVersion: '' subtype: 'IX86' wordSize: nil. p2 := FFIPlatformDescription name: '' osVersion: 'linux-gnu' subtype: '' wordSize: 8. p1 isCompatibleWith: p2. Consequently, the developer has to be careful with unspecific platform descriptions, which are used, for example, in the definitions of external pools. 4. FURTHER READING - all references to FFIPlatformDescription - all senders of #wordSize - class comments of ExternalAddress, ExternalType, ExternalPool, ExternalObject ! Item was removed: - ----- Method: FFIPlatformDescription class>>checkCStandardLibrary (in category 'system startup') ----- - checkCStandardLibrary - "Try to use C Standard Library. Warn if not possible." - - [ [self assert: [(CStandardLibrary default abs: -5) = 5] - ] ifError: [:msg | - self notify: 'C standard library not available. Please check module name in preferences.', String cr, String cr, msg] - ] fork. "Do not interrupt the startup list."! Item was removed: - ----- Method: FFIPlatformDescription class>>checkCStandardLibraryOnStartUp (in category 'preferences') ----- - checkCStandardLibraryOnStartUp - <preference: 'Check C standard library on start-up' - categoryList: #('FFI Kernel') - description: 'When enabled, performs a simple check of the C standard library when Squeak is resuming.' - type: #Boolean> - ^ CheckCStandardLibraryOnStartUp ifNil: [true]! Item was removed: - ----- Method: FFIPlatformDescription class>>checkCStandardLibraryOnStartUp: (in category 'preferences') ----- - checkCStandardLibraryOnStartUp: aBoolean - - CheckCStandardLibraryOnStartUp := aBoolean.! Item was changed: ----- Method: FFIPlatformDescription class>>startUp: (in category 'system startup') ----- startUp: resuming "Notify all FFI classes about platform changes." resuming ifTrue: [ LastPlatform in: [:lastPlatform | self newCurrent in: [:currentPlatform | lastPlatform = currentPlatform ifTrue: [ self flag: #discuss. "mt: Maybe add #platformResuming?" ExternalAddress allBeNull. ExternalType cleanupUnusedTypes ] ifFalse: [ LastPlatform := currentPlatform. "Update now. See #current." { ExternalAddress. ExternalType. ExternalStructure. ExternalPool. ExternalLibrary } do: [:cls | cls platformChangedFrom: lastPlatform to: currentPlatform] ]]]. + self checkFFIOnStartUp ifTrue: [self checkFFI]].! - self checkFFIOnStartUp ifTrue: [self checkFFI]. - self checkCStandardLibraryOnStartUp ifTrue: [self checkCStandardLibrary]].! Item was removed: - CStandardLibrary subclass: #LibC - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'FFI-Kernel-Support'! - - !LibC commentStamp: 'mt 5/26/2021 10:09' prior: 0! - Just a synonym for convenient reference.! Item was added: + ----- Method: Parser>>apicall (in category '*FFI-Kernel') ----- + apicall + <pragmaParser> + ^ self externalFunctionDeclaration! Item was added: + ----- Method: Parser>>callback (in category '*FFI-Kernel') ----- + callback + <pragmaParser> + + | descriptorClass retType externalName args argType | + descriptorClass := self environment classNamed: #ExternalFunction. + "Parse return type" + self advance. + retType := self externalType: descriptorClass. + retType == nil ifTrue:[^self expected:'return type']. + "Parse function name or index" + externalName := here. + + (self match: #leftParenthesis) ifFalse:[^self expected:'function pointer (*)']. + (self matchToken: #*) ifFalse:[^self expected:'function pointer (*)']. + (self match: #rightParenthesis) ifFalse:[^self expected:'function pointer (*)']. + + (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. + args := WriteStream on: Array new. + [self match: #rightParenthesis] whileFalse:[ + argType := self externalType: descriptorClass. + argType == nil ifTrue:[^self expected:'argument']. + argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. + + self addPragma: (Pragma keyword: #callback: arguments: {{retType}, args contents}). + ^true! Item was added: + ----- Method: Parser>>cdecl (in category '*FFI-Kernel') ----- + cdecl + <pragmaParser> + ^ self externalFunctionDeclaration! Item was added: + ----- Method: Parser>>externalFunctionDeclaration (in category '*FFI-Kernel') ----- + externalFunctionDeclaration + "Parse the function declaration for a call to an external library. + + (1) Create an instance of ExternalLibraryFunction and install it as first literal. + (2) Add a pragma to primitive call 120. + " + | descriptorClass callType modifier retType externalName args argType module fn | + descriptorClass := cue environment + valueOf: #ExternalFunction + ifAbsent: [^ false]. + callType := descriptorClass callingConventionFor: here. + callType == nil ifTrue:[^false]. + [modifier := descriptorClass callingConventionModifierFor: token. + modifier notNil] whileTrue: + [self advance. + callType := callType bitOr: modifier]. + "Parse return type" + self advance. + retType := self externalType: descriptorClass. + retType == nil ifTrue:[^self expected:'return type']. + "Parse function name or index" + externalName := here. + (self match: #number) + ifFalse: [ "Consume all tokens as function name" + self advance. + externalName := externalName asSymbol]. + (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. + args := WriteStream on: Array new. + [self match: #rightParenthesis] whileFalse:[ + argType := self externalType: descriptorClass. + argType == nil ifTrue:[^self expected:'argument']. + argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. + (self matchToken: 'module:') ifTrue:[ + module := here. + (self match: #string) ifFalse:[^self expected: 'String']. + module := module asSymbol]. + + self environment at: #ExternalLibraryFunction ifPresent:[:xfn| + fn := xfn name: externalName + module: module + callType: callType + returnType: retType + argumentTypes: args contents. + self allocateLiteral: fn. + fn beWritableObject. "Undo the read-only setting in litIndex:"]. + (self matchToken: 'error:') + ifTrue: + [| errorCodeVariable | + errorCodeVariable := here. + (hereType == #string + or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. + self advance. + self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). + fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] + ifFalse: + [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. + ^true! Item was added: + ----- Method: Parser>>externalType: (in category '*FFI-Kernel') ----- + externalType: descriptorClass + "Parse and return an external type. Ignore leading comma and 'const'." + + | xType typeName isArrayType tokenString | + self matchToken: ','. + self matchToken: 'const'. + typeName := here. "Note that pointer token is not yet parsed!!" + self advance. + (isArrayType := self matchToken: $[) + ifTrue: [ + (self matchToken: $]) + ifTrue: [typeName := typeName, '[]'] + ifFalse: [ + typeName := typeName, '[', here, ']'. + self advance. + (self matchToken: $]) ifFalse: [^ self expected: 'closing bracket']]]. + (xType := descriptorClass typeNamed: typeName) + ifNil: [ + "Raise an error if user is there" + self interactive ifTrue: [^nil]. + "otherwise go over it silently -- use an unknown struct type" + xType := descriptorClass newTypeNamed: typeName]. + isArrayType ifTrue: [ + xType := xType asPointerType]. + self flag: #todo. "mt: Extra commas are currently merged with pointer indicator as a single token." + tokenString := here asString. + ^ (tokenString first == $*) + ifTrue: [self advance. xType asPointerType] + ifFalse:[(tokenString beginsWith: '**') + ifTrue: [self advance. xType asPointerToPointerType] + ifFalse: [xType]]!

1 0

The Trunk: Sound-eem.81.mcz
by commits＠source.squeak.org 26 May '21

26 May '21

Eliot Miranda uploaded a new version of Sound to project The Trunk: http://source.squeak.org/trunk/Sound-eem.81.mcz ==================== Summary ==================== Name: Sound-eem.81 Author: eem Time: 26 May 2021, 12:03:03.709521 pm UUID: 43c1e089-1145-4a27-b5b8-f35e872fc99a Ancestors: Sound-eem.80 Better meterFrom:count:in: =============== Diff against Sound-eem.80 =============== Item was changed: ----- Method: SoundRecorder>>meterFrom:count:in: (in category 'private') ----- meterFrom: start count: count in: buffer "Update the meter level with the maximum signal level in the given range of the given buffer." + | max sample min | + count = 0 ifTrue: [^self]. "no new samples" + max := min := 0. + start to: start + count - 1 do: + [:i | - | last max sample | - count = 0 ifTrue: [^ self]. "no new samples" - last := start + count - 1. - max := 0. - start to: last do: [:i | sample := buffer at: i. + sample > max + ifTrue: [max := sample] + ifFalse: + [sample < min ifTrue: [min := sample]]]. + meterLevel := max max: min negated! - sample < 0 ifTrue: [sample := sample negated]. - sample > max ifTrue: [max := sample]]. - meterLevel := max. - !

1 0

FFI: FFI-Pools-mt.29.mcz
by commits＠source.squeak.org 26 May '21

26 May '21

Marcel Taeumel uploaded a new version of FFI-Pools to project FFI: http://source.squeak.org/FFI/FFI-Pools-mt.29.mcz ==================== Summary ==================== Name: FFI-Pools-mt.29 Author: mt Time: 26 May 2021, 6:57:13.954386 pm UUID: 35ffa57b-8d10-8148-80f8-dd10f3e1ccdf Ancestors: FFI-Pools-mt.28 Remove dependencies on "FFI-Kernel" classes. Use #environment instead of Smalltalk global. =============== Diff against FFI-Pools-mt.28 =============== Item was changed: ----- Method: Parser>>callback (in category '*FFI-Pools') ----- callback <pragmaParser> | descriptorClass retType externalName args argType | + descriptorClass := self environment classNamed: #ExternalFunction. - descriptorClass := ExternalFunction. "Parse return type" self advance. retType := self externalType: descriptorClass. retType == nil ifTrue:[^self expected:'return type']. "Parse function name or index" externalName := here. (self match: #leftParenthesis) ifFalse:[^self expected:'function pointer (*)']. (self matchToken: #*) ifFalse:[^self expected:'function pointer (*)']. (self match: #rightParenthesis) ifFalse:[^self expected:'function pointer (*)']. (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. args := WriteStream on: Array new. [self match: #rightParenthesis] whileFalse:[ argType := self externalType: descriptorClass. argType == nil ifTrue:[^self expected:'argument']. argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. self addPragma: (Pragma keyword: #callback: arguments: {{retType}, args contents}). ^true! Item was changed: ----- Method: Parser>>externalFunctionDeclaration (in category '*FFI-Pools') ----- externalFunctionDeclaration "Parse the function declaration for a call to an external library. (1) Create an instance of ExternalLibraryFunction and install it as first literal. (2) Add a pragma to primitive call 120. " | descriptorClass callType modifier retType externalName args argType module fn | descriptorClass := cue environment valueOf: #ExternalFunction ifAbsent: [^ false]. callType := descriptorClass callingConventionFor: here. callType == nil ifTrue:[^false]. [modifier := descriptorClass callingConventionModifierFor: token. modifier notNil] whileTrue: [self advance. callType := callType bitOr: modifier]. "Parse return type" self advance. retType := self externalType: descriptorClass. retType == nil ifTrue:[^self expected:'return type']. "Parse function name or index" externalName := here. (self match: #number) ifFalse: [ "Consume all tokens as function name" self advance. externalName := externalName asSymbol]. (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. args := WriteStream on: Array new. [self match: #rightParenthesis] whileFalse:[ argType := self externalType: descriptorClass. argType == nil ifTrue:[^self expected:'argument']. argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. (self matchToken: 'module:') ifTrue:[ module := here. (self match: #string) ifFalse:[^self expected: 'String']. module := module asSymbol]. + self environment at: #ExternalLibraryFunction ifPresent:[:xfn| - Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| fn := xfn name: externalName module: module callType: callType returnType: retType argumentTypes: args contents. self allocateLiteral: fn. fn beWritableObject. "Undo the read-only setting in litIndex:"]. (self matchToken: 'error:') ifTrue: [| errorCodeVariable | errorCodeVariable := here. (hereType == #string or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. self advance. self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] ifFalse: [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. ^true!

1 0

FFI: FFI-PoolsTests-mt.11.mcz
by commits＠source.squeak.org 26 May '21

26 May '21

Marcel Taeumel uploaded a new version of FFI-PoolsTests to project FFI: http://source.squeak.org/FFI/FFI-PoolsTests-mt.11.mcz ==================== Summary ==================== Name: FFI-PoolsTests-mt.11 Author: mt Time: 26 May 2021, 6:50:02.802386 pm UUID: 8276584d-e807-414f-b17f-0b6537d11f44 Ancestors: FFI-PoolsTests-mt.10 Fixes #testDefaultDefinition and #testInheritance. =============== Diff against FFI-PoolsTests-mt.10 =============== Item was changed: ----- Method: FFIExternalSharedPoolTest>>definitionClass (in category 'defaults') ----- definitionClass + ^ ExternalPoolDefinition! - ^ FFIExternalSharedPoolDefinition!

1 0

FFI: FFI-Callbacks-mt.20.mcz
by commits＠source.squeak.org 26 May '21

26 May '21

Marcel Taeumel uploaded a new version of FFI-Callbacks to project FFI: http://source.squeak.org/FFI/FFI-Callbacks-mt.20.mcz ==================== Summary ==================== Name: FFI-Callbacks-mt.20 Author: mt Time: 26 May 2021, 6:46:25.775386 pm UUID: f8235d1d-8848-d04d-80c9-868dbc5f3f20 Ancestors: FFI-Callbacks-mt.19 Some preparations for code-generation in FFICallback to speed up callback evaluation. Fixes callback test #test05SortArrayOfPointers. =============== Diff against FFI-Callbacks-mt.19 =============== Item was changed: ExternalObject subclass: #FFICallback + instanceVariableNames: 'abi evaluableObject evaluator thunk argumentTypes resultType' - instanceVariableNames: 'abi type evaluableObject thunk argumentTypes resultType' classVariableNames: 'ThunkToCallbackMap' poolDictionaries: '' category: 'FFI-Callbacks'! Item was changed: ----- Method: FFICallback>>evaluateDynamic: (in category 'callback - evaluators') ----- evaluateDynamic: callbackContext "Read all arguments and make the call(back). Assume that 'handle' and 'type' are set correctly. Only watch out for the sign. See field definition in FFICallbackContext to explore alternative ways to read the arguments." + | byteOffset args intArgs intPos floatArgs floatPos type | - | byteOffset args intArgs intPos floatArgs floatPos | handle := callbackContext stackPtr getHandle. type := callbackContext stackPtr contentType. byteOffset := 1. intArgs := callbackContext intRegArgs. intPos := 0. floatArgs := callbackContext floatRegArgs. floatPos := 0. args := Array new: argumentTypes size. 1 to: args size do: [:argIndex | | argType data isPointer | argType := argumentTypes at: argIndex. "1) Try to read arguments from registers." data := (intPos < intArgs size and: [(isPointer := argType isPointerType) or: [argType isIntegerType]]) ifTrue: [intPos := intPos + 1. intArgs at: intPos] ifFalse: [(floatPos < floatArgs size and: [argType isFloatType]) ifTrue: [floatPos := floatPos + 1. floatArgs at: floatPos]]. data ifNotNil: [ "1b) Read pointers from register value." isPointer ifFalse: ["data is already an integer"] ifTrue: [ data := (ExternalData fromHandle: (ExternalAddress fromInteger: data) + type: argType asNonPointerType "contentType") value]] - type: argType asNonPointerType "contentType" size: 1) value]] ifNil: [ "2) If nothing was read, read the argument from the stack." data := (argType handle: handle at: byteOffset) value. byteOffset := byteOffset + ((type byteSize max: argType byteSize) roundUpTo: type byteAlignment)]. args at: argIndex put: data]. ^ self setResult: (evaluableObject valueWithArguments: args) inContext: callbackContext! Item was removed: - ----- Method: FFICallback>>setArgData: (in category 'callback') ----- - setArgData: externalData - - handle := externalData getHandle. - type := externalData contentType. ! Item was changed: ----- Method: FFICallback>>setResultType:argumentTypes:evaluableObject: (in category 'initialization') ----- setResultType: anExternalType argumentTypes: moreExternalTypes evaluableObject: blockOrMessage abi := FFIPlatformDescription current abi. - handle := nil. - type := nil. evaluableObject := blockOrMessage. argumentTypes := moreExternalTypes. resultType := anExternalType. "Support for callee pop callbacks (Pascal calling convention such as the Win32 stdcall: convention) are supported using the <calleepops: N> pragma which specifies how many bytes to pop. See http://forum.world.st/Pharo-FFI-on-aarch64-arm64-td5096777.html#a5096786." thunk := FFICallbackMemory allocateExecutableBlock. self init__ccall. "self init__stdcall: 0." "(method pragmaAt: #calleepops:) ifNil: [self init__ccall] ifNotNil: [:pragma | self init__stdcall: (pragma argumentAt: 1)]." "numEvaluatorArgs := (evaluator := method selector) numArgs. self addToThunkTable" ThunkToCallbackMap at: thunk getHandle put: self! Item was changed: ----- Method: FFICallback>>valueInContext: (in category 'callback') ----- valueInContext: callbackContext "<FFICallbackContext> ^<Integer>" + ^ evaluator + ifNil: [self evaluateDynamic: callbackContext] + ifNotNil: [evaluator perform: callbackContext]! - ^ self evaluateDynamic: callbackContext!

1 0

FFI: FFI-Kernel-mt.173.mcz
by commits＠source.squeak.org 26 May '21

26 May '21

Marcel Taeumel uploaded a new version of FFI-Kernel to project FFI: http://source.squeak.org/FFI/FFI-Kernel-mt.173.mcz ==================== Summary ==================== Name: FFI-Kernel-mt.173 Author: mt Time: 26 May 2021, 6:43:06.758386 pm UUID: a4390742-4fe7-0a44-b077-b39954d28611 Ancestors: FFI-Kernel-mt.172 Adds a singleton interface to ExternalLibrary. =============== Diff against FFI-Kernel-mt.172 =============== Item was changed: ExternalObject subclass: #ExternalLibrary instanceVariableNames: 'name' classVariableNames: '' poolDictionaries: '' category: 'FFI-Kernel'! + ExternalLibrary class + instanceVariableNames: 'default'! + !ExternalLibrary commentStamp: 'mt 6/8/2020 13:21' prior: 0! - !ExternalLibrary commentStamp: '<historical>' prior: 0! An external library bundles calls to functions from the same library. It is provided mainly as convenience since every external function can be fully specified by the name and the module it resides in. + Every external function that is defined in an external library by default will use the library it is defined in. This can always be modified by providing the appropriate module in the specification. + + Note that you will only get a valid handle *automatically* for the library if the module has not yet been loaded when making the first FFI call. After that, new instances of me must call #forceLoading to get the handle right. Consequently, it is advised to only have a single instance of your external library to reliably check #isLoaded.! + ExternalLibrary class + instanceVariableNames: 'default'! - Every external function that is defined in an external library by default will use the library it is defined in. This can always be modified by providing the appropriate module in the specification. ! Item was added: + ----- Method: ExternalLibrary class>>clearAllCaches (in category 'system startup') ----- + clearAllCaches + + self withAllSubclassesDo: [:libraryClass | + libraryClass clearCaches].! Item was added: + ----- Method: ExternalLibrary class>>clearCaches (in category 'system startup') ----- + clearCaches + + self resetDefault.! Item was added: + ----- Method: ExternalLibrary class>>default (in category 'instance access') ----- + default + + ^ default ifNil: [default := self new]! Item was added: + ----- Method: ExternalLibrary class>>platformChangedFrom:to: (in category 'system startup') ----- + platformChangedFrom: oldPlatform to: newPlatform + + self clearAllCaches.! Item was added: + ----- Method: ExternalLibrary class>>resetDefault (in category 'instance creation') ----- + resetDefault + + default := nil.! Item was changed: ----- Method: FFIPlatformDescription class>>startUp: (in category 'system startup') ----- startUp: resuming "Notify all FFI classes about platform changes." resuming ifTrue: [ LastPlatform in: [:lastPlatform | self newCurrent in: [:currentPlatform | lastPlatform = currentPlatform ifTrue: [ self flag: #discuss. "mt: Maybe add #platformResuming?" ExternalAddress allBeNull. ExternalType cleanupUnusedTypes ] ifFalse: [ LastPlatform := currentPlatform. "Update now. See #current." + { ExternalAddress. ExternalType. ExternalStructure. ExternalPool. ExternalLibrary } - { ExternalAddress. ExternalType. ExternalStructure. ExternalPool } do: [:cls | cls platformChangedFrom: lastPlatform to: currentPlatform] ]]]. self checkFFIOnStartUp ifTrue: [self checkFFI]. self checkCStandardLibraryOnStartUp ifTrue: [self checkCStandardLibrary]].!

1 0

FFI: FFI-Pools-mt.28.mcz
by commits＠source.squeak.org 26 May '21

26 May '21

Marcel Taeumel uploaded a new version of FFI-Pools to project FFI: http://source.squeak.org/FFI/FFI-Pools-mt.28.mcz ==================== Summary ==================== Name: FFI-Pools-mt.28 Author: mt Time: 26 May 2021, 6:39:30.828386 pm UUID: 9faaf707-ff49-c547-91c4-9bdbcd3e5834 Ancestors: FFI-Pools-mt.27 Complements FFI-Kernel-mt.172 =============== Diff against FFI-Pools-mt.27 =============== Item was added: + ----- Method: Parser>>apicall (in category '*FFI-Pools') ----- + apicall + <pragmaParser> + ^ self externalFunctionDeclaration! Item was added: + ----- Method: Parser>>callback (in category '*FFI-Pools') ----- + callback + <pragmaParser> + + | descriptorClass retType externalName args argType | + descriptorClass := ExternalFunction. + "Parse return type" + self advance. + retType := self externalType: descriptorClass. + retType == nil ifTrue:[^self expected:'return type']. + "Parse function name or index" + externalName := here. + + (self match: #leftParenthesis) ifFalse:[^self expected:'function pointer (*)']. + (self matchToken: #*) ifFalse:[^self expected:'function pointer (*)']. + (self match: #rightParenthesis) ifFalse:[^self expected:'function pointer (*)']. + + (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. + args := WriteStream on: Array new. + [self match: #rightParenthesis] whileFalse:[ + argType := self externalType: descriptorClass. + argType == nil ifTrue:[^self expected:'argument']. + argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. + + self addPragma: (Pragma keyword: #callback: arguments: {{retType}, args contents}). + ^true! Item was added: + ----- Method: Parser>>cdecl (in category '*FFI-Pools') ----- + cdecl + <pragmaParser> + ^ self externalFunctionDeclaration! Item was added: + ----- Method: Parser>>externalFunctionDeclaration (in category '*FFI-Pools') ----- + externalFunctionDeclaration + "Parse the function declaration for a call to an external library. + + (1) Create an instance of ExternalLibraryFunction and install it as first literal. + (2) Add a pragma to primitive call 120. + " + | descriptorClass callType modifier retType externalName args argType module fn | + descriptorClass := cue environment + valueOf: #ExternalFunction + ifAbsent: [^ false]. + callType := descriptorClass callingConventionFor: here. + callType == nil ifTrue:[^false]. + [modifier := descriptorClass callingConventionModifierFor: token. + modifier notNil] whileTrue: + [self advance. + callType := callType bitOr: modifier]. + "Parse return type" + self advance. + retType := self externalType: descriptorClass. + retType == nil ifTrue:[^self expected:'return type']. + "Parse function name or index" + externalName := here. + (self match: #number) + ifFalse: [ "Consume all tokens as function name" + self advance. + externalName := externalName asSymbol]. + (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. + args := WriteStream on: Array new. + [self match: #rightParenthesis] whileFalse:[ + argType := self externalType: descriptorClass. + argType == nil ifTrue:[^self expected:'argument']. + argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. + (self matchToken: 'module:') ifTrue:[ + module := here. + (self match: #string) ifFalse:[^self expected: 'String']. + module := module asSymbol]. + + Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| + fn := xfn name: externalName + module: module + callType: callType + returnType: retType + argumentTypes: args contents. + self allocateLiteral: fn. + fn beWritableObject. "Undo the read-only setting in litIndex:"]. + (self matchToken: 'error:') + ifTrue: + [| errorCodeVariable | + errorCodeVariable := here. + (hereType == #string + or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. + self advance. + self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). + fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] + ifFalse: + [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. + ^true! Item was added: + ----- Method: Parser>>externalType: (in category '*FFI-Pools') ----- + externalType: descriptorClass + "Parse and return an external type. Ignore leading comma and 'const'." + + | xType typeName isArrayType tokenString | + self matchToken: ','. + self matchToken: 'const'. + typeName := here. "Note that pointer token is not yet parsed!!" + self advance. + (isArrayType := self matchToken: $[) + ifTrue: [ + (self matchToken: $]) + ifTrue: [typeName := typeName, '[]'] + ifFalse: [ + typeName := typeName, '[', here, ']'. + self advance. + (self matchToken: $]) ifFalse: [^ self expected: 'closing bracket']]]. + (xType := descriptorClass typeNamed: typeName) + ifNil: [ + "Raise an error if user is there" + self interactive ifTrue: [^nil]. + "otherwise go over it silently -- use an unknown struct type" + xType := descriptorClass newTypeNamed: typeName]. + isArrayType ifTrue: [ + xType := xType asPointerType]. + self flag: #todo. "mt: Extra commas are currently merged with pointer indicator as a single token." + tokenString := here asString. + ^ (tokenString first == $*) + ifTrue: [self advance. xType asPointerType] + ifFalse:[(tokenString beginsWith: '**') + ifTrue: [self advance. xType asPointerToPointerType] + ifFalse: [xType]]!

1 0

FFI: FFI-Kernel-mt.172.mcz
by commits＠source.squeak.org 26 May '21

26 May '21

Marcel Taeumel uploaded a new version of FFI-Kernel to project FFI: http://source.squeak.org/FFI/FFI-Kernel-mt.172.mcz ==================== Summary ==================== Name: FFI-Kernel-mt.172 Author: mt Time: 26 May 2021, 6:39:07.815386 pm UUID: 14335f5b-67ba-8d44-b22d-8879378801a4 Ancestors: FFI-Kernel-mt.171 Moves parser extension to "FFI-Pools" to be loaded before "FFI-Kernel" so that the latter may include external libraries with external functions such as libc and qsort. =============== Diff against FFI-Kernel-mt.171 =============== Item was removed: - ----- Method: Parser>>apicall (in category '*FFI-Kernel') ----- - apicall - <pragmaParser> - ^ self externalFunctionDeclaration! Item was removed: - ----- Method: Parser>>callback (in category '*FFI-Kernel') ----- - callback - <pragmaParser> - - | descriptorClass retType externalName args argType | - descriptorClass := ExternalFunction. - "Parse return type" - self advance. - retType := self externalType: descriptorClass. - retType == nil ifTrue:[^self expected:'return type']. - "Parse function name or index" - externalName := here. - - (self match: #leftParenthesis) ifFalse:[^self expected:'function pointer (*)']. - (self matchToken: #*) ifFalse:[^self expected:'function pointer (*)']. - (self match: #rightParenthesis) ifFalse:[^self expected:'function pointer (*)']. - - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: Array new. - [self match: #rightParenthesis] whileFalse:[ - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - - self addPragma: (Pragma keyword: #callback: arguments: {{retType}, args contents}). - ^true! Item was removed: - ----- Method: Parser>>cdecl (in category '*FFI-Kernel') ----- - cdecl - <pragmaParser> - ^ self externalFunctionDeclaration! Item was removed: - ----- Method: Parser>>externalFunctionDeclaration (in category '*FFI-Kernel') ----- - externalFunctionDeclaration - "Parse the function declaration for a call to an external library. - - (1) Create an instance of ExternalLibraryFunction and install it as first literal. - (2) Add a pragma to primitive call 120. - " - | descriptorClass callType modifier retType externalName args argType module fn | - descriptorClass := cue environment - valueOf: #ExternalFunction - ifAbsent: [^ false]. - callType := descriptorClass callingConventionFor: here. - callType == nil ifTrue:[^false]. - [modifier := descriptorClass callingConventionModifierFor: token. - modifier notNil] whileTrue: - [self advance. - callType := callType bitOr: modifier]. - "Parse return type" - self advance. - retType := self externalType: descriptorClass. - retType == nil ifTrue:[^self expected:'return type']. - "Parse function name or index" - externalName := here. - (self match: #number) - ifFalse: [ "Consume all tokens as function name" - self advance. - externalName := externalName asSymbol]. - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: Array new. - [self match: #rightParenthesis] whileFalse:[ - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - (self matchToken: 'module:') ifTrue:[ - module := here. - (self match: #string) ifFalse:[^self expected: 'String']. - module := module asSymbol]. - - Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| - fn := xfn name: externalName - module: module - callType: callType - returnType: retType - argumentTypes: args contents. - self allocateLiteral: fn. - fn beWritableObject. "Undo the read-only setting in litIndex:"]. - (self matchToken: 'error:') - ifTrue: - [| errorCodeVariable | - errorCodeVariable := here. - (hereType == #string - or: [hereType == #word]) ifFalse:[^self expected: 'error code (a variable or string)']. - self advance. - self addPragma: (Pragma keyword: #primitive:error: arguments: (Array with: 120 with: errorCodeVariable)). - fn ifNotNil: [fn setErrorCodeName: errorCodeVariable]] - ifFalse: - [self addPragma: (Pragma keyword: #primitive: arguments: #(120))]. - ^true! Item was removed: - ----- Method: Parser>>externalType: (in category '*FFI-Kernel') ----- - externalType: descriptorClass - "Parse and return an external type. Ignore leading comma and 'const'." - - | xType typeName isArrayType tokenString | - self matchToken: ','. - self matchToken: 'const'. - typeName := here. "Note that pointer token is not yet parsed!!" - self advance. - (isArrayType := self matchToken: $[) - ifTrue: [ - (self matchToken: $]) - ifTrue: [typeName := typeName, '[]'] - ifFalse: [ - typeName := typeName, '[', here, ']'. - self advance. - (self matchToken: $]) ifFalse: [^ self expected: 'closing bracket']]]. - (xType := descriptorClass typeNamed: typeName) - ifNil: [ - "Raise an error if user is there" - self interactive ifTrue: [^nil]. - "otherwise go over it silently -- use an unknown struct type" - xType := descriptorClass newTypeNamed: typeName]. - isArrayType ifTrue: [ - xType := xType asPointerType]. - self flag: #todo. "mt: Extra commas are currently merged with pointer indicator as a single token." - tokenString := here asString. - ^ (tokenString first == $*) - ifTrue: [self advance. xType asPointerType] - ifFalse:[(tokenString beginsWith: '**') - ifTrue: [self advance. xType asPointerToPointerType] - ifFalse: [xType]]!

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages May 2021