diff --git a/ueforth/common/grf_test.fs b/ueforth/common/grf_test.fs new file mode 100644 index 0000000..abeb8ea --- /dev/null +++ b/ueforth/common/grf_test.fs @@ -0,0 +1,19 @@ +\ 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. + +grf + +640 480 window +wait +bye diff --git a/ueforth/windows/grf.fs b/ueforth/windows/grf.fs index 7c0c2e5..7e59276 100644 --- a/ueforth/windows/grf.fs +++ b/ueforth/windows/grf.fs @@ -16,5 +16,70 @@ ( Expand Graphics for Windows ) grf internals definitions +also windows -forth definitions +z" GrfClass" constant GrfClassName +z" uEforth" constant GrfWindowTitle + +0 value hinstance +0 value GrfClass +0 value hwnd +create ps PAINTSTRUCT allot +create msgbuf MSG 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 ! + + +: GrfWindowProc { 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 +; + +grf definitions +also internals +also windows + +: window { width height } + NULL GetModuleHandleA to hinstance + + pad WINDCLASSA erase + WindowProcShim pad ->lpfnWndProc ! + hinstance pad ->hInstance ! + GrfClassName pad ->lpszClassName ! + NULL IDC_ARROW LoadCursorA pad ->hCursor ! + hinstance IDI_MAIN_ICON LoadIconA pad ->hIcon ! + pad RegisterClassA to GrfClass + + 0 GrfClass GrfWindowTitle WS_OVERLAPPEDWINDOW + CW_USEDEFAULT CW_USEDEFAULT width height + NULL NULL hinstance ['] GrfWindowProc callback + CreateWindowExA to hwnd + + hwnd SW_SHOWMAXIMIZED ShowWindow drop + hwnd SetForegroundWindow drop +; + +: wait + begin msgbuf NULL 0 0 GetMessageA while + msgbuf TranslateMessage drop + msgbuf DispatchMessageA drop + repeat +; + +only forth definitions diff --git a/ueforth/windows/windows_test.fs b/ueforth/windows/windows_test.fs index 16ceecd..ad5060e 100644 --- a/ueforth/windows/windows_test.fs +++ b/ueforth/windows/windows_test.fs @@ -38,7 +38,7 @@ create side RECT allot 200 side ->right ! 100 side ->bottom ! -: foo { hwnd msg w l } +: MyWindowProc { hwnd msg w l } WM_DESTROY msg = if 0 PostQuitMessage 0 exit @@ -52,11 +52,11 @@ create side RECT allot then hwnd msg w l DefWindowProcA ; -create bar ' foo , ' yield , 0 myclass MyWindowTitle WS_OVERLAPPEDWINDOW -CW_USEDEFAULT CW_USEDEFAULT 640 480 -NULL NULL hinst bar CreateWindowExA constant hwnd + CW_USEDEFAULT CW_USEDEFAULT 640 480 + NULL NULL hinst ' MyWindowProc callback + CreateWindowExA constant hwnd hwnd SW_SHOWMAXIMIZED ShowWindow drop hwnd SetForegroundWindow drop diff --git a/ueforth/windows/windows_user.fs b/ueforth/windows/windows_user.fs index 5d36a3e..dcf6607 100644 --- a/ueforth/windows/windows_user.fs +++ b/ueforth/windows/windows_user.fs @@ -14,6 +14,7 @@ windows definitions also structures +also internals z" User32.dll" dll User32 @@ -58,6 +59,8 @@ SW_MAXIMIZED constant SW_SHOWMAXIMIZED z" SetForegroundWindow" 1 User32 SetForegroundWindow z" DefWindowProcA" 4 User32 DefWindowProcA +: callback ( xt -- ) here >r , ['] yield , r> ; + z" CreateWindowExA" 12 User32 CreateWindowExA $00000000 constant WS_OVERLAPPED $00010000 constant WS_MAXIMIZEBOX