Commit ab406623 authored by bp's avatar bp

compileable with VFX again

git-svn-id: https://forth-ev.de/repos/bigforth@2499 3b8d8251-53f3-0310-8f3b-fd1cb8370982
parent b770aedb
......@@ -461,9 +461,9 @@ how: : dispose clicks HandleOff
\ Display 04aug05py
[defined] x11 [IF]
:noname event XMotionEvent time @ event-time !
[: event XMotionEvent time @ event-time !
event XMotionEvent x @+ @ mxy!
event XMotionEvent state @ 8 >> mb ! moved! ;
event XMotionEvent state @ 8 >> mb ! moved! ;]
MotionNotify cells Handlers + !
| 2Variable comp_stat
| Variable look_key
......@@ -471,7 +471,7 @@ how: : dispose clicks HandleOff
\ Display 04jan07py
:noname ( -- ) \ cr 'd emit 'o emit
[: ( -- ) \ cr 'd emit 'o emit
do-exposed
event XKeyEvent time @ event-time !
[defined] has-utf8 [IF] xrc ic @ ?dup >r [THEN]
......@@ -483,13 +483,13 @@ how: : dispose clicks HandleOff
?dup IF look_chars swap bounds ?DO
I xc@+ swap >r event XKeyEvent state @ $3F and keyed
r> I - +LOOP EXIT THEN
look_key @ event XKeyEvent state @ $3F and $80 or keyed ;
look_key @ event XKeyEvent state @ $3F and $80 or keyed ;]
KeyPress cells Handlers + !
\ Display 11sep05py
:noname \ cr ." mapping notify"
event XRefreshKeyboardMapping drop ;
[: \ cr ." mapping notify"
event XRefreshKeyboardMapping drop ;]
MappingNotify cells Handlers + !
: click^ ( -- event ) clicks @ @+ swap 8* + ;
: transclick ( x y -- x' y' ) ;
......@@ -524,7 +524,7 @@ how: : dispose clicks HandleOff
: .button cr base push hex event XButtonEvent window
@+ @+ @ swap rot xwin @ 9 .r 9 .r 9 .r 9 .r
space event XButtonEvent x @+ swap . @ . ;
:noname ( -- )
[: ( -- )
do-exposed
event XButtonEvent time @ event-time !
event XButtonEvent time @ dup true in-time?
......@@ -536,11 +536,11 @@ how: : dispose clicks HandleOff
lastclick on
THEN EXIT THEN event !xyclick flags #pending -bit
THEN flags #pending bit@ IF moreclicks THEN
1 event sendclick lastclick on ;
1 event sendclick lastclick on ;]
ButtonPress cells Handlers + !
\ Display 09mar99py
:noname ( -- )
[: ( -- )
do-exposed
event XButtonEvent time @ event-time !
event XButtonEvent time @ dup 0 in-time?
......@@ -556,7 +556,7 @@ how: : dispose clicks HandleOff
IF event !xyclick +clicks moreclicks THEN
flags #pending bit@ 0= >r
2 event sendclick lastclick off
r> IF flags #pending -bit THEN ;
r> IF flags #pending -bit THEN ;]
ButtonRelease cells Handlers + !
\ Display 28jun98py
......@@ -571,32 +571,32 @@ how: : dispose clicks HandleOff
\ Display 04aug05py
:noname
[:
event XExposeEvent x @+ @+ @+ @ add-region
\ event XExposeEvent count @ 0= IF ." draw" draw THEN
flags #exposed +bit ;
flags #exposed +bit ;]
dup Expose cells Handlers + !
GraphicsExpose cells Handlers + !
:noname do-exposed pointed self
IF mx @ my @ pointed moved THEN ;
[: do-exposed pointed self
IF mx @ my @ pointed moved THEN ;]
EnterNotify cells Handlers + !
:noname do-exposed pointed self
IF pointed leave 0 bind pointed moved? drop THEN ;
[: do-exposed pointed self
IF pointed leave 0 bind pointed moved? drop THEN ;]
LeaveNotify cells Handlers + !
\ Display 23apr06py
Create xev here sizeof XEvent dup allot erase
:noname \ cr ." Selection Notify "
[: \ cr ." Selection Notify "
event XSelectionRequestEvent time @ event-time !
event XSelectionEvent property @
event XSelectionEvent requestor @
xrc dpy @ fetch-property ;
xrc dpy @ fetch-property ;]
SelectionNotify cells Handlers + !
:noname \ cr ." Selection Clear "
own-selection off ;
[: \ cr ." Selection Clear "
own-selection off ;]
SelectionClear cells Handlers + !
\ Display 16jan05py
......@@ -622,7 +622,7 @@ how: : dispose clicks HandleOff
'string 2 PropModeReplace #32 4 rest-request ;
\ Display 16jan05py
:noname \ cr ." Selection Request "
[: \ cr ." Selection Request "
event XSelectionRequestEvent time @ event-time !
event xev 4 cells move
event XSelectionRequestEvent requestor
......@@ -642,51 +642,51 @@ how: : dispose clicks HandleOff
xrc dpy @
event XSelectionRequestEvent requestor @
0 0 xev XSendEvent drop ;
0 0 xev XSendEvent drop ;]
SelectionRequest cells Handlers + !
\ Display 07jan07py
:noname flags #exposed +bit ; NoExpose cells Handlers + !
:noname ( -- ) \ resize request
[: flags #exposed +bit ;] NoExpose cells Handlers + !
[: ( -- ) \ resize request
event XConfigureEvent x @ x !
event XConfigureEvent y @ y !
event XConfigureEvent width @ rw !
event XConfigureEvent height @ rh ! ;
event XConfigureEvent height @ rh ! ;]
ConfigureNotify cells Handlers + !
:noname do-exposed focus ;
[: do-exposed focus ;]
FocusIn cells Handlers + !
:noname do-exposed defocus ;
[: do-exposed defocus ;]
FocusOut cells Handlers + !
: >exposed ( -- ) sync flags #exposed -bit
BEGIN ( ExposureMask ) 0 get-event
pause flags #exposed bit@ UNTIL ;
\ Display 02aug98py
:noname ( -- )
event sizeof XClientMessageEvent dump ;
[: ( -- )
event sizeof XClientMessageEvent dump ;]
ClientMessage cells Handlers + !
[THEN]
\ Display 19jan00py
[defined] win32 [IF] Create paint $40 allot
:noname ( lparam wparam msg win -- ret )
[: ( lparam wparam msg win -- ret )
xrc dc @ >r paint xwin @ BeginPaint xrc dc !
Xform0 xrc dc @ SetWorldTransform drop
draw paint xwin @ EndPaint drop r> xrc dc !
2drop 2drop 0 flags #exposed +bit ; WM_PAINT Handler@ !
:noname 3 pick >lohi y ! x ! DefWindowProc ;
2drop 2drop 0 flags #exposed +bit ;] WM_PAINT Handler@ !
[: 3 pick >lohi y ! x ! DefWindowProc ;]
WM_MOVE Handler@ !
:noname 2drop 2drop close 0 ; WM_CLOSE Handler@ !
:noname 3 pick WINDOWPOS flags @ SWP_NOSIZE and
[: 2drop 2drop close 0 ;] WM_CLOSE Handler@ !
[: 3 pick WINDOWPOS flags @ SWP_NOSIZE and
IF DefWindowProc EXIT THEN 2drop drop
WINDOWPOS cx 2@ 0. 0. sp@ 0 style @ rot
AdjustWindowRect drop p- p- rw ! rh !
size-event 0 ; WM_WINDOWPOSCHANGED Handler@ !
size-event 0 ;] WM_WINDOWPOSCHANGED Handler@ !
\ Display 28jul07py
:noname 2drop drop { rect |
[: 2drop drop { rect |
vglue >r hglue >r 0 0 sp@ >r 0 style @ r>
AdjustWindowRect drop p- rect 2@ p+
dup r> + 2 pick r> + >r >r
......@@ -696,11 +696,11 @@ how: : dispose clicks HandleOff
AdjustWindowRect drop p- rect 2@ p+
rot over - r@ 2/ + r@ / r> * + -rot swap
over - r@ 2/ + r@ / r> * + swap
rect 2 cells + 2! 0 } ; WM_SIZING Handler@ !
\ :noname ( lparam wparam msg win -- ret )
\ DefWindowProc ; WM_INPUTLANGCHANGE Handler@ !
\ :noname ( lparam wparam msg win -- ret )
\ DefWindowProc ; WM_INPUTLANGCHANGEREQUEST Handler@ !
rect 2 cells + 2! 0 } ;] WM_SIZING Handler@ !
\ [: ( lparam wparam msg win -- ret )
\ DefWindowProc ;] WM_INPUTLANGCHANGE Handler@ !
\ [: ( lparam wparam msg win -- ret )
\ DefWindowProc ;] WM_INPUTLANGCHANGEREQUEST Handler@ !
\ Display 19jan00py
......@@ -723,15 +723,15 @@ private:
$FF51 , $FF52 , $FF53 , $FF54 ,
0 , 0 , 0 , 0 ,
$0000 , $007F ,
:noname 2drop nip dup $21 $2F within
[: 2drop nip dup $21 $2F within
IF $21 - cells xkeys + @ ?dup
IF shift@ ?keyed THEN
ELSE drop THEN 0 ; WM_KEYDOWN Handler@ !
:noname 2drop nip shift@ ?keyed 0 ;
ELSE drop THEN 0 ;] WM_KEYDOWN Handler@ !
[: 2drop nip shift@ ?keyed 0 ;]
WM_CHAR Handler@ !
\ :noname 2drop nip shift@ ?keyed 0 ;
\ [: 2drop nip shift@ ?keyed 0 ;]
\ WM_IME_CHAR Handler@ !
:noname 2drop nip shift@ ( 8 or ) ?keyed 0 ;
[: 2drop nip shift@ ( 8 or ) ?keyed 0 ;]
WM_SYSCHAR Handler@ !
\ Display 12aug00py
......@@ -768,7 +768,7 @@ private:
: +clicks ( -- ) click^ 6+ dup w@ 2+ -2 and swap w! ;
\ Display 19jan00py
:noname ( lparam wparam msg win -- 0 ) ?grab \ add press
[: ( lparam wparam msg win -- 0 ) ?grab \ add press
SetCapture 2drop 2drop
event MSG time @ dup true in-time?
swap lasttime !
......@@ -779,13 +779,13 @@ private:
lastclick on
THEN 0 EXIT THEN event !xyclick flags #pending -bit
THEN flags #pending bit@ IF moreclicks THEN
1 event sendclick lastclick on 0 ;
1 event sendclick lastclick on 0 ;]
dup WM_LBUTTONDOWN Handler@ !
dup WM_RBUTTONDOWN Handler@ !
WM_MBUTTONDOWN Handler@ !
\ Display 19jan00py
:noname 2drop $13 and 0= IF ReleaseCapture drop THEN
[: 2drop $13 and 0= IF ReleaseCapture drop THEN
?grab drop event MSG time @ dup 0 in-time?
swap lasttime !
IF event samepos? IF lastclick @
......@@ -798,7 +798,7 @@ private:
IF event !xyclick +clicks moreclicks THEN
flags #pending bit@ 0= >r
2 event sendclick lastclick off 0
r> IF flags #pending -bit THEN ;
r> IF flags #pending -bit THEN ;]
dup WM_LBUTTONUP Handler@ !
dup WM_RBUTTONUP Handler@ ! WM_MBUTTONUP Handler@ !
......@@ -813,10 +813,10 @@ private:
click^ w!+ w!+ w!+ w!
moreclicks
2 +LOOP drop ;
:noname ( lparam wparam msg win -- ) moved!
[: ( lparam wparam msg win -- ) moved!
flags #pending bit@ IF moreclicks flags #pending -bit THEN
event MSG time @ lasttime !
2drop 2drop event sendwheel 0 ;
2drop 2drop event sendwheel 0 ;]
WM_MOUSEWHEEL Handler@ !
\ Display 12aug00py
......@@ -829,25 +829,24 @@ private:
clicks @ $C + dup 8 - clicks @ @ 8* move
( 2over 2over cr . . . . ) ;
:noname 2drop drop >r
[: 2drop drop >r
vglue + hglue +
0. sp@ 0 style @ rot AdjustWindowRect drop p-
r> $8 + 2! 0 ;
WM_GETMINMAXINFO Handler@ !
r> $8 + 2! 0 ;] WM_GETMINMAXINFO Handler@ !
\ Display 29jul07py
:noname ( lparam wparam msg win -- ) ?grab moved!
2drop >mshift $FF and mb ! >lohi mxy! 0 ;
[: ( lparam wparam msg win -- ) ?grab moved!
2drop >mshift $FF and mb ! >lohi mxy! 0 ;]
WM_MOUSEMOVE Handler@ !
:noname pointed self
[: pointed self
IF pointed leave 0 bind pointed THEN
DefWindowProc ; WM_NCMOUSEMOVE Handler@ !
:noname focus 2drop 2drop 0 ; WM_SETFOCUS Handler@ !
:noname defocus 2drop 2drop 0 ; WM_KILLFOCUS Handler@ !
:noname ( lparam wparam msg win -- )
[: focus 2drop 2drop 0 ;] WM_SETFOCUS Handler@ !
[: defocus 2drop 2drop 0 ;] WM_KILLFOCUS Handler@ !
[: ( lparam wparam msg win -- )
2drop 2drop get-sys-colors xrc free-colors
xrc colors 0 ; WM_SYSCOLORCHANGE Handler@ !
xrc colors 0 ;] WM_SYSCOLORCHANGE Handler@ !
: >exposed ;
[THEN]
class;
......@@ -857,13 +856,13 @@ class;
displays ptr screen
[defined] x11 [IF]
:noname ( -- ) 0 screen get-event ; IS screen-event
:noname ( -- ) screen sync ; IS screen-sync
:noname ( ic -- ) screen xrc ic ! ; IS screen-ic!
[: ( -- ) 0 screen get-event ;] IS screen-event
[: ( -- ) screen sync ;] IS screen-sync
[: ( ic -- ) screen xrc ic ! ;] IS screen-ic!
[THEN]
[defined] win32 [IF]
:noname ( win -- o ) screen win>o nip ; IS win>o
[: ( win -- o ) screen win>o nip ;] IS win>o
[THEN]
\ font implementation 21aug99py
......
......@@ -96,7 +96,7 @@ FVariable rho 0e rho f!
THEN
LOOP ;
: phis ( n m -- )
: phis ( n m -- ) \ print mm/s
dup negate 1+ ?DO
pi I I' 1- fm*/ phi0 f!
dup integrate phi0 f@ pi f/ 180e f* f.
......
\ helper words for VFX Forth
s" /usr/share/doc/VfxForth/Lib" s" Lib" replaces
\ =============
\ *! vfxharness
\ *T Portability layer for VFX Forth
......@@ -58,7 +60,7 @@ ans-float
\ *G Convert a floating point number to ASCII text. This
\ ** still needs furthr processing according to the required
\ ** presentation mode to insert a decimal point and so on.
pad dup f>ascii ;
precision (f.) ;
Code f>r \ F: f -- ; R: -- f
\ *G Transfer a float to the return stack.
......
......@@ -220,8 +220,8 @@ how:
1 and IF swap-id THEN
w id @ dup XftFont ascent @ swap XftFont descent @ + ;
: draw ( addr u x y dpy -- ) { addr u x y dpy }
x -$8000 $7FFF within
y -$8000 $7FFF within and IF
x $-8000 $7FFF within
y $-8000 $7FFF within and IF
color @ $FF and dpy set-color
dpy displays with
xft-draw @ 0= IF
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment