diff --git a/common/structures.fs b/common/structures.fs index 5d2093e..6fa886a 100644 --- a/common/structures.fs +++ b/common/structures.fs @@ -17,18 +17,27 @@ vocabulary structures structures definitions variable last-align -: typer ( sz "name" ) create dup , 1 max cell min , - does> dup cell+ @ last-align ! @ ; -1 typer i8 -2 typer i16 -4 typer i32 -8 typer i64 -cell typer ptr -long-size typer long +variable last-typer +: typer ( xt@ xt! sz "name" -- ) + create dup , 1 max cell min , , , + does> dup last-typer ! dup cell+ @ last-align ! @ ; +: sc@ ( a -- c ) c@ dup 127 > if 256 - then ; +' sc@ ' c! 1 typer i8 +' c@ ' c! 1 typer u8 +' sw@ ' w! 2 typer i16 +' uw@ ' w! 2 typer u16 +' sl@ ' l! 4 typer i32 +' ul@ ' l! 4 typer u32 +' @ ' ! 8 typer i64 ( Wrong on 32-bit! ) +' @ ' ! cell typer ptr +long-size cell = [IF] + : long ptr ; +[ELSE] + : long i32 ; +[THEN] variable last-struct - -: struct ( "name" ) 0 typer latestxt >body last-struct ! +: struct ( "name" ) 0 0 0 typer latestxt >body last-struct ! 1 last-align ! ; : align-by ( a n -- a ) 1- dup >r + r> invert and ; : max! ( n a -- ) swap over @ max swap ! ; @@ -37,7 +46,13 @@ variable last-struct last-struct @ @ swap align-by last-struct @ ! ; : field ( n "name" ) last-align @ struct-align - create last-struct @ @ , last-struct @ +! + create last-struct @ @ , last-struct @ +! last-typer @ , does> @ + ; +: field-op ( n "name" -- ) + >r ' dup >body cell+ @ r> cells + @ + state @ if >r , r> , else >r execute r> execute then ; +: !field ( n "name" -- ) 2 field-op ; immediate +: @field ( "name" -- n ) 3 field-op ; immediate + forth definitions diff --git a/common/structures_tests.fs b/common/structures_tests.fs index c585dc2..9fea1fc 100644 --- a/common/structures_tests.fs +++ b/common/structures_tests.fs @@ -60,3 +60,48 @@ e: test-forth-structure 0 t3 5 =assert 0 t4 14 =assert ;e + +e: test-structure-accessors + also structures + struct foo + i8 field ->a + u8 field ->b + i16 field ->c + u16 field ->d + i32 field ->e + u32 field ->f + ptr field ->g + pad foo erase + + 127 pad !field ->a + 255 pad !field ->b + 32767 pad !field ->c + 65535 pad !field ->d + 2147483647 pad !field ->e + 4294967295 pad !field ->f + 1234 pad !field ->g + + 127 pad @field ->a =assert + 255 pad @field ->b =assert + 32767 pad @field ->c =assert + 65535 pad @field ->d =assert + 2147483647 pad @field ->e =assert + 4294967295 pad @field ->f =assert + 1234 pad @field ->g =assert + + -128 pad !field ->a + 0 pad !field ->b + -32768 pad !field ->c + 0 pad !field ->d + -2147483648 pad !field ->e + 0 pad !field ->f + 1234 pad !field ->g + + -128 pad @field ->a =assert + 0 pad @field ->b =assert + -32768 pad @field ->c =assert + 0 pad @field ->d =assert + -2147483648 pad @field ->e =assert + 0 pad @field ->f =assert + 1234 pad @field ->g =assert +;e diff --git a/posix/graphics.fs b/posix/graphics.fs index 133de40..16cbb08 100644 --- a/posix/graphics.fs +++ b/posix/graphics.fs @@ -57,8 +57,8 @@ StructureNotifyMask or constant EVENT-MASK : update-mouse [ xbutton ] - xevent ->x sl@ to mouse-x - xevent ->y sl@ to mouse-y + xevent @field ->x to mouse-x + xevent @field ->y to mouse-y ; : update-key @@ -80,10 +80,10 @@ StructureNotifyMask or constant EVENT-MASK : update-event IDLE to event - xevent [ xany ] ->type sl@ to xevent-type + xevent [ xany ] @field ->type to xevent-type Expose xevent-type = if [ xexposure ] - xevent ->count sl@ 0= if + xevent @field ->count 0= if EXPOSED to event exit then @@ -91,7 +91,7 @@ StructureNotifyMask or constant EVENT-MASK ConfigureNotify xevent-type = if RESIZED to event [ xconfigure ] - xevent ->width sl@ xevent ->height sl@ image-resize + xevent @field ->width xevent @field ->height image-resize exit then KeyPress xevent-type = if @@ -110,7 +110,7 @@ StructureNotifyMask or constant EVENT-MASK PRESSED to event update-mouse ( uses carnal knowledge ) - [ xbutton ] 256 xevent ->button sl@ - to last-key + [ xbutton ] 256 xevent @field ->button - to last-key 1 last-key key-state! exit then @@ -118,7 +118,7 @@ StructureNotifyMask or constant EVENT-MASK RELEASED to event update-mouse ( uses carnal knowledge ) - [ xbutton ] 256 xevent ->button sl@ - to last-key + [ xbutton ] 256 xevent @field ->button - to last-key 0 last-key key-state! exit then diff --git a/windows/graphics.fs b/windows/graphics.fs index 3865de3..7e6f8d9 100644 --- a/windows/graphics.fs +++ b/windows/graphics.fs @@ -15,7 +15,7 @@ ( Expand Graphics for Windows ) graphics internals definitions -also windows +also windows also structures z" GrfClass" constant GrfClassName z" uEforth" constant GrfWindowTitle @@ -35,12 +35,12 @@ cell allocate throw to backbuffer backbuffer w h * 4* resize throw to backbuffer backbuffer w h * 4* 255 fill binfo BITMAPINFO erase - BITMAPINFOHEADER binfo ->bmiHeader ->biSize l! - w binfo ->bmiHeader ->biWidth l! - h negate binfo ->bmiHeader ->biHeight l! - 1 binfo ->bmiHeader ->biPlanes w! - 32 binfo ->bmiHeader ->biBitCount w! - BI_RGB binfo ->bmiHeader ->biCompression l! + BITMAPINFOHEADER binfo ->bmiHeader !field ->biSize + w binfo ->bmiHeader !field ->biWidth + h negate binfo ->bmiHeader !field ->biHeight + 1 binfo ->bmiHeader !field ->biPlanes + 32 binfo ->bmiHeader !field ->biBitCount + BI_RGB binfo ->bmiHeader !field ->biCompression RESIZED to event ; @@ -119,6 +119,7 @@ cell allocate throw to backbuffer graphics definitions also internals also windows +also structures : window { width height } width 0< { fullscreen } @@ -128,11 +129,11 @@ also windows 1 1 rescale 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 ! + WindowProcShim pad !field ->lpfnWndProc + hinstance pad !field ->hInstance + GrfClassName pad !field ->lpszClassName + NULL IDC_ARROW LoadCursorA pad !field ->hCursor + hinstance IDI_MAIN_ICON LoadIconA pad !field ->hIcon pad RegisterClassA to GrfClass 0 GrfClass GrfWindowTitle WS_OVERLAPPEDWINDOW @@ -161,7 +162,7 @@ also windows event FINISHED = if exit then IDLE to event msgbuf NULL 0 0 PM_REMOVE PeekMessageA if - WM_QUIT msgbuf ->message ul@ = if + WM_QUIT msgbuf @field ->message = if FINISHED to event exit then diff --git a/windows/windows_gdi.fs b/windows/windows_gdi.fs index d20edf8..921f057 100644 --- a/windows/windows_gdi.fs +++ b/windows/windows_gdi.fs @@ -46,10 +46,10 @@ $80000013 constant DC_PEN z" StretchDIBits" 13 Gdi32 StretchDIBits struct RGBQUAD - i8 field ->rgbBlue - i8 field ->rgbGreen - i8 field ->rgbRed - i8 field ->rgbReserved + u8 field ->rgbBlue + u8 field ->rgbGreen + u8 field ->rgbRed + u8 field ->rgbReserved struct BITMAPINFOHEADER i16 field ->biSize i32 field ->biWidth diff --git a/windows/windows_test.fs b/windows/windows_test.fs index c375696..80e0fae 100644 --- a/windows/windows_test.fs +++ b/windows/windows_test.fs @@ -12,7 +12,7 @@ \ See the License for the specific language governing permissions and \ limitations under the License. -also windows also internals +also windows also internals also structures z" MyClass" constant MyClassName z" Test Window" constant MyWindowTitle @@ -20,11 +20,11 @@ z" Test Window" constant MyWindowTitle NULL GetModuleHandleA constant hinst pad WINDCLASSA erase - WindowProcShim pad ->lpfnWndProc ! - hinst pad ->hInstance ! - MyClassName pad ->lpszClassName ! - NULL IDC_ARROW LoadCursorA pad ->hCursor ! - hinst IDI_MAIN_ICON LoadIconA pad ->hIcon ! + WindowProcShim pad !field ->lpfnWndProc + hinst pad !field ->hInstance + MyClassName pad !field ->lpszClassName + NULL IDC_ARROW LoadCursorA pad !field ->hCursor + hinst IDI_MAIN_ICON LoadIconA pad !field ->hIcon pad RegisterClassA constant myclass create ps PAINTSTRUCT allot @@ -42,8 +42,8 @@ side 0 0 200 100 SetRect then WM_PAINT msg = if hwnd ps BeginPaint drop - ps ->hdc @ ps ->rcPaint orange FillRect drop - ps ->hdc @ side green FillRect drop + ps @field ->hdc ps ->rcPaint orange FillRect drop + ps @field ->hdc side green FillRect drop hwnd ps EndPaint drop 0 exit then @@ -61,7 +61,7 @@ hwnd SetForegroundWindow drop create mymsg msg allot : pump begin mymsg NULL 0 0 GetMessageA while - \ mymsg ->message @ WM_>name type cr + \ mymsg @field ->message WM_>name type cr mymsg TranslateMessage drop mymsg DispatchMessageA drop repeat diff --git a/windows/windows_user.fs b/windows/windows_user.fs index be97305..e4780b0 100644 --- a/windows/windows_user.fs +++ b/windows/windows_user.fs @@ -134,7 +134,7 @@ struct PAINTSTRUCT RECT field ->rcPaint i32 field ->fRestore i32 field ->fIncUpdate - 32 i8 * field ->rgbReserved + 32 u8 * field ->rgbReserved z" FillRect" 3 User32 FillRect z" PostQuitMessage" 1 User32 PostQuitMessage