discp.f

   1 \ Listing in "Towards a Discipline of ANS Forth Programming"\r
   2 \ Originally published in Forth Dimensions XVIII, No.4, pp5-14\r
   3 \ Adapted to hForth v0.9.9 by Wonyong Koh\r
   4 \   An ANS compliance problem in v0.9.7 is fixed now.\r
   5 \   'dest+' should not be necessary.\r
   6 \r
   7 \ Dijkstra Guarded Command Control Structures\r
   8 \ M. Edward Borasky\r
   9 \ 03-AUG-96\r
  10 \\r
  11 \ Environmental dependencies:\r
  12 \\r
  13 \ Requires AGAIN from the CORE EXT word set\r
  14 \ Requires AHEAD from the TOOLS EXT word set\r
  15 \ Requires CS-PICK from the TOOLS EXT word set\r
  16 \ Requires CS-ROLL from the TOOLS EXT word set\r
  17 \ Requires PICK from the CORE EXT word set\r
  18 \ Requires ROLL from the CORE EXT word set\r
  19 \ Requires THROW from the EXCEPTION word set\r
  20 \ Requires hForth word COMPILE-ONLY or equivalent\r
  21 \ Requires .( from CORE EXT word set (test sequence only)\r
  22 \r
  23 \ hForth has the capability to flag a word COMPILE-ONLY.  On\r
  24 \ other systems, COMPILE-ONLY can be ignored by defining it as\r
  25 \ follows:\r
  26 \r
  27 BL WORD COMPILE-ONLY FIND NIP 0= [IF]\r
  28         : COMPILE-ONLY ;\r
  29 [THEN]\r
  30 \r
  31 : {IF \ start a conditional\r
  32         ( -- 0 )\r
  33 \r
  34         0 \ put counter on stack\r
  35 ; COMPILE-ONLY IMMEDIATE\r
  36 \r
  37 : IF> \ right-arrow for {IF ... FI}\r
  38         ( count -- count+1 )\r
  39         ( C: -- orig1 )\r
  40 \r
  41         1+ >R \ increment and save count\r
  42         POSTPONE IF \ create orig1\r
  43         R> \ restore count\r
  44 ; COMPILE-ONLY IMMEDIATE\r
  45 \r
  46 : |IF| \ bar for {IF ... FI}\r
  47         ( count -- count )\r
  48         ( C: orig ... orig1 -- orig ... orig2 )\r
  49 \r
  50         >R \ save count\r
  51         POSTPONE AHEAD \ new orig\r
  52         1 CS-ROLL \ old orig to top of CFStack\r
  53         POSTPONE THEN \ resolve old orig\r
  54         R> \ restore count\r
  55 ; COMPILE-ONLY IMMEDIATE\r
  56 \r
  57 : BAD{IF...FI} \ abort if there is no TRUE condition\r
  58         ( -- )\r
  59 \r
  60         CR ." {IF ... FI}: no TRUE condition" CR \ error message\r
  61         -22 THROW \ 'control structure mismatch'\r
  62 ;\r
  63 \r
  64 : FI} \ end of conditional\r
  65         ( count -- )\r
  66         ( C: orig1 ... orign -- )\r
  67 \r
  68         >R \ save count\r
  69         POSTPONE AHEAD \ new orig\r
  70         1 CS-ROLL \ old orig\r
  71         POSTPONE THEN \ resolve old orig\r
  72 \r
  73         \ if we got here, none of the guards were TRUE\r
  74         \ so abort\r
  75         POSTPONE BAD{IF...FI} \ compile the abort\r
  76         R> \ restore count\r
  77 \r
  78         0 ?DO \ resolve all remaining origs\r
  79                 POSTPONE THEN\r
  80         LOOP\r
  81 ; COMPILE-ONLY IMMEDIATE\r
  82 \r
  83 : {DO \ start a loop\r
  84         ( C: -- dest )\r
  85 \r
  86         POSTPONE BEGIN \ create dest\r
  87 ; COMPILE-ONLY IMMEDIATE\r
  88 \r
  89 : DO> \ right arrow for {DO ... OD}\r
  90         ( C: dest -- orig1 dest )\r
  91 \r
  92         POSTPONE IF \ create orig\r
  93         1 CS-ROLL \ bring dest back to top of CFStack\r
  94 ; COMPILE-ONLY IMMEDIATE\r
  95 \r
  96 : |DO| \ bar for {DO ... OD}\r
  97         ( C: orig1 dest -- dest )\r
  98 \r
  99         0 CS-PICK \ copy the dest\r
 100         POSTPONE AGAIN \ resolve the copy\r
 101         1 CS-ROLL \ old orig\r
 102         POSTPONE THEN \ resolve old orig\r
 103 ; COMPILE-ONLY IMMEDIATE\r
 104 \r
 105 : OD} \ end of loop\r
 106         ( C: orig dest -- )\r
 107         POSTPONE AGAIN \ resolve dest\r
 108         POSTPONE THEN \ resolve orig\r
 109 ; COMPILE-ONLY IMMEDIATE\r
 110 \r
 111 \r
 112 \ Simple test words\r
 113 \r
 114 : TEST1 \ print the relationship between 'x' and 'y'\r
 115         ( x y -- )\r
 116 \r
 117         {IF\r
 118                 2DUP = IF> CR ." = "\r
 119         |IF|\r
 120                 2DUP > IF> CR ." > "\r
 121         |IF|\r
 122                 2DUP < IF> CR ." < "\r
 123         FI}\r
 124         2DROP\r
 125 ;\r
 126 \r
 127 \ execute TEST1 for all three combinations\r
 128 \r
 129 CR .( 5 0 TEST1 )\r
 130 5 0 TEST1\r
 131 \r
 132 CR .( 5 5 TEST1 )\r
 133 5 5 TEST1\r
 134 \r
 135 CR .( 0 5 TEST1 )\r
 136 0 5 TEST1\r
 137 \r
 138 : TEST2 \ deliberately erroneous test case --\r
 139         \ 'equal' case left out!\r
 140         ( x y -- )\r
 141 \r
 142         {IF\r
 143                 2DUP < IF> CR ." < "\r
 144         |IF|\r
 145                 2DUP > IF> CR ." > "\r
 146         FI}\r
 147         2DROP\r
 148 ;\r
 149 \r
 150 CR .( Since TEST2 aborts if 'x' and 'y' are equal, we will )\r
 151 CR .( test TEST2 later; first we will compile and test USEFUL )\r
 152 \r
 153 \ define arguments\r
 154 VARIABLE x  5 6553 * x !\r
 155 VARIABLE y 6551 5 * y !\r
 156 \r
 157 : USEFUL \ sets both 'x' and 'y' to GCD(x, y)\r
 158         ( -- )\r
 159 \r
 160         {DO\r
 161                 x @ y @ > DO> y @ NEGATE x +!\r
 162         |DO|\r
 163                 y @ x @ > DO> x @ NEGATE y +!\r
 164         OD}\r
 165 ;\r
 166 \r
 167 CR .( Before: x, y = ) x @ . y @ . CR\r
 168 CR .( USEFUL ) USEFUL\r
 169 CR .( After: x, y = ) x @ . y @ . CR\r
 170 \r
 171 CR .( Now we'll test TEST2 )\r
 172 \r
 173 CR .( 5 0 TEST2 )\r
 174 5 0 TEST2\r
 175 \r
 176 CR .( 0 5 TEST2 )\r
 177 0 5 TEST2\r
 178 \r
 179 CR .( 5 5 TEST2 )\r
 180 5 5 TEST2\r