Keep track of out in gl-terminal.fs

cross.fs

@@ -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

kernel/stringk.fs

@@ -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 ;

minos2/gl-helper.fs

@@ -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

minos2/gl-terminal.fs

@@ -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

struct-val.fs

@@ -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 )