Commit 0557450e authored by Anton Ertl's avatar Anton Ertl

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

parent 9dfd83dc
......@@ -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
......
......@@ -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
- ;
......
......@@ -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, ;
......
......@@ -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 ;
......
......@@ -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
......
......@@ -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 ! ;
......
......@@ -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 ;
......
......@@ -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<> ;
......
......@@ -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
......
......@@ -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
......
......@@ -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<> ;
......
......@@ -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 ;
......
......@@ -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 ;
......
......@@ -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
......
......@@ -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 ==================
......
......@@ -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 ;
......
......@@ -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
......
......@@ -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 ;
......
......@@ -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
......
......@@ -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+ ;
......
......@@ -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>
......
......@@ -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
......
......@@ -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
......
......@@ -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 !
......
......@@ -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 ;
......
......@@ -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
......
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