Progress towards grf for x11.

ueforth/common/boot.fs

@@ -14,6 +14,7 @@
 
 : (   41 parse drop drop ; immediate
 : \   10 parse drop drop ; immediate
+: #!   10 parse drop drop ; immediate  ( shebang for scripts )
 ( Now can do comments! )
 
 ( Constants and Variables )

ueforth/common/forth_namespace_tests.fs

@@ -137,6 +137,7 @@ e: check-boot
   out: sp0 
   out: variable 
   out: constant 
+  out: #! 
   out: \ 
   out: ( 
 ;e
@@ -229,7 +230,9 @@ e: check-core-opcodes
   out: DROP 
   out: @ 
   out: SL@ 
+  out: UL@ 
   out: SW@ 
+  out: UW@ 
   out: C@ 
   out: ! 
   out: L! 
@@ -537,7 +540,6 @@ e: test-posix-forth-namespace
   out: termios 
   check-allocation
   out: ok 
-  out: #! 
   out: ms-ticks 
   out: ms 
   check-files

ueforth/common/grf_test.fs

@@ -1,3 +1,4 @@
+#! /usr/bin/env ueforth
 \ Copyright 2022 Bradley D. Nelson
 \
 \ Licensed under the Apache License, Version 2.0 (the "License");

ueforth/common/opcodes.h

@@ -91,7 +91,9 @@ typedef struct {
   Y(DROP, DROP) \
   X("@", AT, tos = *(cell_t *) tos) \
   X("SL@", SLAT, tos = *(int32_t *) tos) \
+  X("UL@", ULAT, tos = *(uint32_t *) tos) \
   X("SW@", SWAT, tos = *(int16_t *) tos) \
+  X("UW@", UWAT, tos = *(uint16_t *) tos) \
   X("C@", CAT, tos = *(uint8_t *) tos) \
   X("!", STORE, *(cell_t *) tos = *sp--; DROP) \
   X("L!", LSTORE, *(int32_t *) tos = *sp--; DROP) \
@@ -111,6 +113,7 @@ typedef struct {
   YV(internals, DOLIT, DUP; tos = *ip++) \
   YV(internals, ALITERAL, COMMA(g_sys.DOLIT_XT); COMMA(tos); DROP) \
   Y(CELL, DUP; tos = sizeof(cell_t)) \
+  XV(internals, "LONG-SIZE", LONG_SIZE, DUP; tos = sizeof(long)) \
   Y(FIND, tos = find((const char *) *sp, tos); --sp) \
   Y(PARSE, DUP; tos = parse(tos, sp)) \
   XV(internals, "S>NUMBER?", \

ueforth/common/structures.fs

@@ -19,12 +19,15 @@ vocabulary structures   structures definitions
 variable last-align
 : typer ( align sz "name" ) create , ,
                             does> dup cell+ @ last-align ! @ ;
-   1    1 typer i8
+1 1 typer i8
-   2    2 typer i16
+2 2 typer i16
-   4    4 typer i32
+4 4 typer i32
-cell    8 typer i64
+cell 8 typer i64
 cell cell typer ptr
+long-size long-size typer long
+
 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 -- )

ueforth/posix/grf.fs

@@ -18,13 +18,112 @@ grf definitions
 
 : window r|
 
-forth grf internals definitions also x11
+also x11
+forth grf internals definitions
+also posix also x11
 
+0 value display
+0 value screen
+0 value colormap
+0 value visual
+0 value screen-depth
+0 value black
+0 value white
+0 value root-window
+0 value window-handle
+0 value gc
+0 value image
+0 value xevent-type
+create xevent xevent-size allot
 
-grf definitions also internals also x11
+ExposureMask
+ButtonPressMask or
+ButtonReleaseMask or
+KeyPressMask or
+KeyReleaseMask or
+PointerMotionMask or
+StructureNotifyMask or constant EVENT-MASK
 
+: image-resize { w h }
+  w to width   h to height
+  image if image XDestroyImage then
+  w h * 4* malloc dup 0= throw to backbuffer
+  display visual screen-depth ZPixmap 0 backbuffer
+    width height 32 width 4* XCreateImage to image
+;
 
-only forth definitions
+: update-event
+  xevent [ xany ] ->type sl@ to xevent-type
+  Expose xevent-type = if
+    EXPOSED to event
+    exit
+  then
+  ConfigureNotify xevent-type = if
+    RESIZED to event
+    [ xconfigure ]
+    xevent ->width sl@ xevent ->height sl@ image-resize
+    exit
+  then
+  KeyPress xevent-type = if
+    PRESSED to event
+    exit
+  then
+  KeyRelease xevent-type = if
+    RELEASED to event
+    exit
+  then
+  ButtonPress xevent-type = if
+    PRESSED to event
+    exit
+  then
+  ButtonRelease xevent-type = if
+    RELEASED to event
+    exit
+  then
+  MotionNotify xevent-type = if
+    MOTION to event
+    exit
+  then
+  UNKNOWN to event
+;
+
+also grf definitions
+
+: window { w h }
+  w 0< if 640 to w 480 to h then
+  NULL XOpenDisplay to display
+  display XDefaultScreen to screen
+  display screen XDefaultColorMap to colormap
+  display screen XDefaultVisual to visual
+  display screen XDefaultDepth to screen-depth
+  display screen XBlackPixel to black
+  display screen XWhitePixel to white
+  display screen XRootWindow to root-window
+  display root-window 0 0 w h 0 black white
+    XCreateSimpleWindow to window-handle
+  display window-handle XMapWindow drop
+  display window-handle 0 NULL XCreateGC to gc
+  display window-handle EVENT-MASK XSelectInput drop
+  1 1 image-resize
+;
+
+: flip
+  display window-handle gc image
+    0 0 0 0 width height XPutImage drop
+;
+
+: wait
+  display xevent XNextEvent drop
+  update-event
+;
+
+: poll
+  display event-mask xevent XCheckMaskEvent
+    if update-event else TIMEOUT to event then
+;
+
+forth definitions
+previous previous previous previous
 window
 | evaluate ;
 

ueforth/posix/posix.fs

@@ -188,8 +188,5 @@ O_RDWR constant R/W
 
 forth
 
-( Support shebang for running in scripts. )
-: #!   10 parse drop drop ; immediate
-
 ( Setup entry )
 internals : ok   ." uEforth" raw-ok ; forth

ueforth/posix/x11.fs

@@ -16,7 +16,7 @@
 
 : x11 r|
 
-forth also posix
+forth also posix also structures
 vocabulary x11   also x11 definitions
 
 z" libX11.so" shared-library xlib
@@ -47,9 +47,101 @@ z" XSetForeground" 3 xlib XSetForeground ( a a n -- void )
 z" XSetBackground" 3 xlib XSetBackground ( a a n -- void )
 z" XFillRectangle" 7 xlib XFillRectangle ( a n n n n n n -- void )
 
+0 constant XYBitmap
+1 constant XYPixmap
+2 constant ZPixmap
+
 0 constant NULL
+
 32 cells constant xevent-size
 
+: win ( n "name" ) long ;
+: time ( n "name" ) long ;
+: bool ( n "name" ) i32 ;
+
+vocabulary xany  also xany definitions
+struct XAnyEvent
+   i32 field ->type
+  long field ->serial
+  bool field ->send_event  ( Bool )
+   ptr field ->display
+   win field ->window
+previous definitions
+
+vocabulary xbutton  also xbutton definitions
+struct XButtonEvent
+   i32 field ->type
+  long field ->serial
+  bool field ->send_event
+   ptr field ->display
+   win field ->window
+   win field ->root
+   win field ->subwindow
+  time field ->time
+   i32 field ->x
+   i32 field ->y
+   i32 field ->x_root
+   i32 field ->y_root
+   i32 field ->state
+   i32 field ->button
+  bool field ->same_screen
+previous definitions
+
+vocabulary xkey  also xkey definitions
+struct XKeyEvent
+   i32 field ->type
+  long field ->serial
+  bool field ->send_event
+   ptr field ->display
+   win field ->window
+   win field ->root
+   win field ->subwindow
+  time field ->time
+   i32 field ->x
+   i32 field ->y
+   i32 field ->x_root
+   i32 field ->y_root
+   i32 field ->state
+   i32 field ->keycode
+  bool field ->same_screen
+previous definitions
+
+vocabulary xmotion  also xmotion definitions
+struct XMotionEvent
+   i32 field ->type
+  long field ->serial
+  bool field ->send_event
+   ptr field ->display
+   win field ->window
+   win field ->root
+   win field ->subwindow
+  time field ->time
+   i32 field ->x
+   i32 field ->y
+   i32 field ->x_root
+   i32 field ->y_root
+   i32 field ->state
+    i8 field ->is_hint
+  bool field ->same_screen
+previous definitions
+
+vocabulary xconfigure  also xconfigure definitions
+struct XConfigureEvent
+   i32 field ->type
+  long field ->serial
+  bool field ->send_event
+   ptr field ->display
+   win field ->event
+   win field ->window
+   i32 field ->x
+   i32 field ->y
+   i32 field ->width
+   i32 field ->height
+   i32 field ->border_width
+   win field ->above
+  bool field ->override_redirect
+previous definitions
+
 0 constant NoEventMask
 1 : xmask   dup constant 2* ;
 xmask KeyPressMask
@@ -79,43 +171,43 @@ xmask ColormapChangeMask
 xmask OwnerGrabButtonMask
 drop
 
-2 : xevent   dup constant 1+ ; 
+2 : xevent#   dup constant 1+ ;
-xevent KeyPress
+xevent# KeyPress
-xevent KeyRelease
+xevent# KeyRelease
-xevent ButtonPress
+xevent# ButtonPress
-xevent ButtonRelease
+xevent# ButtonRelease
-xevent MotionNotify
+xevent# MotionNotify
-xevent EnterNotify
+xevent# EnterNotify
-xevent LeaveNotify
+xevent# LeaveNotify
-xevent FocusIn
+xevent# FocusIn
-xevent FocusOut
+xevent# FocusOut
-xevent KeymapNotify
+xevent# KeymapNotify
-xevent Expose
+xevent# Expose
-xevent GraphicsExpose
+xevent# GraphicsExpose
-xevent NoExpose
+xevent# NoExpose
-xevent VisibilityNotify
+xevent# VisibilityNotify
-xevent CreateNotify
+xevent# CreateNotify
-xevent DestroyNotify
+xevent# DestroyNotify
-xevent UnmapNotify
+xevent# UnmapNotify
-xevent MapNotify
+xevent# MapNotify
-xevent MapRequest
+xevent# MapRequest
-xevent ReparentNotify
+xevent# ReparentNotify
-xevent ConfigureNotify
+xevent# ConfigureNotify
-xevent ConfigureRequest
+xevent# ConfigureRequest
-xevent GravityNotify
+xevent# GravityNotify
-xevent ResizeRequest
+xevent# ResizeRequest
-xevent CirculateNotify
+xevent# CirculateNotify
-xevent CirculateRequest
+xevent# CirculateRequest
-xevent PropertyNotify
+xevent# PropertyNotify
-xevent SelectionClear
+xevent# SelectionClear
-xevent SelectionRequest
+xevent# SelectionRequest
-xevent SelectionNotify
+xevent# SelectionNotify
-xevent ColormapNotify
+xevent# ColormapNotify
-xevent ClientMessage
+xevent# ClientMessage
-xevent MappingNotify
+xevent# MappingNotify
-xevent GenericEvent
+xevent# GenericEvent
 drop
 
-only forth definitions
+previous previous forth definitions
 x11
 | evaluate ;