Commit 8ee3e536 authored by Bernd Paysan's avatar Bernd Paysan

Keep track of out in gl-terminal.fs

parent c5a33416
......@@ -733,6 +733,7 @@ Plugin branch, ( target-addr -- ) \ compiles a branch
Plugin ?branch, ( target-addr -- ) \ compiles a ?branch
Plugin branchmark, ( -- branch-addr ) \ reserves room for a branch
Plugin ?branchmark, ( -- branch-addr ) \ reserves room for a ?branch
Plugin ?dup-?branchmark, ( -- branch-addr ) \ reserves room for a ?branch
Plugin ?domark, ( -- branch-addr ) \ reserves room for a ?do branch
Plugin branchto, ( -- ) \ actual program position is target of a branch (do e.g. alignment)
' NOOP plugin-of branchto,
......@@ -749,6 +750,7 @@ Plugin doer-resolve ( ghost res-pnt target-addr addr -- ghost res-pnt )
Plugin ncontrols? ( [ xn ... x1 ] n -- ) \ checks wheter n control structures are open
Plugin if, ( -- if-token )
Plugin ?dup-if, ( -- if-token )
Plugin else, ( if-token -- if-token )
Plugin then, ( if-token -- )
Plugin ahead,
......@@ -1098,6 +1100,7 @@ Ghost - drop \ need a ghost otherwise "-" would be treated as a number
Ghost 0= drop
Ghost branch Ghost ?branch 2drop
Ghost ?dup-?branch drop
Ghost unloop Ghost ;S 2drop
Ghost lit Ghost ! 2drop
Ghost noop drop
......@@ -3482,6 +3485,8 @@ X has? abranch [IF]
IS branchmark, ( -- branchtoken )
:noname compile ?branch T here 0 H offset, ;
IS ?branchmark, ( -- branchtoken )
:noname compile ?dup-?branch T here 0 H offset, ;
IS ?dup-?branchmark, ( -- branchtoken )
:noname T here 0 H offset, ;
IS ?domark, ( -- branchtoken )
:noname dup X @ ?struc X here over branchoffset swap X ! ;
......@@ -3571,6 +3576,8 @@ Cond: ?LEAVE ?leave, ;Cond
: (if,) ?branchmark, ; ' (if,) plugin-of if,
: (?dup-if,) ?dup-?branchmark, ; ' (?dup-if,) plugin-of ?dup-if,
: (then,) branchto, branchtoresolve, ; ' (then,) plugin-of then,
: (else,) ( ahead ) branchmark,
......@@ -3606,6 +3613,7 @@ Cond: ?LEAVE ?leave, ;Cond
>TARGET
Cond: AHEAD ahead, ;Cond
Cond: IF if, ;Cond
Cond: ?dup-IF ?dup-if, ;Cond
Cond: THEN 1 ncontrols? then, ;Cond
Cond: ENDIF 1 ncontrols? then, ;Cond
Cond: ELSE 1 ncontrols? else, ;Cond
......
......@@ -33,7 +33,7 @@
[ 6 cells ] Literal + [ -4 cells ] Literal and ;
: $free ( addr -- ) \ gforth-string string-free
\G free the string pointed to by addr, and set addr to 0
0 swap !@ dup IF free throw ELSE drop THEN ;
0 swap !@ ?dup-IF free throw THEN ;
' $free alias $off \ don't ask, don't use
: $make ( addr1 u -- $addr )
......@@ -50,9 +50,7 @@
over $padding over $@len $padding = IF
@ 2dup ! cell+ swap move EXIT
THEN THEN
>r $make
BEGIN r@ $free dup 0 r@ ?!@ 0= UNTIL \ prevent memory leak
drop rdrop ;
>r $make r> !@ ?dup-IF free throw THEN ;
: $@ ( addr1 -- addr2 u ) \ gforth-string string-fetch
\G returns the stored string.
@ dup IF dup cell+ swap @ ELSE 0 THEN ;
......
......@@ -20,9 +20,6 @@
require unix/mmap.fs
require mini-oof2.fs
: w, ( n -- ) here 2 allot w! ;
: l, ( n -- ) here 4 allot l! ;
Variable dpy-w
Variable dpy-h
0 Value ctx
......
......@@ -17,8 +17,6 @@
\ You should have received a copy of the GNU General Public License
\ along with this program. If not, see http://www.gnu.org/licenses/.
require ansi.fs \ we may want to support colorize.fs
\ opengl common stuff
\ :noname source type cr stdout flush-file throw ; is before-line
......@@ -250,7 +248,7 @@ Variable gl-emit-buf
: gl-cr ( -- )
gl-lineend @ 0= IF
gl-xy 2@ 1+ nip 0 swap gl-xy 2! THEN
resize-screen need-sync on ;
resize-screen need-sync on out off ;
: xchar>glascii ( xchar -- 0..7F )
case
......@@ -273,8 +271,17 @@ Variable gl-emit-buf
THEN
0 endcase ;
: gl-atxy ( x y -- )
>r gl-wh @ min 0 max r> gl-xy 2!
gl-xy cell+ @ out ! ;
: gl-at-deltaxy ( x y -- )
>r s>d screenw @ sm/rem r> +
gl-xy 2@ rot + >r + r> gl-atxy ;
: (gl-emit) ( char color -- )
over 7 = IF 2drop EXIT THEN
over #bs = IF 2drop -1 0 gl-at-deltaxy EXIT THEN
over #lf = IF 2drop gl-cr EXIT THEN
over #cr = IF 2drop gl-cr EXIT THEN
over #tab = IF >r drop bl gl-xy cell+ @ dup 1+ dfaligned swap - 0
......@@ -285,7 +292,8 @@ Variable gl-emit-buf
gl-emit-buf $@ x-width abs
gl-emit-buf $off $10
THEN { n m }
n out +!
resize-screen need-sync on
dup $70 and 5 lshift or $F0F and 4 lshift r> $FFFF0000 and or
n 0 ?DO
......@@ -308,13 +316,6 @@ Variable gl-emit-buf
: gl-type-err ( addr u -- )
bounds ?DO I c@ gl-emit-err LOOP ;
: gl-atxy ( x y -- )
>r gl-wh @ min 0 max r> gl-xy 2! ;
: gl-at-deltaxy ( x y -- )
>r s>d screenw @ sm/rem r> +
gl-xy 2@ rot + >r + r> gl-atxy ;
: gl-page ( -- ) 0 0 gl-atxy 0 to videorows
0e screen-scroll 0e fdup scroll-source f! scroll-dest f!
videomem videocols sfloats resize throw to videomem
......
......@@ -46,9 +46,6 @@ standard:field
:noname ]] >r [[ xt-align compile, ]] r> create+value ; [[
Create set-does> , , , , ;
: waligned ( addr -- waddr ) 1+ -2 and ;
: laligned ( addr -- waddr ) 3 + -4 and ;
cell ' aligned ' @ ' ! wrap+value: value: ( u1 "name" -- u2 )
1 ' noop ' c@ ' c! wrap+value: cvalue: ( u1 "name" -- u2 )
2 ' waligned ' w@ ' w! wrap+value: wvalue: ( u1 "name" -- u2 )
......
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