alx/ueforth
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Adding structures, fix locals bug, win32 bindings.

Browse Source
This commit is contained in:
Brad Nelson
2022-02-20 16:23:23 -08:00
parent 16a8695c55
commit 59cd2ff4e0
19 changed files with 979 additions and 222 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
ueforth/Makefile
View File

@ -65,11 +65,15 @@ WIN_CFLAGS = $(CFLAGS_COMMON) \
WIN_LFLAGS32 = /LIBPATH:"c:/Program Files (x86)/Microsoft SDKs/Windows/v7.1A/Lib" \
/LIBPATH:"c:/Program Files (x86)/Microsoft Visual Studio/2019/Community/VC/Tools/MSVC/14.28.29333/lib/x86" \
/LIBPATH:"c:/Program Files (x86)/Windows Kits/10/Lib/10.0.19041.0/ucrt/x86"
/LIBPATH:"c:/Program Files (x86)/Windows Kits/10/Lib/10.0.19041.0/ucrt/x86" \
$(WIN_LIBS)
WIN_LFLAGS64 = /LIBPATH:"c:/Program Files (x86)/Microsoft SDKs/Windows/v7.1A/Lib/x64" \
/LIBPATH:"c:/Program Files (x86)/Microsoft Visual Studio/2019/Community/VC/Tools/MSVC/14.28.29333/lib/x64" \
/LIBPATH:"c:/Program Files (x86)/Windows Kits/10/Lib/10.0.19041.0/ucrt/x64" \
$(WIN_LIBS)
WIN_LIBS=user32.lib
TARGETS = posix_target \
web_target \
@ -180,7 +184,7 @@ $(GEN):
mkdir -p $@
COMMON_PHASE1 = common/boot.fs common/conditionals.fs common/vocabulary.fs \
common/floats.fs
common/floats.fs common/structures.fs
COMMON_DESKTOP = common/ansi.fs common/desktop.fs
@ -198,7 +202,13 @@ $(GEN)/posix_boot.h: common/source_to_string.js $(POSIX_BOOT) | $(GEN)
$< boot $(VERSION) $(REVISION) $(POSIX_BOOT) >$@
WINDOWS_BOOT = $(COMMON_PHASE1) \
windows/windows.fs windows/allocation.fs \
windows/windows_core.fs \
windows/windows_files.fs \
windows/windows_console.fs \
windows/windows_user.fs \
windows/windows_gdi.fs \
windows/windows_messages.fs \
windows/allocation.fs \
$(COMMON_PHASE2) $(COMMON_DESKTOP) \
posix/autoboot.fs \
common/fini.fs

1
ueforth/common/all_tests.fs
View File

@ -22,4 +22,5 @@ include common/doloop_tests.fs
include common/conditionals_tests.fs
include common/float_tests.fs
include common/forth_namespace_tests.fs
include common/structures_tests.fs
run-tests

2
ueforth/common/calling.h
View File

@ -25,6 +25,8 @@
#define n8 sp[-7]
#define n9 sp[-8]
#define n10 sp[-9]
#define n11 sp[-10]
#define n12 sp[-11]
#define a0 ((void *) tos)
#define a1 (*(void **) &n1)

4
ueforth/common/calls.h
View File

@ -35,4 +35,6 @@ typedef cell_t (CALLTYPE *call_t)();
YV(internals, CALL7, n0 = ct0(n7, n6, n5, n4, n3, n2, n1); sp -= 7) \
YV(internals, CALL8, n0 = ct0(n8, n7, n6, n5, n4, n3, n2, n1); sp -= 8) \
YV(internals, CALL9, n0 = ct0(n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 9) \
YV(internals, CALL10, n0 = ct0(n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 10)
YV(internals, CALL10, n0 = ct0(n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 10) \
YV(internals, CALL11, n0 = ct0(n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 11) \
YV(internals, CALL12, n0 = ct0(n12, n11, n10, n9, n8, n7, n6, n5, n4, n3, n2, n1); sp -= 12)

18
ueforth/common/forth_namespace_tests.fs
View File

@ -29,6 +29,7 @@ also internals
e: check-locals
out: +to
out: to
out: exit
out: ;
out: {
out: (local)
@ -423,6 +424,7 @@ e: check-allocation
;e
e: check-phase1
out: structures
check-highlevel-floats
check-vocabulary
check-[]conds
@ -460,6 +462,7 @@ e: test-windows-forth-namespace
out: streams
out: tasks
out: windows
out: structures
out: internals
out: FORTH
;e
@ -470,17 +473,18 @@ e: test-windows-forth-namespace
check-desktop
check-phase2
check-allocation
out: ok
out: ms
check-files
out: ms-ticks
out: default-key?
out: default-key
out: default-type
check-files
out: ok
out: ms-ticks
out: ms
out: windows
check-phase1
out: GETPROCADDRESS
out: LOADLIBRARYA
out: GetProcAddress
out: LoadLibraryA
out: WindowProcShim
check-opcodes
out: forth-builtins
;e
@ -496,6 +500,7 @@ e: test-posix-forth-namespace
out: tasks
out: termios
out: posix
out: structures
out: internals
out: FORTH
;e
@ -551,6 +556,7 @@ e: test-esp32-forth-namespace
out: editor
out: streams
out: tasks
out: structures
out: internals
out: FORTH
;e

4
ueforth/common/locals.fs
View File

@ -30,9 +30,10 @@ variable locals-here locals-area locals-here !
variable scope-depth
variable local-op ' local@ local-op !
: scope-exit scope-depth @ for aft postpone rdrop then next ;
: scope-clear
scope-exit
scope-depth @ negate nest-depth +!
scope-depth @ for aft postpone rdrop then next
0 scope-depth ! 0 scope ! locals-area locals-here ! ;
: do-local ( n -- ) nest-depth @ + cells negate aliteral
local-op @ , ['] local@ local-op ! ;
@ -64,6 +65,7 @@ also forth definitions
recurse (local) ; immediate
( TODO: Hide the words overriden here. )
: ; scope-clear postpone ; ; immediate
: exit scope-exit postpone exit ; immediate
: to ( n -- ) ' dup >flags if (to) else ['] ! value-bind then ; immediate
: +to ( n -- ) ' dup >flags if (+to) else ['] +! value-bind then ; immediate

38
ueforth/common/structures.fs Normal file
View File

@ -0,0 +1,38 @@
\ 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 for building C-style structures )
vocabulary structures structures definitions
variable last-align
: typer ( align sz "name" ) create , ,
does> dup cell+ @ last-align ! @ ;
1 1 typer i8
2 2 typer i16
4 4 typer i32
cell 8 typer i64
cell cell typer ptr
variable last-struct
: struct ( "name" ) 1 0 typer latestxt >body last-struct ! ;
: align-by ( a n -- a ) 1- dup >r + r> invert and ;
: struct-align ( n -- )
dup last-struct @ cell+ @ max last-struct @ cell+ !
last-struct @ @ swap align-by last-struct @ ! ;
: field ( n "name" )
last-align @ struct-align
create last-struct @ @ , last-struct @ +!
does> @ + ;
forth definitions

48
ueforth/common/structures_tests.fs Normal file
View File

@ -0,0 +1,48 @@
\ 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.
e: test-structure
also structures
struct gappy
ptr field ->first
i8 field ->foo
i16 field ->bar
i32 field ->baz
1000 ->first 1000 =assert
1000 ->foo 1000 cell+ =assert
1000 ->bar 1002 cell+ =assert
1000 ->baz 1004 cell+ =assert
i8 1 =assert
i16 2 =assert
i32 4 =assert
i64 8 =assert
ptr cell =assert
;e
e: test-nested-structure
also structures
struct rect
i32 field ->left
i32 field ->top
i32 field ->right
i32 field ->bottom
struct gappy
i16 field ->foo
rect field ->bar
1000 ->foo 1000 =assert
1000 ->bar ->left 1004 =assert
1000 ->bar ->top 1008 =assert
1000 ->bar ->right 1012 =assert
1000 ->bar ->bottom 1016 =assert
;e

26
ueforth/esp32/bindings.fs
View File

@ -47,25 +47,31 @@ DEFINED? spi_flash_init [IF]
0 constant SPI_PARTITION_TYPE_APP
1 constant SPI_PARTITION_TYPE_DATA
$ff constant SPI_PARTITION_SUBTYPE_ANY
also structures
struct esp_partition_t
( Work around changing struct layout )
: p>common ( part -- part' ) esp_partition_t_size 40 >= if cell+ then ;
: p>type ( part -- n ) p>common @ ;
: p>subtype ( part -- n ) p>common cell+ @ ;
: p>address ( part -- n ) p>common 2 cells + @ ;
: p>size ( part -- n ) p>common 3 cells + @ ;
: p>label ( part -- a n ) p>common 4 cells + z>s ;
esp_partition_t_size 40 >= [IF]
ptr field p>gap
[THEN]
ptr field p>type
ptr field p>subtype
ptr field p>address
ptr field p>size
ptr field p>label
: p. ( part -- )
base @ >r >r decimal
." TYPE: " r@ p>type . ." SUBTYPE: " r@ p>subtype .
." ADDR: " r@ hex p>address . ." SIZE: " r@ p>size .
." LABEL: " r> p>label type cr r> base ! ;
." TYPE: " r@ p>type @ . ." SUBTYPE: " r@ p>subtype @ .
." ADDR: " r@ hex p>address @ . ." SIZE: " r@ p>size @ .
." LABEL: " r> p>label @ z>s type cr r> base ! ;
: list-partition-type ( type -- )
SPI_PARTITION_SUBTYPE_ANY 0 esp_partition_find
begin dup esp_partition_get p. esp_partition_next dup 0= until drop ;
: list-partitions SPI_PARTITION_TYPE_APP list-partition-type
SPI_PARTITION_TYPE_DATA list-partition-type ;
[THEN]
forth definitions
only forth definitions
vocabulary SPIFFS SPIFFS definitions
transfer SPIFFS-builtins

3
ueforth/esp32/sim_main.cpp
View File

@ -142,6 +142,9 @@ static cell_t *simulated(cell_t *sp, const char *op) {
} else if (op == STR_getMaxAllocHeap) {
*++sp = 80 * 1024;
return sp;
} else if (op == STR_esp_partition_t_size) {
*++sp = 64;
return sp;
} else {
fprintf(stderr, "MISSING SIM OPCODE: %s\n", op);
exit(1);

35
ueforth/windows/main.c
View File

@ -36,11 +36,13 @@
#define HEAP_SIZE (10 * 1024 * 1024)
#define STACK_CELLS (8 * 1024)
static LRESULT WindowProcShim(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam);
#define PLATFORM_OPCODE_LIST \
Y(GETPROCADDRESS, \
Y(GetProcAddress, \
tos = (cell_t) GetProcAddress((HMODULE) *sp, (LPCSTR) tos); --sp) \
Y(LOADLIBRARYA, \
tos = (cell_t) LoadLibraryA((LPCSTR) tos)) \
Y(LoadLibraryA, tos = (cell_t) LoadLibraryA((LPCSTR) tos)) \
Y(WindowProcShim, DUP; tos = (cell_t) &WindowProcShim) \
CALLING_OPCODE_LIST \
FLOATING_POINT_LIST
@ -51,6 +53,33 @@
#include "gen/windows_boot.h"
static LRESULT WindowProcShim(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) {
if (msg == WM_NCCREATE) {
SetWindowLongPtr(
hwnd, GWLP_USERDATA,
(LONG_PTR) ((CREATESTRUCT *) lParam)->lpCreateParams);
}
if (!GetWindowLongPtr(hwnd, GWLP_USERDATA)) {
return DefWindowProc(hwnd, msg, wParam, lParam);
}
cell_t stacks[STACK_CELLS * 3 + 4];
cell_t *at = stacks;
at += 4;
float *fp = (float *) (at + 1); at += STACK_CELLS;
cell_t *rp = at + 1; at += STACK_CELLS;
cell_t *sp = at + 1; at += STACK_CELLS;
cell_t *ip = (cell_t *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
cell_t tos = 0;
DUP; tos = (cell_t) hwnd;
DUP; tos = (cell_t) msg;
DUP; tos = (cell_t) wParam;
DUP; tos = (cell_t) lParam;
PARK;
rp = forth_run(rp);
UNPARK;
return tos;
}
#ifdef UEFORTH_MINIMAL
int WINAPI WinMainCRTStartup(void) {
#else

197
ueforth/windows/windows.fs
View File

@ -1,197 +0,0 @@
\ 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
z" GetTickCount" 0 Kernel32 GetTickCount
z" GetCommandLineW" 0 Kernel32 GetCommandLineW
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 value console-started
0 value stdin
0 value stdout
0 value stderr
variable console-mode
: init-console
console-started if exit then
-1 to console-started
AllocConsole drop
STD_INPUT_HANDLE GetStdHandle to stdin
STD_OUTPUT_HANDLE GetStdHandle to stdout
STD_ERROR_HANDLE GetStdHandle to stderr
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 -- ) init-console stdout -rot NULL NULL WriteFile drop ;
: raw-key ( -- n ) 0 >r stdin rp@ 1 NULL NULL ReadFile drop r> ;
: win-key? ( -- f ) stdin 0 WaitForSingleObject 0= ;
: win-key ( -- n ) raw-key dup 13 = if drop nl then ;
: win-bye ( -- ) 0 ExitProcess drop ;
also forth definitions
: default-type win-type ;
: default-key win-key ;
: default-key? win-key? ;
: ms-ticks ( -- n ) GetTickCount ;
only windows definitions
' default-type is type
' default-key is key
' default-key? is key?
' win-bye is bye
-1 echo !
( 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<ior ( 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
: BIN ( fh -- fh ) ;
: CLOSE-FILE ( fh -- ior ) CloseHandle 0=ior ;
: FLUSH-FILE ( fh -- ior ) FlushFileBuffers 0=ior ;
: 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<ior ;
: 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<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 ;
: WRITE-FILE ( a n fh -- ior )
-rot dup >r 0 >r rp@ NULL WriteFile
if r> r> <> else rdrop rdrop GetLastError then ;
: READ-FILE ( a n fh -- n ior ) -rot 0 >r rp@ NULL ReadFile r> swap 0=ior ;
: 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 ;
: NON-BLOCK ( fh -- ior ) 1 throw ; ( IMPLEMENT! )
( Other Utils )
: ms ( n -- ) Sleep ;
only forth
( Setup entry )
internals : ok ." uEforth" raw-ok ; forth

79
ueforth/windows/windows_console.fs Normal file
View File

@ -0,0 +1,79 @@
\ 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.
windows definitions
-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" 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
0 value console-started
0 value stdin
0 value stdout
0 value stderr
variable console-mode
: init-console
console-started if exit then
-1 to console-started
AllocConsole drop
STD_INPUT_HANDLE GetStdHandle to stdin
STD_OUTPUT_HANDLE GetStdHandle to stdout
STD_ERROR_HANDLE GetStdHandle to stderr
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 -- ) init-console stdout -rot NULL NULL WriteFile drop ;
: raw-key ( -- n ) 0 >r stdin rp@ 1 NULL NULL ReadFile drop r> ;
: win-key? ( -- f ) stdin 0 WaitForSingleObject 0= ;
: win-key ( -- n ) raw-key dup 13 = if drop nl then ;
: win-bye ( -- ) 0 ExitProcess drop ;
also forth definitions
: default-type win-type ;
: default-key win-key ;
: default-key? win-key? ;
only windows definitions
' default-type is type
' default-key is key
' default-key? is key?
' win-bye is bye
only forth definitions

66
ueforth/windows/windows_core.fs Normal file
View File

@ -0,0 +1,66 @@
\ 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 ,
windows
: sofunc ( z n a "name" -- )
>r dup 12 > 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 ;
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" 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

77
ueforth/windows/windows_files.fs Normal file
View File

@ -0,0 +1,77 @@
\ 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.
windows definitions
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
( 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<ior ( n -- n ior ) dup 0< ior ;
: invalid?ior ( n -- ior ) $ffffffff = ior ;
also forth definitions
( Generic Files )
$80000000 constant R/O ( GENERIC_READ )
$40000000 constant W/O ( GENERIC_WRITE )
R/O W/O or constant R/W
: BIN ( fh -- fh ) ;
: CLOSE-FILE ( fh -- ior ) CloseHandle 0=ior ;
: FLUSH-FILE ( fh -- ior ) FlushFileBuffers 0=ior ;
: 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<ior ;
: 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<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 ;
: WRITE-FILE ( a n fh -- ior )
-rot dup >r 0 >r rp@ NULL WriteFile
if r> r> <> else rdrop rdrop GetLastError then ;
: READ-FILE ( a n fh -- n ior ) -rot 0 >r rp@ NULL ReadFile r> swap 0=ior ;
: 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 ;
: NON-BLOCK ( fh -- ior ) 1 throw ; ( IMPLEMENT! )
only forth definitions

27
ueforth/windows/windows_gdi.fs Normal file
View File

@ -0,0 +1,27 @@
\ 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.
windows definitions
also structures
z" Gdi32.dll" dll Gdi32
z" DeleteObject" 1 Gdi32 DeleteObject
z" CreateSolidBrush" 1 Gdi32 CreateSolidBrush
5 constant COLOR_WINDOW
: RGB ( r g b -- n ) 16 lshift swap 8 lshift + + ;
only forth definitions

361
ueforth/windows/windows_messages.fs Normal file
View File

@ -0,0 +1,361 @@
\ 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.
windows definitions
0 constant WM_NULL
1 constant WM_CREATE
2 constant WM_DESTROY
3 constant WM_MOVE
5 constant WM_SIZE
6 constant WM_ACTIVATE
7 constant WM_SETFOCUS
8 constant WM_KILLFOCUS
10 constant WM_ENABLE
11 constant WM_SETREDRAW
12 constant WM_SETTEXT
13 constant WM_GETTEXT
14 constant WM_GETTEXTLENGTH
15 constant WM_PAINT
16 constant WM_CLOSE
17 constant WM_QUERYENDSESSION
18 constant WM_QUIT
19 constant WM_QUERYOPEN
20 constant WM_ERASEBKGND
21 constant WM_SYSCOLORCHANGE
22 constant WM_ENDSESSION
24 constant WM_SHOWWINDOW
25 constant WM_CTLCOLOR
26 constant WM_WININICHANGE
27 constant WM_DEVMODECHANGE
28 constant WM_ACTIVATEAPP
29 constant WM_FONTCHANGE
30 constant WM_TIMECHANGE
31 constant WM_CANCELMODE
32 constant WM_SETCURSOR
33 constant WM_MOUSEACTIVATE
34 constant WM_CHILDACTIVATE
35 constant WM_QUEUESYNC
36 constant WM_GETMINMAXINFO
38 constant WM_PAINTICON
39 constant WM_ICONERASEBKGND
40 constant WM_NEXTDLGCTL
42 constant WM_SPOOLERSTATUS
43 constant WM_DRAWITEM
44 constant WM_MEASUREITEM
45 constant WM_DELETEITEM
46 constant WM_VKEYTOITEM
47 constant WM_CHARTOITEM
48 constant WM_SETFONT
49 constant WM_GETFONT
50 constant WM_SETHOTKEY
51 constant WM_GETHOTKEY
55 constant WM_QUERYDRAGICON
57 constant WM_COMPAREITEM
61 constant WM_GETOBJECT
65 constant WM_COMPACTING
68 constant WM_COMMNOTIFY
70 constant WM_WINDOWPOSCHANGING
71 constant WM_WINDOWPOSCHANGED
72 constant WM_POWER
73 constant WM_COPYGLOBALDATA
74 constant WM_COPYDATA
75 constant WM_CANCELJOURNAL
78 constant WM_NOTIFY
80 constant WM_INPUTLANGCHANGEREQUEST
81 constant WM_INPUTLANGCHANGE
82 constant WM_TCARD
83 constant WM_HELP
84 constant WM_USERCHANGED
85 constant WM_NOTIFYFORMAT
123 constant WM_CONTEXTMENU
124 constant WM_STYLECHANGING
125 constant WM_STYLECHANGED
126 constant WM_DISPLAYCHANGE
127 constant WM_GETICON
128 constant WM_SETICON
129 constant WM_NCCREATE
130 constant WM_NCDESTROY
131 constant WM_NCCALCSIZE
132 constant WM_NCHITTEST
133 constant WM_NCPAINT
134 constant WM_NCACTIVATE
135 constant WM_GETDLGCODE
136 constant WM_SYNCPAINT
160 constant WM_NCMOUSEMOVE
161 constant WM_NCLBUTTONDOWN
162 constant WM_NCLBUTTONUP
163 constant WM_NCLBUTTONDBLCLK
164 constant WM_NCRBUTTONDOWN
165 constant WM_NCRBUTTONUP
166 constant WM_NCRBUTTONDBLCLK
167 constant WM_NCMBUTTONDOWN
168 constant WM_NCMBUTTONUP
169 constant WM_NCMBUTTONDBLCLK
171 constant WM_NCXBUTTONDOWN
172 constant WM_NCXBUTTONUP
173 constant WM_NCXBUTTONDBLCLK
176 constant EM_GETSEL
177 constant EM_SETSEL
178 constant EM_GETRECT
179 constant EM_SETRECT
180 constant EM_SETRECTNP
181 constant EM_SCROLL
182 constant EM_LINESCROLL
183 constant EM_SCROLLCARET
185 constant EM_GETMODIFY
187 constant EM_SETMODIFY
188 constant EM_GETLINECOUNT
189 constant EM_LINEINDEX
190 constant EM_SETHANDLE
191 constant EM_GETHANDLE
192 constant EM_GETTHUMB
193 constant EM_LINELENGTH
194 constant EM_REPLACESEL
195 constant EM_SETFONT
196 constant EM_GETLINE
197 constant EM_LIMITTEXT
197 constant EM_SETLIMITTEXT
198 constant EM_CANUNDO
199 constant EM_UNDO
200 constant EM_FMTLINES
201 constant EM_LINEFROMCHAR
202 constant EM_SETWORDBREAK
203 constant EM_SETTABSTOPS
204 constant EM_SETPASSWORDCHAR
205 constant EM_EMPTYUNDOBUFFER
206 constant EM_GETFIRSTVISIBLELINE
207 constant EM_SETREADONLY
209 constant EM_SETWORDBREAKPROC
209 constant EM_GETWORDBREAKPROC
210 constant EM_GETPASSWORDCHAR
211 constant EM_SETMARGINS
212 constant EM_GETMARGINS
213 constant EM_GETLIMITTEXT
214 constant EM_POSFROMCHAR
215 constant EM_CHARFROMPOS
216 constant EM_SETIMESTATUS
217 constant EM_GETIMESTATUS
224 constant SBM_SETPOS
225 constant SBM_GETPOS
226 constant SBM_SETRANGE
227 constant SBM_GETRANGE
228 constant SBM_ENABLE_ARROWS
230 constant SBM_SETRANGEREDRAW
233 constant SBM_SETSCROLLINFO
234 constant SBM_GETSCROLLINFO
235 constant SBM_GETSCROLLBARINFO
240 constant BM_GETCHECK
241 constant BM_SETCHECK
242 constant BM_GETSTATE
243 constant BM_SETSTATE
244 constant BM_SETSTYLE
245 constant BM_CLICK
246 constant BM_GETIMAGE
247 constant BM_SETIMAGE
248 constant BM_SETDONTCLICK
255 constant WM_INPUT
256 constant WM_KEYDOWN
256 constant WM_KEYFIRST
257 constant WM_KEYUP
258 constant WM_CHAR
259 constant WM_DEADCHAR
260 constant WM_SYSKEYDOWN
261 constant WM_SYSKEYUP
262 constant WM_SYSCHAR
263 constant WM_SYSDEADCHAR
265 constant WM_UNICHAR
265 constant WM_WNT_CONVERTREQUESTEX
266 constant WM_CONVERTREQUEST
267 constant WM_CONVERTRESULT
268 constant WM_INTERIM
269 constant WM_IME_STARTCOMPOSITION
270 constant WM_IME_ENDCOMPOSITION
271 constant WM_IME_COMPOSITION
271 constant WM_IME_KEYLAST
272 constant WM_INITDIALOG
273 constant WM_COMMAND
274 constant WM_SYSCOMMAND
275 constant WM_TIMER
276 constant WM_HSCROLL
277 constant WM_VSCROLL
278 constant WM_INITMENU
279 constant WM_INITMENUPOPUP
280 constant WM_SYSTIMER
287 constant WM_MENUSELECT
288 constant WM_MENUCHAR
289 constant WM_ENTERIDLE
290 constant WM_MENURBUTTONUP
291 constant WM_MENUDRAG
292 constant WM_MENUGETOBJECT
293 constant WM_UNINITMENUPOPUP
294 constant WM_MENUCOMMAND
295 constant WM_CHANGEUISTATE
296 constant WM_UPDATEUISTATE
297 constant WM_QUERYUISTATE
305 constant WM_LBTRACKPOINT
306 constant WM_CTLCOLORMSGBOX
307 constant WM_CTLCOLOREDIT
308 constant WM_CTLCOLORLISTBOX
309 constant WM_CTLCOLORBTN
310 constant WM_CTLCOLORDLG
311 constant WM_CTLCOLORSCROLLBAR
312 constant WM_CTLCOLORSTATIC
320 constant CB_GETEDITSEL
321 constant CB_LIMITTEXT
322 constant CB_SETEDITSEL
323 constant CB_ADDSTRING
324 constant CB_DELETESTRING
325 constant CB_DIR
326 constant CB_GETCOUNT
327 constant CB_GETCURSEL
328 constant CB_GETLBTEXT
329 constant CB_GETLBTEXTLEN
330 constant CB_INSERTSTRING
331 constant CB_RESETCONTENT
332 constant CB_FINDSTRING
333 constant CB_SELECTSTRING
334 constant CB_SETCURSEL
335 constant CB_SHOWDROPDOWN
336 constant CB_GETITEMDATA
337 constant CB_SETITEMDATA
338 constant CB_GETDROPPEDCONTROLRECT
339 constant CB_SETITEMHEIGHT
340 constant CB_GETITEMHEIGHT
341 constant CB_SETEXTENDEDUI
342 constant CB_GETEXTENDEDUI
343 constant CB_GETDROPPEDSTATE
344 constant CB_FINDSTRINGEXACT
345 constant CB_SETLOCALE
346 constant CB_GETLOCALE
347 constant CB_GETTOPINDEX
348 constant CB_SETTOPINDEX
349 constant CB_GETHORIZONTALEXTENT
350 constant CB_SETHORIZONTALEXTENT
351 constant CB_GETDROPPEDWIDTH
352 constant CB_SETDROPPEDWIDTH
353 constant CB_INITSTORAGE
355 constant CB_MULTIPLEADDSTRING
356 constant CB_GETCOMBOBOXINFO
357 constant CB_MSGMAX
512 constant WM_MOUSEFIRST
512 constant WM_MOUSEMOVE
513 constant WM_LBUTTONDOWN
514 constant WM_LBUTTONUP
515 constant WM_LBUTTONDBLCLK
516 constant WM_RBUTTONDOWN
517 constant WM_RBUTTONUP
518 constant WM_RBUTTONDBLCLK
519 constant WM_MBUTTONDOWN
520 constant WM_MBUTTONUP
521 constant WM_MBUTTONDBLCLK
521 constant WM_MOUSELAST
522 constant WM_MOUSEWHEEL
523 constant WM_XBUTTONDOWN
524 constant WM_XBUTTONUP
525 constant WM_XBUTTONDBLCLK
526 constant WM_MOUSEHWHEEL
528 constant WM_PARENTNOTIFY
529 constant WM_ENTERMENULOOP
530 constant WM_EXITMENULOOP
531 constant WM_NEXTMENU
532 constant WM_SIZING
533 constant WM_CAPTURECHANGED
534 constant WM_MOVING
536 constant WM_POWERBROADCAST
537 constant WM_DEVICECHANGE
544 constant WM_MDICREATE
545 constant WM_MDIDESTROY
546 constant WM_MDIACTIVATE
547 constant WM_MDIRESTORE
548 constant WM_MDINEXT
549 constant WM_MDIMAXIMIZE
550 constant WM_MDITILE
551 constant WM_MDICASCADE
552 constant WM_MDIICONARRANGE
553 constant WM_MDIGETACTIVE
560 constant WM_MDISETMENU
561 constant WM_ENTERSIZEMOVE
562 constant WM_EXITSIZEMOVE
563 constant WM_DROPFILES
564 constant WM_MDIREFRESHMENU
640 constant WM_IME_REPORT
641 constant WM_IME_SETCONTEXT
642 constant WM_IME_NOTIFY
643 constant WM_IME_CONTROL
644 constant WM_IME_COMPOSITIONFULL
645 constant WM_IME_SELECT
646 constant WM_IME_CHAR
648 constant WM_IME_REQUEST
656 constant WM_IMEKEYDOWN
656 constant WM_IME_KEYDOWN
657 constant WM_IMEKEYUP
657 constant WM_IME_KEYUP
672 constant WM_NCMOUSEHOVER
673 constant WM_MOUSEHOVER
674 constant WM_NCMOUSELEAVE
675 constant WM_MOUSELEAVE
768 constant WM_CUT
769 constant WM_COPY
770 constant WM_PASTE
771 constant WM_CLEAR
772 constant WM_UNDO
773 constant WM_RENDERFORMAT
774 constant WM_RENDERALLFORMATS
775 constant WM_DESTROYCLIPBOARD
776 constant WM_DRAWCLIPBOARD
777 constant WM_PAINTCLIPBOARD
778 constant WM_VSCROLLCLIPBOARD
779 constant WM_SIZECLIPBOARD
780 constant WM_ASKCBFORMATNAME
781 constant WM_CHANGECBCHAIN
782 constant WM_HSCROLLCLIPBOARD
783 constant WM_QUERYNEWPALETTE
784 constant WM_PALETTEISCHANGING
785 constant WM_PALETTECHANGED
786 constant WM_HOTKEY
791 constant WM_PRINT
792 constant WM_PRINTCLIENT
793 constant WM_APPCOMMAND
856 constant WM_HANDHELDFIRST
863 constant WM_HANDHELDLAST
864 constant WM_AFXFIRST
895 constant WM_AFXLAST
896 constant WM_PENWINFIRST
897 constant WM_RCRESULT
898 constant WM_HOOKRCRESULT
899 constant WM_GLOBALRCCHANGE
899 constant WM_PENMISCINFO
900 constant WM_SKB
901 constant WM_HEDITCTL
901 constant WM_PENCTL
902 constant WM_PENMISC
903 constant WM_CTLINIT
904 constant WM_PENEVENT
911 constant WM_PENWINLAST
: WM_>name ( msg -- a n )
['] WM_PENWINLAST begin dup ['] WM_NULL <> while
2dup >body @ = if nip >name exit then
>link
repeat
nip >name ;
forth definitions

68
ueforth/windows/windows_test.fs Normal file
View File

@ -0,0 +1,68 @@
\ 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.
also windows also internals
z" MyClass" constant MyClassName
z" Test Window" constant MyWindowTitle
pad WINDCLASSA erase
WindowProcShim pad ->lpfnWndProc !
DefaultInstance pad ->hInstance !
MyClassName pad ->lpszClassName !
pad RegisterClassA constant myclass
create ps PAINTSTRUCT allot
255 192 0 RGB CreateSolidBrush constant orange
0 255 0 RGB CreateSolidBrush constant green
create side RECT allot
0 side ->left !
0 side ->top !
200 side ->right !
100 side ->bottom !
: foo { hwnd msg w l }
WM_DESTROY msg = if
0 PostQuitMessage
0 exit
then
WM_PAINT msg = if
hwnd ps BeginPaint drop
ps ->hdc @ ps ->rcPaint orange FillRect drop
ps ->hdc @ side green FillRect drop
hwnd ps EndPaint drop
0 exit
then
hwnd msg w l DefWindowProcA
;
create bar ' foo , ' yield ,
0 myclass MyWindowTitle WS_OVERLAPPEDWINDOW
CW_USEDEFAULT CW_USEDEFAULT 640 480
NULL NULL DefaultInstance bar CreateWindowExA constant hwnd
hwnd SW_SHOWDEFAULT ShowWindow drop
hwnd SetForegroundWindow drop
create mymsg msg allot
: pump
begin mymsg NULL 0 0 GetMessageA while
mymsg TranslateMessage drop
mymsg DispatchMessageA drop
repeat
;
pump
bye

129
ueforth/windows/windows_user.fs Normal file
View File

@ -0,0 +1,129 @@
\ 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.
windows definitions
also structures
z" User32.dll" dll User32
z" MessageBoxA" 4 User32 MessageBoxA
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
z" RegisterClassA" 1 User32 RegisterClassA
struct WINDCLASSA
i16 field ->style
ptr field ->lpfnWndProc
i32 field ->cbClsExtra
i32 field ->cbWndExtra
ptr field ->hInstance
ptr field ->hIcon
ptr field ->hCursor
ptr field ->hbrBackground
ptr field ->lpszMenuName
ptr field ->lpszClassName
z" ShowWindow" 2 User32 ShowWindow
0 constant SW_HIDE
1 constant SW_NORMAL
2 constant SW_SHOWMINIMIZED
3 constant SW_MAXIMIZED
4 constant SW_SHOWNOACTIVATE
5 constant SW_SHOW
6 constant SW_MINIMIZE
7 constant SW_SHWOMINNOACTIVE
8 constant SW_SHOWNA
9 constant SW_RESTORE
10 constant SW_SHOWDEFAULT
11 constant SW_FORCEMINIMIZE
SW_NORMAL constant SW_SHOWNORMAL
SW_MAXIMIZED constant SW_SHOWMAXIMIZED
z" SetForegroundWindow" 1 User32 SetForegroundWindow
z" DefWindowProcA" 4 User32 DefWindowProcA
z" CreateWindowExA" 12 User32 CreateWindowExA
$00000000 constant WS_OVERLAPPED
$00010000 constant WS_MAXIMIZEBOX
$00020000 constant WS_MINIMIZEBOX
$00040000 constant WS_THICKFRAME
$00080000 constant WS_SYSMENU
$00100000 constant WS_HSCROLL
$00200000 constant WS_VSCROLL
$00400000 constant WS_DLGFRAME
$00800000 constant WS_BORDER
$01000000 constant WS_MAXIMIZE
$02000000 constant WS_CLIPCHILDREN
$04000000 constant WS_CLIPSIBLINGS
$08000000 constant WS_DISABLED
$10000000 constant WS_VISIBLE
$20000000 constant WS_MINIMIZE
$40000000 constant WS_CHILD
$80000000 constant WS_POPUP
WS_MAXIMIZEBOX constant WS_TABSTOP ( With dialog boxes )
WS_MINIMIZEBOX constant WS_GROUP ( With dialog boxes )
WS_CHILD constant WS_CHILDWINDOW
WS_MINIMIZE constant WS_ICONIC
WS_OVERLAPPED constant WS_TILED
WS_DLGFRAME WS_BORDER or constant WS_CAPTION
WS_OVERLAPPED WS_CAPTION or WS_SYSMENU or
WS_THICKFRAME or WS_MINIMIZEBOX or WS_MAXIMIZEBOX or constant WS_OVERLAPPEDWINDOW
WS_POPUP WS_BORDER or WS_SYSMENU or constant WS_POPUPWINDOW
WS_OVERLAPPEDWINDOW constant WS_TILEDWINDOW
( General use )
$400000 constant DefaultInstance
$80000000 constant CW_USEDEFAULT
struct POINT
i32 field ->x
i32 field ->y
struct RECT
i32 field ->left
i32 field ->top
i32 field ->right
i32 field ->bottom
z" GetMessageA" 4 User32 GetMessageA
z" TranslateMessage" 1 User32 TranslateMessage
z" DispatchMessageA" 1 User32 DispatchMessageA
struct MSG
ptr field ->hwnd
i32 field ->message
i16 field ->wParam
i32 field ->lParam
i32 field ->time
POINT field ->pt
i32 field ->lPrivate
z" BeginPaint" 2 User32 BeginPaint
z" EndPaint" 2 User32 EndPaint
struct PAINTSTRUCT
ptr field ->hdc
i32 field ->fErase
RECT field ->rcPaint
i32 field ->fRestore
i32 field ->fIncUpdate
32 field ->rgbReserved
z" FillRect" 3 User32 FillRect
z" PostQuitMessage" 1 User32 PostQuitMessage
only forth definitions