Condense DO LOOP.

common/boot.fs

@@ -63,15 +63,18 @@ variable leaving
              begin dup while dup @ swap here swap ! repeat drop ;
 : (do) ( n n -- .. ) swap r> -rot >r >r >r ;
 : do ( lim s -- ) leaving( postpone (do) here ; immediate
-: (?do) ( n n -- n n f .. ) 2dup = if 2drop 0 else -1 then ;
+: (?do) ( n n -- n n f .. )
-: ?do ( lim s -- ) leaving( postpone (?do) postpone 0branch leaving,
+   2dup = if 2drop r> @ >r else swap r> cell+ -rot >r >r >r then ;
-                   postpone (do) here ; immediate
+: ?do ( lim s -- ) leaving( postpone (?do) leaving, here ; immediate
-: unloop   postpone rdrop postpone rdrop ; immediate
+: unloop   r> rdrop rdrop >r ;
-: leave   postpone unloop postpone branch leaving, ; immediate
+: (leave)   r> rdrop rdrop @ >r ;
-: (+loop) ( n -- f .. ) dup 0< swap r> r> rot + dup r@ < -rot >r >r xor 0= ;
+: leave   postpone (leave) leaving, ; immediate
-: +loop ( n -- ) postpone (+loop) postpone until
+: (+loop) ( n -- ) dup 0< swap r> r> rot + dup r@ < -rot >r >r xor 0=
-                 postpone unloop )leaving ; immediate
+                        if r> cell+ rdrop rdrop >r else r> @ >r then ;
-: loop   1 aliteral postpone +loop ; immediate
+: +loop ( n -- ) postpone (+loop) , )leaving ; immediate
+: (loop)   r> r> 1+ dup r@ < -rot >r >r 0=
+           if r> cell+ rdrop rdrop >r else r> @ >r then ;
+: loop   postpone (loop) , )leaving ; immediate
 create I ' r@ @ ' i !  ( i is same as r@ )
 : J ( -- n ) rp@ 3 cells - @ ;
 : K ( -- n ) rp@ 5 cells - @ ;

common/utils.fs

@@ -90,6 +90,10 @@ variable indent
    dup  @ ['] BRANCH @ =
    over @ ['] 0BRANCH @ = or
    over @ ['] DONEXT @ = or
+   over ['] (?do) = or
+   over ['] (+loop) = or
+   over ['] (loop) = or
+   over ['] (leave) = or
        if swap cell+ swap then
    drop
 ;

common/vocabulary.fs

@@ -57,7 +57,7 @@ transfer{
   immediate? input-buffer ?echo ?arrow. arrow
   evaluate-buffer aliteral value-bind
   leaving( )leaving leaving leaving,
-  (do) (?do) (+loop) 
+  (do) (?do) (+loop) (loop) (leave)
   parse-quote digit $@ raw.s
   tib-setup input-limit
   [SKIP] [SKIP]' raw-ok boot-prompt free.