70 lines
2.1 KiB
Forth
70 lines
2.1 KiB
Forth
\ Copyright 2022 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 , ' call11 , ' call12 , ' call13 , ' call14 , ' call15 ,
|
|
windows
|
|
: sofunc ( z n a "name" -- )
|
|
>r dup 15 > throw r> ( Check there aren't too many args )
|
|
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 ;
|
|
: contains? ( z 'lib -- f ) >body @ swap GetProcAddress ;
|
|
|
|
z" Kernel32.dll" dll Kernel32
|
|
|
|
z" ExitProcess" 1 Kernel32 ExitProcess
|
|
z" Sleep" 1 Kernel32 Sleep
|
|
z" GetTickCount" 0 Kernel32 GetTickCount
|
|
z" WaitForSingleObject" 2 Kernel32 WaitForSingleObject
|
|
z" GetLastError" 0 Kernel32 GetLastError
|
|
z" GetCommandLineW" 0 Kernel32 GetCommandLineW
|
|
z" GetModuleHandleA" 1 Kernel32 GetModuleHandleA
|
|
|
|
z" Shell32.dll" dll Shell32
|
|
z" CommandLineToArgvW" 2 Shell32 CommandLineToArgvW
|
|
|
|
variable wargc variable wargv
|
|
GetCommandLineW wargc CommandLineToArgvW wargv !
|
|
: wz>sz ( a -- a n )
|
|
here swap begin dup sw@ 0<> while dup sw@ c, 2 + repeat drop 0 c, align ;
|
|
: wargs-convert ( dst )
|
|
wargv @ wargc @ for aft
|
|
dup @ wz>sz >r swap r> over ! cell+ swap cell+
|
|
then next 2drop ;
|
|
also internals
|
|
wargc @ 'argc !
|
|
here 'argv ! wargc @ cells allot
|
|
'argv @ wargs-convert
|
|
|
|
0 constant NULL
|
|
|
|
forth definitions
|
|
|
|
( Other Utils )
|
|
: ms ( n -- ) Sleep ;
|
|
: ms-ticks ( -- n ) GetTickCount ;
|
|
|
|
only forth
|
|
|
|
( Setup entry )
|
|
internals : ok ." uEforth" raw-ok ; forth
|