replaced ROT + SWAP with UNDER+, replaced other sequences with UNDER+ sequences

arch/386/asm.fs

@@ -86,7 +86,7 @@ Variable .osize               Variable .onow
 
 \ Extra-Werte compilieren                              01may95py
 : bytes,  ( nr x n -- )
-    0 ?DO  over 0< IF  +rel  swap 1+ swap  THEN  dup ,  $8 rshift
+    0 ?DO  over 0< IF  +rel  1 under+  THEN  dup ,  $8 rshift
     LOOP   2drop ;
 : opcode, ( opcode -- )
     .asize @ .anow @  <> IF  $67 ,  THEN

arch/386/ncex/ring.fs

@@ -118,7 +118,7 @@ S" Ring buffer index out of range!" exception constant RB-E-RANGE
     ROT DROP 
   ELSE ( wrap around ) 			\ rb hp tp
     ROT @ 				\ hp tp length
-    ROT + SWAP 				\ hp+l tp
+    UNDER+ 				\ hp+l tp
   THEN 
   - ;
 

arch/amd64/asm.fs

@@ -95,7 +95,7 @@ Variable dquad?
    
 \ Extra-Werte compilieren                              01may95py
 : bytes,  ( nr x n -- )
-    0 ?DO  over 0< IF  +rel  swap 1+ swap  THEN  dup ,  $8 rshift
+    0 ?DO  over 0< IF  +rel  1 under+  THEN  dup ,  $8 rshift
     LOOP   2drop ;
 : rbytes, ( nr x n -- )
     >r here r@ + - r> bytes, ;

arch/amd64/disasm.fs

@@ -165,8 +165,8 @@ Create .disp ' noop ,  ' .8b ,   ' .32b ,
   cells .disp + perform  r> .[ .sib/reg .] ;
 \ Register display                                     29may10py
 
-: wcount ( addr -- addr' w ) dup uw@ >r 2 + r> ;
-: wxcount ( addr -- addr' w ) dup sw@ >r 2 + r> ;
+: wcount ( addr -- addr' w ) dup uw@ 2 under+ ;
+: wxcount ( addr -- addr' w ) dup sw@ 2 under+ ;
 : +8b  ( addr -- addr' )  count  .$bs ;
 : +16b ( addr -- addr' )  wcount .$ds ;
 

arch/arm/asm.fs

@@ -37,7 +37,7 @@ HEX  \ EVERYTHING BELOW IS IN HEXADECIMAL!
 
 \ Enumerations
 : enumerate:  ( N start "name1" ... "nameN" -- )
-   DUP ROT + SWAP ?DO   I CONSTANT  LOOP ;
+   DUP UNDER+ ?DO   I CONSTANT  LOOP ;
 
 \ operand types
 6 70000000 enumerate: register shifted #immediate psr cxsf-mask offset

arch/misc/sokoban.fs

@@ -45,7 +45,7 @@ Create pn-tab ," 000102030405060708091011121314151617181920212223242526272829303
 : pn    ( n -- )  2* pn-tab 1+ + 2 type ;
 : ;pn   [char] ; emit pn ;
 : ESC[  &27 emit [char] [ emit ;
-: at-xy 1+ swap 1+ swap ESC[ pn ;pn [char] H emit ;
+: at-xy 1+ 1 under+ ESC[ pn ;pn [char] H emit ;
 : page  ESC[ ." 2J" 0 0 at-xy ;
 
 40 Constant /maze  \ maximal maze line
@@ -72,7 +72,7 @@ UNLOCK
     over + swap ?DO  I c@ [char] $ = -  LOOP ;
 : m: ( "string" -- )  \ add a level line (top first!)
     -1 parse tuck 2dup count-$
-    >maze X @ 1 X cells - dup X @ rot + swap X ! 
+    >maze X @ 1 X cells - dup X @ under+ X ! 
     bounds ?DO  I c@ X c,  LOOP
     /maze swap - 0 ?DO  bl X c,  LOOP
     >maze X @ X here over X cell+ - swap X ! ;

arch/misc/tt.fs

@@ -21,7 +21,7 @@ variable loops/ms
 : pn    ( n -- )  0 <# # # #> type ;
 : ;pn   [char] ; emit pn ;
 : ESC[  27 emit [char] [ emit ;
-: at-xy 1+ swap 1+ swap ESC[ pn ;pn [char] H emit ;
+: at-xy 1+ 1 under+ ESC[ pn ;pn [char] H emit ;
 : page  ESC[ ." 2J" 0 0 at-xy ;
 : d= rot = >r = r> and ;
 

arch/r8c/tt.fs

@@ -51,7 +51,7 @@ variable seed $1234 seed !
 : pn    ( n -- )  0 <# # # #> type ;
 : ;pn   [char] ; emit pn ;
 : ESC[  27 emit [char] [ emit ;
-: at-xy 1+ swap 1+ swap ESC[ pn ;pn [char] H emit ;
+: at-xy 1+ 1 under+ ESC[ pn ;pn [char] H emit ;
 : page  ESC[ ." 2J" 0 0 at-xy ;
 
 : d<>  d- or 0<> ;

asm/bitmask.fs

@@ -51,7 +51,7 @@ decimal
 
 : bitset# ( u -- )
 \G returns the number of bits set in a cell
-  0 swap 64 0 DO dup 1 and IF swap 1+ swap THEN 1 rshift LOOP drop ;
+  0 swap 64 0 DO dup 1 and IF 1 under+ THEN 1 rshift LOOP drop ;
 
 : max/bits ( u -- u2 )
 \G returns the highes number that could be represented by u bits

asm/bitmask2.fs

@@ -29,7 +29,7 @@
    -rot and or ;                \ first delete then optionally set bit
 : (bits/cell)  ( -- +n )  \ measure number of bits per cell
    1 1 begin  1 lshift dup while
-	 swap 1+ swap
+	 1 under+
    repeat  drop ;
 (bits/cell) CONSTANT bits/cell
 

bits.fs

@@ -20,7 +20,7 @@
 
 : bits ( n -- n ) 1 swap lshift ;
 
-: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
+: >bit ( addr n -- c-addr mask ) 8 /mod under+ bits ;
 : +bit ( addr n -- )  >bit over c@ or swap c! ;
 : +bit@ ( addr n -- flag )  >bit over c@ 2dup and >r
     or swap c! r> 0<> ;

contrib/strings.fs

@@ -61,7 +61,7 @@
 	\ Use "count" to obtain the length of a counted string.
 	0
 	begin
-	  over c@ 0= dup invert if -rot 1+ swap 1+ swap rot then 
+	  over c@ 0= dup invert if -rot 1+ 1 under+ rot then 
 	until
 	nip ;
 

cross.fs

@@ -1662,26 +1662,26 @@ bigendian
 	DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
     : DS@  ( addr -- d )
 	>r 0 0 r> tcell bounds
-	DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP ;
+	DO  maxbyte * swap maxbyte um* under+ I c@ + swap  LOOP ;
     : Sc!  ( n addr -- )
 	>r s>d r> tchar bounds swap 1-
 	DO  maxbyte ud/mod rot I c!  -1 +LOOP  2drop ;
     : Sc@  ( addr -- n )
 	>r 0 0 r> tchar bounds
-	DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  LOOP d>s ;
+	DO  maxbyte * swap maxbyte um* under+ I c@ + swap  LOOP d>s ;
 [ELSE]
     : DS!  ( d addr -- )
 	tcell bounds
 	DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
     : DS@  ( addr -- n )
 	>r 0 0 r> tcell bounds swap 1-
-	DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP ;
+	DO  maxbyte * swap maxbyte um* under+ I c@ + swap  -1 +LOOP ;
     : Sc!  ( n addr -- )
 	>r s>d r> tchar bounds
 	DO  maxbyte ud/mod rot I c!  LOOP  2drop ;
     : Sc@  ( addr -- n )
 	>r 0 0 r> tchar bounds swap 1-
-	DO  maxbyte * swap maxbyte um* rot + swap I c@ + swap  -1 +LOOP d>s ;
+	DO  maxbyte * swap maxbyte um* under+ I c@ + swap  -1 +LOOP d>s ;
 [THEN]
 
 : S! ( n addr -- ) >r s>d r> DS! ;
@@ -1760,7 +1760,7 @@ bigendian
 CREATE Bittable 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
 : bits ( n -- n ) chars Bittable + c@ ;
 
-: >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
+: >bit ( addr n -- c-addr mask ) 8 /mod under+ bits ;
 : +bit ( addr n -- )  >bit over c@ or swap c! ;
 : -bit ( addr n -- )  >bit invert over c@ and swap c! ;
 
@@ -4135,7 +4135,7 @@ Variable outfile-fd
   over align+ tuck tcell swap - rshift swap 0
   ?DO dup 1 and 
      IF drop rdrop snl-calc UNLOOP EXIT THEN 
-     2/ swap 1+ swap 
+     2/ 1 under+ 
   LOOP
   drop r> cell+
   ( S .. taddr2 type-addr ) dup
@@ -4143,7 +4143,7 @@ Variable outfile-fd
   dup >r swap - 1 cells / tcell * + r>
   ( S .. taddr2+skiplencells type-addr )
   @ addr-refs @ 1 tcell lshift or
-  BEGIN dup 1 and 0= WHILE swap 1+ swap 2/ REPEAT drop
+  BEGIN dup 1 and 0= WHILE 1 under+ 2/ REPEAT drop
   ( S .. taddr2+skiplencells+skiplenbytes )
   snl-calc ;
 

date.fs

@@ -10,14 +10,14 @@
 
 : j-day2ymd ( day -- y m d )
     1461 /mod 4 * swap
-    365 /mod3 rot + swap
+    365 /mod3 under+
     31 + 5 153 */mod swap 5 / >r
-    2 + dup 12 > IF  12 - swap 1+ swap  THEN
+    2 + dup 12 > IF  12 - 1 under+  THEN
     r> 1+ ;
  
 : (ymd2day) ( y m d -- day year/4 )
     1- -rot
-    2 - dup 0<= IF  12 + swap 1- swap  THEN
+    2 - dup 0<= IF  12 + -1 under+  THEN
     153 5 */mod swap 0= >r 31 - swap
     4 /mod swap 365 * swap >r + + r> swap r> + 1+ swap ;
  
@@ -31,7 +31,7 @@
 : day2ymd ( day -- y m d )
     dup gregorian >= IF
 	2 - 146097 /mod 400 * swap
-	36524 /mod3 100 * rot + swap
+	36524 /mod3 100 * under+
 	j-day2ymd 2>r + 2r>
     ELSE
 	j-day2ymd

fsl-util.fs

@@ -279,7 +279,7 @@ VARIABLE print-width      6 print-width !
 ;
 
 : }}fput ( r11 r12 ... r_nm  n m 'A -- | store r11 ... r_nm into nxm matrix )
-      -ROT 2DUP * >R 1- SWAP 1- SWAP }} R> 
+      -ROT 2DUP * >R 1- -1 UNDER+ }} R> 
       0 ?DO  DUP >R F! R> FLOAT -  LOOP  DROP ;
 
 \ ================= Floating-point local variables ==================

glocals.fs

@@ -212,7 +212,7 @@ opt: drop postpone swap postpone >l postpone >l ;
 : list-length ( list -- u )
     0 swap begin ( u1 list1 )
        dup while
-           name>link swap 1+ swap
+           name>link 1 under+
     repeat
     drop ;
 

gray.fs

@@ -44,7 +44,7 @@ s" address-unit-bits" environment? 0=
   \ if your machine has fewer bits/au, gray will not work
   : (bits/cell)  ( -- n )
       1 0 invert dup 1 rshift xor
-      BEGIN  dup 1 = 0=  WHILE  1 rshift  swap 1+ swap  REPEAT  drop ;
+      BEGIN  dup 1 = 0=  WHILE  1 rshift  1 under+  REPEAT  drop ;
   (bits/cell)
   warnings @ [IF]
       .( You seem to have ) dup 1 cells / . .( bits/address unit) cr

kernel-ec/tools.fs

@@ -100,7 +100,7 @@ include  ./../termsize.fs
 	IF
 	    cr nip 0 swap
 	THEN
-	dup name>string type space r> rot + swap
+	dup name>string type space r> under+
     REPEAT
     2drop ;
 

kernel/stringk.fs

@@ -92,7 +92,7 @@
 
 : $ins ( addr1 u $addr off -- ) \ gforth-string string-ins
     \G inserts a string at offset @var{off}.
-    >r 2dup dup $@len rot + swap $!len  $@ r> safe/string insert ;
+    >r 2dup dup $@len under+ $!len  $@ r> safe/string insert ;
 : $del ( addr off u -- ) \ gforth-string string-del
     \G deletes @var{u} bytes from a string with offset @var{off}.
     >r >r dup $@ r> safe/string r@ delete

libcc.fs

@@ -371,7 +371,7 @@ drop
     2 + ;
 
 : count-stacks-r ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
-    swap 1+ swap ;
+    1 under+ ;
 
 : count-stacks-func ( fp-change1 sp-change1 -- fp-change2 sp-change2 )
     1+ ;

mini-oof2.fs

@@ -104,7 +104,7 @@ dynamic-a to allocater
 : >inherit ( class1 class2 -- class' ) >dynamic swap >osize @ over >osize ! ;
 : class-resize ( class u -- class' ) over >methods @ umax >r
     class>count r@ 2 cells + umax resize throw
-    r@ over cell+ !@ >r 2 cells + r> r> swap
+    r@ over cell+ !@ 2 cells under+ r> swap
     U+DO  ['] default-method defer@ over I + !  cell +LOOP ;
 
 \ dot parser .foo -> >o foo o>

minos2/mkv-tools.fs

@@ -29,10 +29,10 @@ s" Invalid data size" exception constant !!ebml-ds!!
 s" Early terminate scanning" exception constant !!ebml-early!!
 s" Early termination of cue reading" exception Constant !!cueterm!!
 
-: id-8x  24 rshift >r 1+  r> ;
-: id-4x  16 rshift >r 2 + r> ;
-: id-2x   8 rshift >r 3 + r> ;
-: id-1x            >r 4 + r> ;
+: id-8x  24 rshift 1 under+ ;
+: id-4x  16 rshift 2 under+ ;
+: id-2x   8 rshift 3 under+ ;
+: id-1x            4 under+ ;
 : id-00   !!ebml-ds!! throw ;
 Create id@-table
 ' id-00 , ' id-1x , ' id-2x , ' id-2x ,
@@ -44,21 +44,21 @@ Create id@-table
 
 : track@+ ( addr -- addr' id )
     dup be-ul@
-    dup $80000000 and IF  24 rshift     $80 xor >r 1+  r>  EXIT  THEN
-    dup $40000000 and IF  16 rshift   $4000 xor >r 2 + r>  EXIT  THEN
-    dup $20000000 and IF   8 rshift $200000 xor >r 3 + r>  EXIT  THEN
-    dup $10000000 and IF          $10000000 xor >r 4 + r>  EXIT  THEN
+    dup $80000000 and IF  24 rshift     $80 xor 1 under+  EXIT  THEN
+    dup $40000000 and IF  16 rshift   $4000 xor 2 under+  EXIT  THEN
+    dup $20000000 and IF   8 rshift $200000 xor 3 under+  EXIT  THEN
+    dup $10000000 and IF          $10000000 xor 4 under+  EXIT  THEN
     !!ebml-id!! throw ;
 
 cell 8 = [IF]
-    : ds-8x  56 rshift             $7F and >r 1+  r> ;
-    : ds-4x  48 rshift           $3FFF and >r 2 + r> ;
-    : ds-2x  40 rshift         $1FFFFF and >r 3 + r> ;
-    : ds-1x  32 rshift        $FFFFFFF and >r 4 + r> ;
-    : ds-08  24 rshift      $7FFFFFFFF and >r 5 + r> ;
-    : ds-04  16 rshift    $3FFFFFFFFFF and >r 6 + r> ;
-    : ds-02   8 rshift  $1FFFFFFFFFFFF and >r 7 + r> ;
-    : ds-01            $FFFFFFFFFFFFFF and >r 8 + r> ;
+    : ds-8x  56 rshift             $7F and 1 under+ ;
+    : ds-4x  48 rshift           $3FFF and 2 under+ ;
+    : ds-2x  40 rshift         $1FFFFF and 3 under+ ;
+    : ds-1x  32 rshift        $FFFFFFF and 4 under+ ;
+    : ds-08  24 rshift      $7FFFFFFFF and 5 under+ ;
+    : ds-04  16 rshift    $3FFFFFFFFFF and 6 under+ ;
+    : ds-02   8 rshift  $1FFFFFFFFFFFF and 7 under+ ;
+    : ds-01            $FFFFFFFFFFFFFF and 8 under+ ;
     Create ds@-table
     ' id-00 , ' ds-01 , ' ds-02 , ' ds-02 ,
     4 0 [DO] ' ds-04 , [LOOP]
@@ -72,17 +72,17 @@ cell 8 = [IF]
 [ELSE]
     : ds@+ ( addr -- addr' ddatasize )
 	dup be-ul@
-	dup $80000000 and IF  24 rshift     $7F and >r 1+  r> 0 EXIT  THEN
-	dup $40000000 and IF  16 rshift   $3FFF and >r 2 + r> 0 EXIT  THEN
-	dup $20000000 and IF   8 rshift $1FFFFF and >r 3 + r> 0 EXIT  THEN
-	dup $10000000 and IF          $0FFFFFFF and >r 4 + r> 0 EXIT  THEN
-	dup $08000000 and IF          $07FFFFFF and >r 5 + r>
+	dup $80000000 and IF  24 rshift     $7F and 1 under+ 0 EXIT  THEN
+	dup $40000000 and IF  16 rshift   $3FFF and 2 under+ 0 EXIT  THEN
+	dup $20000000 and IF   8 rshift $1FFFFF and 3 under+ 0 EXIT  THEN
+	dup $10000000 and IF          $0FFFFFFF and 4 under+ 0 EXIT  THEN
+	dup $08000000 and IF          $07FFFFFF and 5 under+
 	    over 1 - be-ul@ swap 24 drshift EXIT  THEN
-	dup $04000000 and IF          $03FFFFFF and >r 6 + r>
+	dup $04000000 and IF          $03FFFFFF and 6 under+
 	    over 2 - be-ul@ swap 16 drshift EXIT  THEN
-	dup $02000000 and IF          $01FFFFFF and >r 7 + r>
+	dup $02000000 and IF          $01FFFFFF and 7 under+
 	    over 3 - be-ul@ swap  8 drshift EXIT  THEN
-	dup $01000000 and IF          $00FFFFFF and >r 8 + r>
+	dup $01000000 and IF          $00FFFFFF and 8 under+
 	    over 4 - be-ul@ swap            EXIT  THEN
 	!!ebml-id!! throw ;
 [THEN]
@@ -393,7 +393,7 @@ Variable random-access
 : nal-fill-mts ( addr end pid -- addr' ) { pid }
     >r BEGIN  dup r@ u<  WHILE
 	"\0\0\0\1" pid string>mts
-	    dup be-ul@ >r 4 + r> over + tuck pid fill-mts
+	    dup be-ul@ 4 under+ over + tuck pid fill-mts
 	    tuck - ?dup-if r> swap - >r then
     REPEAT  rdrop ;
 : sei-len ( -- n )  0

minos2/mts-tools.fs

@@ -118,7 +118,7 @@ $1000 Value dump#
     count $E and
     >r dup be-uw@ 2/ r> 15 lshift or
     >r 2 + dup be-uw@ 2/ r> 15 lshift or
-    >r 2 + r> ;
+    2 under+ ;
 
 : .pts ( addr -- addr' ) pts@ s>f 90k f/ f. ;
 
@@ -147,7 +147,7 @@ Variable pns s" " pns $!
     2 +LOOP  drop false ;
 
 : be-w@+ ( addr -- addr' len )
-    dup be-uw@ >r 2 + r> ;
+    dup be-uw@ 2 under+ ;
 
 : p>len ( addr -- addr' len )
     dup be-uw@ $3FF and >r

netlib/netlib.fs

@@ -50,7 +50,7 @@ end-struct sockaddr_in
 : +place ( adr len adr )
         2dup >r >r
         dup c@ char+ + swap move
-        r> r> dup c@ rot + swap c! ;
+        r> r> dup c@ under+ c! ;
 [THEN]
 
 \ ------        IP number conversion                            31dec95jaw
@@ -64,7 +64,7 @@ variable ip-class
         r> r>
         dup 0= IF EXIT THEN
         1 ip-class +!
-        1- swap 1+ swap ;
+        1 /string ;
 
 : dotted>ip     ( adr len -- u )
         0 ip-class !

unix/jni-tools.fs

@@ -51,13 +51,15 @@ attach \ attach this thread
 Create 'args '[' 1+ 'A'
 [DO] ">x" 2dup + 1- [i] swap c! current @ search-wordlist 0= [IF] ' nip [THEN] , [LOOP]
 
-: >args ( x1 .. xn addr u -- ) dup floats callargs @ + -rot
-    swap 1- swap bounds swap U-DO
+: >args ( x1 .. xn addr u -- )
+    dup floats callargs @ + -rot
+    -1 under+ bounds swap U-DO
 	I c@ 'A' - cells 'args + perform
     1 -LOOP  drop ;
 
-: args, ( addr u -- )  dup floats ]] callargs @ Literal + [[
-    swap 1- swap bounds swap U-DO
+: args, ( addr u -- )
+    dup floats ]] callargs @ Literal + [[
+    -1 under+ bounds swap U-DO
 	I c@ 'A' - cells 'args + @ compile,
     1 -LOOP  postpone drop ;
 

wordinfo.fs

@@ -99,7 +99,7 @@ CREATE InfoTable
 : WordInfo ( nfa --- code )
         InfoTable
         BEGIN  dup @ dup
-        WHILE  swap 2 cells + swap
+        WHILE  2 cells under+
                2 pick swap execute
         UNTIL
         cell- @ nip