diff --git a/ueforth/Makefile b/ueforth/Makefile index c73f909..d6a8f2e 100644 --- a/ueforth/Makefile +++ b/ueforth/Makefile @@ -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 diff --git a/ueforth/common/all_tests.fs b/ueforth/common/all_tests.fs index 60bda2f..c66e9b0 100644 --- a/ueforth/common/all_tests.fs +++ b/ueforth/common/all_tests.fs @@ -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 diff --git a/ueforth/common/calling.h b/ueforth/common/calling.h index 1b0c530..bb283e3 100644 --- a/ueforth/common/calling.h +++ b/ueforth/common/calling.h @@ -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) diff --git a/ueforth/common/calls.h b/ueforth/common/calls.h index ea9b029..16b7dae 100644 --- a/ueforth/common/calls.h +++ b/ueforth/common/calls.h @@ -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) diff --git a/ueforth/common/forth_namespace_tests.fs b/ueforth/common/forth_namespace_tests.fs index cfe7bba..14af07f 100644 --- a/ueforth/common/forth_namespace_tests.fs +++ b/ueforth/common/forth_namespace_tests.fs @@ -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 diff --git a/ueforth/common/locals.fs b/ueforth/common/locals.fs index ef33490..f3ba26b 100644 --- a/ueforth/common/locals.fs +++ b/ueforth/common/locals.fs @@ -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 diff --git a/ueforth/common/structures.fs b/ueforth/common/structures.fs new file mode 100644 index 0000000..9c907db --- /dev/null +++ b/ueforth/common/structures.fs @@ -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 diff --git a/ueforth/common/structures_tests.fs b/ueforth/common/structures_tests.fs new file mode 100644 index 0000000..07c18e7 --- /dev/null +++ b/ueforth/common/structures_tests.fs @@ -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 diff --git a/ueforth/esp32/bindings.fs b/ueforth/esp32/bindings.fs index a726907..5d6339d 100644 --- a/ueforth/esp32/bindings.fs +++ b/ueforth/esp32/bindings.fs @@ -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 -( 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 ; + +also structures +struct esp_partition_t + ( Work around changing struct layout ) + 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 diff --git a/ueforth/esp32/sim_main.cpp b/ueforth/esp32/sim_main.cpp index 099e9c0..1924f3c 100644 --- a/ueforth/esp32/sim_main.cpp +++ b/ueforth/esp32/sim_main.cpp @@ -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); diff --git a/ueforth/windows/main.c b/ueforth/windows/main.c index e995420..9c7bf4e 100644 --- a/ueforth/windows/main.c +++ b/ueforth/windows/main.c @@ -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 diff --git a/ueforth/windows/windows.fs b/ueforth/windows/windows.fs deleted file mode 100644 index 8e3231d..0000000 --- a/ueforth/windows/windows.fs +++ /dev/null @@ -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 ; -: d0r s>z r> FILE_SHARE_READ FILE_SHARE_WRITE or NULL - OPEN_EXISTING FILE_ATTRIBUTE_NORMAL NULL CreateFileA d0r s>z r> FILE_SHARE_READ FILE_SHARE_WRITE or NULL - CREATE_ALWAYS FILE_ATTRIBUTE_NORMAL NULL CreateFileA d0z 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 diff --git a/ueforth/windows/windows_console.fs b/ueforth/windows/windows_console.fs new file mode 100644 index 0000000..09ae682 --- /dev/null +++ b/ueforth/windows/windows_console.fs @@ -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 diff --git a/ueforth/windows/windows_core.fs b/ueforth/windows/windows_core.fs new file mode 100644 index 0000000..426d719 --- /dev/null +++ b/ueforth/windows/windows_core.fs @@ -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 diff --git a/ueforth/windows/windows_files.fs b/ueforth/windows/windows_files.fs new file mode 100644 index 0000000..225e007 --- /dev/null +++ b/ueforth/windows/windows_files.fs @@ -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 ; +: d0r s>z r> FILE_SHARE_READ FILE_SHARE_WRITE or NULL + OPEN_EXISTING FILE_ATTRIBUTE_NORMAL NULL CreateFileA d0r s>z r> FILE_SHARE_READ FILE_SHARE_WRITE or NULL + CREATE_ALWAYS FILE_ATTRIBUTE_NORMAL NULL CreateFileA d0z 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 diff --git a/ueforth/windows/windows_gdi.fs b/ueforth/windows/windows_gdi.fs new file mode 100644 index 0000000..d5c7a50 --- /dev/null +++ b/ueforth/windows/windows_gdi.fs @@ -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 diff --git a/ueforth/windows/windows_messages.fs b/ueforth/windows/windows_messages.fs new file mode 100644 index 0000000..2ca8000 --- /dev/null +++ b/ueforth/windows/windows_messages.fs @@ -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 diff --git a/ueforth/windows/windows_test.fs b/ueforth/windows/windows_test.fs new file mode 100644 index 0000000..9bec876 --- /dev/null +++ b/ueforth/windows/windows_test.fs @@ -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 diff --git a/ueforth/windows/windows_user.fs b/ueforth/windows/windows_user.fs new file mode 100644 index 0000000..4f19606 --- /dev/null +++ b/ueforth/windows/windows_user.fs @@ -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