\ Copyright 2021 Bradley D. Nelson \ \ Licensed under the Apache License, Version 2.0 (the "License"); \ you may not use this file except in compliance with the License. \ You may obtain a copy of the License at \ \ http://www.apache.org/licenses/LICENSE-2.0 \ \ Unless required by applicable law or agreed to in writing, software \ distributed under the License is distributed on an "AS IS" BASIS, \ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. \ See the License for the specific language governing permissions and \ limitations under the License. vocabulary windows windows definitions ( DLL Handling ) create calls internals ' call0 , ' call1 , ' call2 , ' call3 , ' call4 , ' call5 , ' call6 , ' call7 , ' call8 , ' call9 , ' call10 , windows : sofunc ( z n a "name" -- ) swap >r swap GetProcAddress dup 0= throw create , r> cells calls + @ , does> dup @ swap cell+ @ execute ; : dll ( z "name" -- ) LoadLibraryA dup 0= throw create , does> @ sofunc ; 0 constant NULL 0 constant MB_OK 1 constant MB_OKCANCEL 2 constant MB_ABORTRETRYIGNORE 3 constant MB_YESNOCANCEL 4 constant MB_YESNO 5 constant MB_RETRYCANCEL 6 constant MB_CANCELTRYCONTINUE -10 constant STD_INPUT_HANDLE -11 constant STD_OUTPUT_HANDLE -12 constant STD_ERROR_HANDLE $0001 constant ENABLE_PROCESSED_INPUT $0002 constant ENABLE_LINE_INPUT $0004 constant ENABLE_ECHO_INPUT $0008 constant ENABLE_WINDOW_INPUT $0010 constant ENABLE_MOUSE_INPUT $0020 constant ENABLE_INSERT_MODE $0040 constant ENABLE_QUICK_EDIT_MODE $0200 constant ENABLE_VIRTUAL_TERMINAL_INPUT $0001 constant ENABLE_PROCESSED_OUTPUT $0002 constant ENABLE_WRAP_AT_EOL_OUTPUT $0004 constant ENABLE_VIRTUAL_TERMINAL_PROCESSING $0008 constant DISABLE_NEWLINE_AUTO_RETURN $0010 constant ENABLE_LVB_GRID_WORLDWIDE z" User32.dll" dll User32 z" MessageBoxA" 4 User32 MessageBoxA z" Kernel32.dll" dll Kernel32 z" AllocConsole" 0 Kernel32 AllocConsole z" ExitProcess" 1 Kernel32 ExitProcess z" GetStdHandle" 1 Kernel32 GetStdHandle z" GetConsoleMode" 2 Kernel32 GetConsoleMode z" SetConsoleMode" 2 Kernel32 SetConsoleMode z" FlushConsoleInputBuffer" 1 Kernel32 FlushConsoleInputBuffer z" Sleep" 1 Kernel32 Sleep z" WaitForSingleObject" 2 Kernel32 WaitForSingleObject z" GetLastError" 0 Kernel32 GetLastError z" CreateFileA" 7 Kernel32 CreateFileA z" ReadFile" 5 Kernel32 ReadFile z" WriteFile" 5 Kernel32 WriteFile z" CloseHandle" 1 Kernel32 CloseHandle z" FlushFileBuffers" 1 Kernel32 FlushFileBuffers z" DeleteFileA" 1 Kernel32 DeleteFileA z" MoveFileA" 2 Kernel32 MoveFileA z" SetFilePointer" 4 Kernel32 SetFilePointer z" SetEndOfFile" 1 Kernel32 SetEndOfFile z" GetFileSize" 2 Kernel32 GetFileSize AllocConsole drop STD_INPUT_HANDLE GetStdHandle constant stdin STD_OUTPUT_HANDLE GetStdHandle constant stdout STD_ERROR_HANDLE GetStdHandle constant stderr variable console-mode stdin console-mode GetConsoleMode drop stdin console-mode @ ENABLE_LINE_INPUT ENABLE_MOUSE_INPUT or ENABLE_WINDOW_INPUT or invert and SetConsoleMode drop stdout console-mode GetConsoleMode drop stdout console-mode @ ENABLE_VIRTUAL_TERMINAL_PROCESSING or SetConsoleMode drop : win-type ( a n -- ) stdout -rot NULL NULL WriteFile drop ; ' win-type is type : raw-key ( -- n ) 0 >r stdin rp@ 1 NULL NULL ReadFile drop r> ; : win-key? ( -- f ) stdin 0 WaitForSingleObject 0= ; ' win-key? is key? : win-key ( -- n ) raw-key dup 13 = if drop nl then ; ' win-key is key : win-bye ( -- ) 0 ExitProcess drop ; ' win-bye is bye -1 echo ! ansi : set-title ( a n -- ) esc ." ]0;" type bel ; windows s" uEforth" set-title ( Window File Specific ) 1 constant FILE_SHARE_READ 2 constant FILE_SHARE_WRITE 2 constant CREATE_ALWAYS 3 constant OPEN_EXISTING $80 constant FILE_ATTRIBUTE_NORMAL 0 constant FILE_BEGIN 1 constant FILE_CURRENT 2 constant FILE_END ( I/O Error Helpers ) : ior ( f -- ior ) if GetLastError else 0 then ; : 0=ior ( n -- n ior ) 0= ior ; : d0( n -- n ior ) dup 0< ior ; : invalid?ior ( n -- ior ) $ffffffff = ior ; forth definitions windows ( Generic Files ) $80000000 constant r/o ( GENERIC_READ ) $40000000 constant w/o ( GENERIC_WRITE ) r/o w/o or constant r/w : open-file ( a n fam -- fh ior ) >r s>z r> FILE_SHARE_READ FILE_SHARE_WRITE or NULL OPEN_EXISTING FILE_ATTRIBUTE_NORMAL NULL CreateFileA d0 ; : create-file ( a n fam -- fh ior ) >r s>z r> FILE_SHARE_READ FILE_SHARE_WRITE or NULL CREATE_ALWAYS FILE_ATTRIBUTE_NORMAL NULL CreateFileA d0 ; : close-file ( fh -- ior ) CloseHandle 0=ior ; : flush-file ( fh -- ior ) FlushFileBuffers 0=ior ; : delete-file ( a n -- ior ) s>z DeleteFileA 0=ior ; : rename-file ( a n a n -- ior ) s>z -rot s>z swap MoveFileA 0=ior ; : read-file ( a n fh -- n ior ) -rot 0 >r rp@ NULL ReadFile r> swap 0=ior ; : write-file ( a n fh -- ior ) -rot dup >r 0 >r rp@ NULL WriteFile if r> r> <> else rdrop rdrop GetLastError then ; : file-position ( fh -- n ior ) 0 NULL FILE_CURRENT SetFilePointer dup invalid?ior ; : reposition-file ( n fh -- ior ) swap NULL FILE_BEGIN SetFilePointer invalid?ior ; : resize-file ( n fh -- ior ) dup file-position dup if drop 2drop 1 ior exit else drop then >r dup -rot reposition-file if rdrop drop 1 ior exit then dup SetEndOfFile 0= if rdrop drop 1 ior exit then r> swap reposition-file ; : file-size ( fh -- n ior ) NULL GetFileSize dup invalid?ior ; ( Other Utils ) : ms ( n -- ) Sleep ; forth ( Setup entry ) internals : ok ." uEforth" raw-ok ; forth ' forth ( leave on stack for fini.fs )
Legal: site web personnel sans commerce / personal site without seling