Public feed #530863

new do loop for spf

public text v1 · immutable
Raw Edit
·published 2007-06-02 08:26 UTC
rendered paste body
\ 22-02-2007 ~mOleg
\ Copyright [C] 2006-2007 mOleg mininoleg@yahoo.com
\ циклы DO LOOP для СПФ - портабельный вариант.

REQUIRE /TEST ~profit/lib/testing.f
REQUIRE vocLocalsSupport lib/ext/locals.f

MODULE: mOleg-DO-LOOP

\ ---------------------------------------------------------------------------

\ на стеке возвратов лежит 4-ре параметра.
\ адрес выхода из слова
\ верхний предел счета
\ счетчик цикла
\ адрес выхода за LOOP метку

\ установили параметры цикла - выполняется один раз на входе
: (DO) ( up low --> ) R> -ROT 2>R ['] LEAVE >R >R ;

\ приращение счетчика цикла, проверка условия выхода из цикла. »
: (+LOOP) ( n --> flag )
          DUP 0 < IF    2R> ROT R> + R@ OVER >R <
                   ELSE 2R> ROT R> + R@ OVER >R < 0=
                  THEN -ROT 2>R ;

\ ---------------------------------------------------------------------------
EXPORT

WARNING @ WARNING 0!

\ &#1101;&#1082;&#1089;&#1090;&#1088;&#1077;&#1085;&#1085;&#1099;&#1081; &#1074;&#1099;&#1093;&#1086;&#1076; &#1080;&#1079; &#1094;&#1080;&#1082;&#1083;&#1072;
: LEAVE ( --> ) RDROP RDROP RDROP RDROP ;

\ &#1074;&#1077;&#1088;&#1085;&#1091;&#1083;&#1080; &#1089;&#1095;&#1077;&#1090;&#1095;&#1080;&#1082; &#1090;&#1077;&#1082;&#1091;&#1097;&#1077;&#1075;&#1086; &#1094;&#1080;&#1082;&#1083;&#1072;
: I ( --> index )
    \ 2R> R@ -ROT 2>R
    2 CELLS RP+@ ;

\ &#1074;&#1077;&#1088;&#1085;&#1091;&#1090;&#1100; &#1089;&#1095;&#1077;&#1090;&#1095;&#1080;&#1082; &#1074;&#1085;&#1077;&#1096;&#1085;&#1077;&#1075;&#1086; &#1094;&#1080;&#1082;&#1083;&#1072;.
: J ( --> ext_index ) 6 CELLS RP+@ ;

\ &#1085;&#1072;&#1095;&#1072;&#1090;&#1100; &#1074;&#1099;&#1087;&#1086;&#1083;&#1085;&#1077;&#1085;&#1080;&#1077; &#1094;&#1080;&#1082;&#1083;&#1072;, &#1080;&#1085;&#1080;&#1094;&#1080;&#1072;&#1083;&#1080;&#1079;&#1088;&#1086;&#1074;&#1072;&#1090;&#1100; &#1089;&#1095;&#1077;&#1090;&#1095;&#1080;&#1082; &#1094;&#1080;&#1082;&#1083;&#1072;
: DO ( up low --> )
     ?COMP
     HERE 0 RLIT, 1 + \ &#1079;&#1072;&#1075;&#1088;&#1091;&#1079;&#1082;&#1072; &#1072;&#1076;&#1088;&#1077;&#1089;&#1072; &#1074;&#1099;&#1093;&#1086;&#1076;&#1072; &#1087;&#1086; LEAVE
     ['] (DO) _COMPILE,
     0
     [COMPILE] BEGIN ; IMMEDIATE

\ &#1085;&#1072;&#1095;&#1072;&#1090;&#1100; &#1074;&#1099;&#1087;&#1086;&#1083;&#1085;&#1077;&#1085;&#1080;&#1077; &#1094;&#1080;&#1082;&#1083;&#1072; &#1089; &#1087;&#1088;&#1077;&#1076;&#1091;&#1089;&#1083;&#1086;&#1074;&#1080;&#1077;&#1084; - &#1077;&#1089;&#1083;&#1080; up &#1084;&#1077;&#1085;&#1100;&#1096;&#1077; low
\ &#1074;&#1099;&#1087;&#1086;&#1083;&#1085;&#1077;&#1085;&#1080;&#1077; &#1094;&#1080;&#1082;&#1083;&#1072; &#1086;&#1090;&#1084;&#1077;&#1085;&#1103;&#1077;&#1090;&#1089;&#1103;
: ?DO ( up low -->  )
      ?COMP
      HERE 0 RLIT, 1 + \ &#1079;&#1072;&#1075;&#1088;&#1091;&#1079;&#1082;&#1072; &#1072;&#1076;&#1088;&#1077;&#1089;&#1072; &#1074;&#1099;&#1093;&#1086;&#1076;&#1072; &#1087;&#1086; LEAVE
      POSTPONE 2DUP POSTPONE > [COMPILE] IF
     ['] (DO) _COMPILE,
      [COMPILE] BEGIN ; IMMEDIATE

\ &#1084;&#1077;&#1089;&#1090;&#1086; &#1079;&#1072;&#1074;&#1077;&#1088;&#1096;&#1077;&#1085;&#1080;&#1103; &#1080;&#1083;&#1080; &#1087;&#1086;&#1074;&#1090;&#1086;&#1088;&#1077;&#1085;&#1080;&#1103; &#1094;&#1080;&#1082;&#1083;&#1072;, &#1085;&#1072;&#1095;&#1072;&#1090;&#1086;&#1075;&#1086; &#1086;&#1087;&#1080;&#1089;&#1072;&#1090;&#1077;&#1083;&#1077;&#1084; DO &#1080;&#1083;&#1080; ?DO
\ &#1087;&#1088;&#1080;&#1088;&#1072;&#1097;&#1077;&#1085;&#1080;&#1077; &#1089;&#1095;&#1077;&#1090;&#1095;&#1080;&#1082;&#1072; &#1094;&#1080;&#1082;&#1083;&#1072; &#1086;&#1087;&#1088;&#1077;&#1076;&#1077;&#1083;&#1103;&#1077;&#1090;&#1089;&#1103; &#1089;&#1086;&#1076;&#1077;&#1088;&#1078;&#1080;&#1084;&#1099;&#1084; &#1074;&#1077;&#1088;&#1093;&#1085;&#1077;&#1075;&#1086;
\ &#1101;&#1083;&#1077;&#1084;&#1077;&#1085;&#1090;&#1072; &#1089;&#1090;&#1077;&#1082;&#1072; &#1076;&#1072;&#1085;&#1085;&#1099;&#1093;
: +LOOP ( n --> )
        ?COMP
        POSTPONE (+LOOP)
        [COMPILE] UNTIL
                  POSTPONE RDROP POSTPONE RDROP POSTPONE RDROP POSTPONE RDROP

        DUP IF [COMPILE] ELSE POSTPONE 2DROP POSTPONE RDROP [COMPILE] THEN
             ELSE DROP
            THEN
        HERE SWAP !

        ; IMMEDIATE

\ &#1084;&#1077;&#1089;&#1090;&#1086; &#1079;&#1072;&#1074;&#1077;&#1088;&#1096;&#1077;&#1085;&#1080;&#1103; &#1080;&#1083;&#1080; &#1087;&#1086;&#1074;&#1090;&#1086;&#1088;&#1077;&#1085;&#1080;&#1103; &#1094;&#1080;&#1082;&#1083;&#1072;, &#1085;&#1072;&#1095;&#1072;&#1090;&#1086;&#1075;&#1086; &#1086;&#1087;&#1080;&#1089;&#1072;&#1090;&#1077;&#1083;&#1077;&#1084; DO &#1080;&#1083;&#1080; ?DO
\ &#1087;&#1088;&#1080;&#1088;&#1072;&#1097;&#1077;&#1085;&#1080;&#1077; &#1089;&#1095;&#1077;&#1090;&#1095;&#1080;&#1082;&#1072; &#1094;&#1080;&#1082;&#1083;&#1072; = 1
: LOOP ( --> ) ?COMP 1 LIT, [COMPILE] +LOOP ; IMMEDIATE

\ &#1059;&#1073;&#1088;&#1072;&#1090;&#1100; &#1087;&#1072;&#1088;&#1072;&#1084;&#1077;&#1090;&#1088;&#1099; &#1094;&#1080;&#1082;&#1083;&#1072; &#1090;&#1077;&#1082;&#1091;&#1097;&#1077;&#1075;&#1086; &#1091;&#1088;&#1086;&#1074;&#1085;&#1103;. UNLOOP &#1090;&#1088;&#1077;&#1073;&#1091;&#1077;&#1090;&#1089;&#1103; &#1076;&#1083;&#1103; &#1082;&#1072;&#1078;&#1076;&#1086;&#1075;&#1086;
\ &#1091;&#1088;&#1086;&#1074;&#1085;&#1103; &#1074;&#1083;&#1086;&#1078;&#1077;&#1085;&#1080;&#1103; &#1094;&#1080;&#1082;&#1083;&#1086;&#1074; &#1087;&#1077;&#1088;&#1077;&#1076; &#1074;&#1099;&#1093;&#1086;&#1076;&#1086;&#1084; &#1080;&#1079; &#1086;&#1087;&#1088;&#1077;&#1076;&#1077;&#1083;&#1077;&#1085;&#1080;&#1103; &#1087;&#1086; EXIT.
: UNLOOP ( --> ) R> RDROP RDROP RDROP RDROP >R ;

\ ===
\ &#1087;&#1077;&#1088;&#1077;&#1086;&#1087;&#1088;&#1077;&#1076;&#1077;&#1083;&#1077;&#1085;&#1080;&#1077; &#1089;&#1086;&#1086;&#1090;&#1074;&#1077;&#1090;&#1089;&#1090;&#1074;&#1091;&#1102;&#1097;&#1080;&#1093; &#1089;&#1083;&#1086;&#1074; &#1076;&#1083;&#1103; &#1074;&#1086;&#1079;&#1084;&#1086;&#1078;&#1085;&#1086;&#1089;&#1090;&#1080; &#1080;&#1089;&#1087;&#1086;&#1083;&#1100;&#1079;&#1086;&#1074;&#1072;&#1090;&#1100;
\ &#1074;&#1088;&#1077;&#1084;&#1077;&#1085;&#1085;&#1099;&#1077; &#1087;&#1077;&#1088;&#1077;&#1084;&#1077;&#1085;&#1085;&#1099;&#1077; &#1074;&#1085;&#1091;&#1090;&#1088;&#1080;  &#1094;&#1080;&#1082;&#1083;&#1072; DO LOOP  &#1080; &#1085;&#1077;&#1079;&#1072;&#1074;&#1080;&#1089;&#1080;&#1084;&#1086; &#1086;&#1090; &#1080;&#1079;&#1084;&#1077;&#1085;&#1077;&#1085;&#1080;&#1103;
\ &#1089;&#1086;&#1076;&#1077;&#1088;&#1078;&#1080;&#1084;&#1086;&#1075;&#1086; &#1089;&#1090;&#1077;&#1082;&#1072; &#1074;&#1086;&#1079;&#1074;&#1088;&#1072;&#1090;&#1086;&#1074;  &#1089;&#1083;&#1086;&#1074;&#1072;&#1084;&#1080;   >R   R>

{{ vocLocalsSupport DEFINITIONS

: DO    FORTH::POSTPONE DO     [  4 CELLS ] LITERAL  uAddDepth +! ;; IMMEDIATE
: ?DO   FORTH::POSTPONE ?DO    [  4 CELLS ] LITERAL  uAddDepth +! ;; IMMEDIATE
: LOOP  FORTH::POSTPONE LOOP   [ -4 CELLS ] LITERAL  uAddDepth +! ;; IMMEDIATE
: +LOOP FORTH::POSTPONE +LOOP  [ -4 CELLS ] LITERAL  uAddDepth +! ;; IMMEDIATE
: >R    FORTH::POSTPONE >R     [  1 CELLS ] LITERAL  uAddDepth +! ;; IMMEDIATE
: R>    FORTH::POSTPONE R>     [ -1 CELLS ] LITERAL  uAddDepth +! ;; IMMEDIATE
: RDROP FORTH::POSTPONE RDROP  [ -1 CELLS ] LITERAL  uAddDepth +! ;; IMMEDIATE
\ ===
}}

WARNING !

;MODULE

/TEST

REQUIRE TESTCASES ~ygrek/lib/testcase.f
REQUIRE TYPE>STR ~ygrek/lib/typestr.f

TESTCASES DO-LOOP

:NONAME 10 0 ." [" ?DO I . LOOP ." ]" ; TYPE>STR STR@
S" [0 1 2 3 4 5 6 7 8 9 ]" TEST-ARRAY

:NONAME 0 0  ." [" ?DO I . LOOP ." ]" ; TYPE>STR STR@
S" []" TEST-ARRAY

:NONAME 10 0 ." [" ?DO I . EXIT LOOP ." ]" ; TYPE>STR STR@
S" [0 " TEST-ARRAY

:NONAME 10 0 ." [" ?DO I . LEAVE LOOP ." ]" ; TYPE>STR STR@
S" [0 ]" TEST-ARRAY

:NONAME 10 0 DO CR 10 0 DO J . I . SPACE LOOP LOOP ; TYPE>STR STR@ "
0 0  0 1  0 2  0 3  0 4  0 5  0 6  0 7  0 8  0 9  
1 0  1 1  1 2  1 3  1 4  1 5  1 6  1 7  1 8  1 9  
2 0  2 1  2 2  2 3  2 4  2 5  2 6  2 7  2 8  2 9  
3 0  3 1  3 2  3 3  3 4  3 5  3 6  3 7  3 8  3 9  
4 0  4 1  4 2  4 3  4 4  4 5  4 6  4 7  4 8  4 9  
5 0  5 1  5 2  5 3  5 4  5 5  5 6  5 7  5 8  5 9  
6 0  6 1  6 2  6 3  6 4  6 5  6 6  6 7  6 8  6 9  
7 0  7 1  7 2  7 3  7 4  7 5  7 6  7 7  7 8  7 9  
8 0  8 1  8 2  8 3  8 4  8 5  8 6  8 7  8 8  8 9  
9 0  9 1  9 2  9 3  9 4  9 5  9 6  9 7  9 8  9 9  " STR@ TEST-ARRAY

:NONAME 10 0 DO CR 10 0 DO J . I . SPACE LEAVE LOOP LOOP ; TYPE>STR STR@ "
0 0  
1 0  
2 0  
3 0  
4 0  
5 0  
6 0  
7 0  
8 0  
9 0  " STR@ TEST-ARRAY
 
:NONAME ." [" 10 0 DO ." |" I . I 5 = IF UNLOOP EXIT THEN LOOP ." ]" ; TYPE>STR STR@
S" [|0 |1 |2 |3 |4 |5 " TEST-ARRAY

10 :NONAME { a -- } ." [" 10 0 DO I a + . LOOP ." ]" ; TYPE>STR STR@
S" [10 11 12 13 14 15 16 17 18 19 ]" TEST-ARRAY

END-TESTCASES