Added field accessors.

common/structures.fs

@@ -17,18 +17,27 @@
 vocabulary structures   structures definitions
 
 variable last-align
-: typer ( sz "name" ) create dup , 1 max cell min ,
+variable last-typer
-                      does> dup cell+ @ last-align ! @ ;
+: typer ( xt@ xt! sz "name" -- )
-1 typer i8
+   create dup , 1 max cell min , , ,
-2 typer i16
+   does> dup last-typer !  dup cell+ @ last-align !  @ ;
-4 typer i32
+: sc@ ( a -- c ) c@ dup 127 > if 256 - then ;
-8 typer i64
+' sc@ ' c! 1 typer i8
-cell typer ptr
+' c@  ' c! 1 typer u8
-long-size typer long
+' 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 0 0 typer latestxt >body last-struct !
-: struct ( "name" ) 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

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

posix/graphics.fs

@@ -57,8 +57,8 @@ StructureNotifyMask or constant EVENT-MASK
 
 : update-mouse
   [ xbutton ]
-  xevent ->x sl@ to mouse-x
+  xevent @field ->x to mouse-x
-  xevent ->y sl@ to mouse-y
+  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

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!
+  BITMAPINFOHEADER binfo ->bmiHeader !field ->biSize
-  w binfo ->bmiHeader ->biWidth l!
+  w binfo ->bmiHeader !field ->biWidth
-  h negate binfo ->bmiHeader ->biHeight l!
+  h negate binfo ->bmiHeader !field ->biHeight
-  1 binfo ->bmiHeader ->biPlanes w!
+  1 binfo ->bmiHeader !field ->biPlanes
-  32 binfo ->bmiHeader ->biBitCount w!
+  32 binfo ->bmiHeader !field ->biBitCount
-  BI_RGB binfo ->bmiHeader ->biCompression l!
+  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 !
+    WindowProcShim pad !field ->lpfnWndProc
-    hinstance pad ->hInstance !
+    hinstance pad !field ->hInstance
-    GrfClassName pad ->lpszClassName !
+    GrfClassName pad !field ->lpszClassName
-    NULL IDC_ARROW LoadCursorA pad ->hCursor !
+    NULL IDC_ARROW LoadCursorA pad !field ->hCursor
-    hinstance IDI_MAIN_ICON LoadIconA pad ->hIcon !
+    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

windows/windows_gdi.fs

@@ -46,10 +46,10 @@ $80000013 constant DC_PEN
 
 z" StretchDIBits" 13 Gdi32 StretchDIBits
 struct RGBQUAD
-  i8 field ->rgbBlue
+  u8 field ->rgbBlue
-  i8 field ->rgbGreen
+  u8 field ->rgbGreen
-  i8 field ->rgbRed
+  u8 field ->rgbRed
-  i8 field ->rgbReserved
+  u8 field ->rgbReserved
 struct BITMAPINFOHEADER
   i16 field ->biSize
   i32 field ->biWidth

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 !
+  WindowProcShim pad !field ->lpfnWndProc
-  hinst pad ->hInstance !
+  hinst pad !field ->hInstance
-  MyClassName pad ->lpszClassName !
+  MyClassName pad !field ->lpszClassName
-  NULL IDC_ARROW LoadCursorA pad ->hCursor !
+  NULL IDC_ARROW LoadCursorA pad !field ->hCursor
-  hinst IDI_MAIN_ICON LoadIconA pad ->hIcon !
+  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 @field ->hdc ps ->rcPaint orange FillRect drop
-    ps ->hdc @ side green 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

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