diff --git a/ueforth/common/boot.fs b/ueforth/common/boot.fs index be3572f..85f11f2 100644 --- a/ueforth/common/boot.fs +++ b/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 ) diff --git a/ueforth/common/forth_namespace_tests.fs b/ueforth/common/forth_namespace_tests.fs index 198322e..157849b 100644 --- a/ueforth/common/forth_namespace_tests.fs +++ b/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 diff --git a/ueforth/common/grf_test.fs b/ueforth/common/grf_test.fs index 01bf5ef..e517c2f 100644 --- a/ueforth/common/grf_test.fs +++ b/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"); diff --git a/ueforth/common/opcodes.h b/ueforth/common/opcodes.h index 512c364..4bb9dbd 100644 --- a/ueforth/common/opcodes.h +++ b/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?", \ diff --git a/ueforth/common/structures.fs b/ueforth/common/structures.fs index 9c907db..adeda0a 100644 --- a/ueforth/common/structures.fs +++ b/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 - 2 2 typer i16 - 4 4 typer i32 -cell 8 typer i64 +1 1 typer i8 +2 2 typer i16 +4 4 typer i32 +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 -- ) diff --git a/ueforth/posix/grf.fs b/ueforth/posix/grf.fs index 75ed8be..8f02477 100644 --- a/ueforth/posix/grf.fs +++ b/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 ; diff --git a/ueforth/posix/posix.fs b/ueforth/posix/posix.fs index 5bfc1a2..d8e9e86 100644 --- a/ueforth/posix/posix.fs +++ b/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 diff --git a/ueforth/posix/x11.fs b/ueforth/posix/x11.fs index eb90ed5..14d0598 100644 --- a/ueforth/posix/x11.fs +++ b/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+ ; -xevent KeyPress -xevent KeyRelease -xevent ButtonPress -xevent ButtonRelease -xevent MotionNotify -xevent EnterNotify -xevent LeaveNotify -xevent FocusIn -xevent FocusOut -xevent KeymapNotify -xevent Expose -xevent GraphicsExpose -xevent NoExpose -xevent VisibilityNotify -xevent CreateNotify -xevent DestroyNotify -xevent UnmapNotify -xevent MapNotify -xevent MapRequest -xevent ReparentNotify -xevent ConfigureNotify -xevent ConfigureRequest -xevent GravityNotify -xevent ResizeRequest -xevent CirculateNotify -xevent CirculateRequest -xevent PropertyNotify -xevent SelectionClear -xevent SelectionRequest -xevent SelectionNotify -xevent ColormapNotify -xevent ClientMessage -xevent MappingNotify -xevent GenericEvent +2 : xevent# dup constant 1+ ; +xevent# KeyPress +xevent# KeyRelease +xevent# ButtonPress +xevent# ButtonRelease +xevent# MotionNotify +xevent# EnterNotify +xevent# LeaveNotify +xevent# FocusIn +xevent# FocusOut +xevent# KeymapNotify +xevent# Expose +xevent# GraphicsExpose +xevent# NoExpose +xevent# VisibilityNotify +xevent# CreateNotify +xevent# DestroyNotify +xevent# UnmapNotify +xevent# MapNotify +xevent# MapRequest +xevent# ReparentNotify +xevent# ConfigureNotify +xevent# ConfigureRequest +xevent# GravityNotify +xevent# ResizeRequest +xevent# CirculateNotify +xevent# CirculateRequest +xevent# PropertyNotify +xevent# SelectionClear +xevent# SelectionRequest +xevent# SelectionNotify +xevent# ColormapNotify +xevent# ClientMessage +xevent# MappingNotify +xevent# GenericEvent drop -only forth definitions +previous previous forth definitions x11 | evaluate ;