Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.28 | \ Copyright (C) 1995,1998,2000,2003,2005,2007,2009,2010 Free Software Foundation, Inc. |
| 2 : | anton | 1.1 | |
| 3 : | \ This file is part of Gforth. | ||
| 4 : | |||
| 5 : | \ Gforth is free software; you can redistribute it and/or | ||
| 6 : | \ modify it under the terms of the GNU General Public License | ||
| 7 : | anton | 1.22 | \ as published by the Free Software Foundation, either version 3 |
| 8 : | anton | 1.1 | \ of the License, or (at your option) any later version. |
| 9 : | |||
| 10 : | \ This program is distributed in the hope that it will be useful, | ||
| 11 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 12 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 13 : | \ GNU General Public License for more details. | ||
| 14 : | |||
| 15 : | \ You should have received a copy of the GNU General Public License | ||
| 16 : | anton | 1.22 | \ along with this program. If not, see http://www.gnu.org/licenses/. |
| 17 : | anton | 1.1 | |
| 18 : | jwilke | 1.3 | Warnings off |
| 19 : | anton | 1.1 | |
| 20 : | Variable countif | ||
| 21 : | |||
| 22 : | : dummy ; immediate | ||
| 23 : | : >exec >r ; restrict ( :-) | ||
| 24 : | anton | 1.10 | : scanIF f83find dup 0= IF drop ['] dummy >head-noprim THEN ; |
| 25 : | anton | 1.1 | |
| 26 : | jwilke | 1.2 | Create [struct]-search ' scanIF A, ' (reveal) A, ' drop A, ' drop A, |
| 27 : | pazsan | 1.5 | Create [struct]-voc [struct]-search A, |
| 28 : | NIL A, NIL A, NIL A, | ||
| 29 : | anton | 1.1 | |
| 30 : | : ?if countif @ 0< | ||
| 31 : | IF [ [struct]-voc 3 cells + ] ALiteral @ lookup ! THEN ; | ||
| 32 : | |||
| 33 : | UNLOCK Tlast @ TNIL Tlast ! LOCK | ||
| 34 : | \ last @ 0 last ! | ||
| 35 : | |||
| 36 : | crook | 1.8 | : [IF] |
| 37 : | 1 countif +! ?if ; immediate | ||
| 38 : | : [THEN] | ||
| 39 : | -1 countif +! ?if ; immediate | ||
| 40 : | : [ELSE] | ||
| 41 : | anton | 1.26 | postpone [THEN] postpone [IF] ; immediate |
| 42 : | |||
| 43 : | anton | 1.1 | ' [IF] Alias [IFDEF] immediate |
| 44 : | ' [IF] Alias [IFUNDEF] immediate | ||
| 45 : | crook | 1.8 | ' [THEN] Alias [ENDIF] immediate |
| 46 : | anton | 1.1 | ' [IF] Alias [BEGIN] immediate |
| 47 : | ' [IF] Alias [WHILE] immediate | ||
| 48 : | ' [THEN] Alias [UNTIL] immediate | ||
| 49 : | ' [THEN] Alias [AGAIN] immediate | ||
| 50 : | ' [IF] Alias [DO] immediate | ||
| 51 : | ' [IF] Alias [?DO] immediate | ||
| 52 : | ' [THEN] Alias [LOOP] immediate | ||
| 53 : | ' [THEN] Alias [+LOOP] immediate | ||
| 54 : | : [REPEAT] postpone [AGAIN] postpone [THEN] ; | ||
| 55 : | immediate | ||
| 56 : | anton | 1.17 | \ The following was too smart for its own good; consider "postpone (". |
| 57 : | \ Moreover, ANS Forth specifies that the next [THEN] ends an [IF] | ||
| 58 : | \ (even if its in a '( ... )'). | ||
| 59 : | |||
| 60 : | \ ' ( Alias ( immediate ( keep fontify happy) | ||
| 61 : | \ ' \ Alias \ immediate | ||
| 62 : | anton | 1.1 | |
| 63 : | UNLOCK Tlast @ swap Tlast ! LOCK | ||
| 64 : | \ last @ swap last ! | ||
| 65 : | pazsan | 1.5 | 1 cells - [struct]-voc cell+ ! |
| 66 : | anton | 1.1 | |
| 67 : | \ Interpretative Structuren 30apr92py | ||
| 68 : | |||
| 69 : | anton | 1.27 | : [defined] ( "<spaces>name" -- flag ) parse-name find-name 0<> ; immediate |
| 70 : | pazsan | 1.13 | \G returns true if name is found in current search order |
| 71 : | anton | 1.14 | ' [defined] alias defined immediate |
| 72 : | pazsan | 1.13 | : [undefined] ( "<spaces>name" -- flag ) postpone [defined] 0= ; immediate |
| 73 : | \G returns false if name is found in current search order | ||
| 74 : | crook | 1.8 | |
| 75 : | pazsan | 1.13 | : [IF] ( flag -- ) \ tools-ext bracket-if |
| 76 : | crook | 1.8 | \G If flag is @code{TRUE} do nothing (and therefore |
| 77 : | \G execute subsequent words as normal). If flag is @code{FALSE}, | ||
| 78 : | \G parse and discard words from the parse | ||
| 79 : | \G area (refilling it if necessary using | ||
| 80 : | \G @code{REFILL}) including nested instances of @code{[IF]}.. | ||
| 81 : | \G @code{[ELSE]}.. @code{[THEN]} and @code{[IF]}.. @code{[THEN]} | ||
| 82 : | \G until the balancing @code{[ELSE]} or @code{[THEN]} has been | ||
| 83 : | \G parsed and discarded. Immediate word. | ||
| 84 : | 0= IF countif off | ||
| 85 : | anton | 1.1 | lookup @ [ [struct]-voc 3 cells + ] ALiteral ! |
| 86 : | [struct]-voc lookup ! | ||
| 87 : | THEN ; immediate | ||
| 88 : | crook | 1.8 | |
| 89 : | : [IFDEF] ( "<spaces>name" -- ) \ gforth bracket-if-def | ||
| 90 : | \G If name is found in the current search-order, behave like | ||
| 91 : | crook | 1.9 | \G @code{[IF]} with a @code{TRUE} flag, otherwise behave like |
| 92 : | crook | 1.8 | \G @code{[IF]} with a @code{FALSE} flag. Immediate word. |
| 93 : | pazsan | 1.13 | postpone [defined] postpone [IF] ; immediate |
| 94 : | crook | 1.8 | |
| 95 : | : [IFUNDEF] ( "<spaces>name" -- ) \ gforth bracket-if-un-def | ||
| 96 : | \G If name is not found in the current search-order, behave like | ||
| 97 : | crook | 1.9 | \G @code{[IF]} with a @code{TRUE} flag, otherwise behave like |
| 98 : | crook | 1.8 | \G @code{[IF]} with a @code{FALSE} flag. Immediate word. |
| 99 : | pazsan | 1.13 | postpone [defined] 0= postpone [IF] ; immediate |
| 100 : | crook | 1.8 | |
| 101 : | pazsan | 1.13 | : [ELSE] ( -- ) \ tools-ext bracket-else |
| 102 : | crook | 1.8 | \G Parse and discard words from the parse |
| 103 : | \G area (refilling it if necessary using | ||
| 104 : | \G @code{REFILL}) including nested instances of @code{[IF]}.. | ||
| 105 : | \G @code{[ELSE]}.. @code{[THEN]} and @code{[IF]}.. @code{[THEN]} | ||
| 106 : | \G until the balancing @code{[THEN]} has been parsed and discarded. | ||
| 107 : | \G @code{[ELSE]} only gets executed if the balancing @code{[IF]} | ||
| 108 : | \G was @code{TRUE}; if it was @code{FALSE}, @code{[IF]} would | ||
| 109 : | \G have parsed and discarded the @code{[ELSE]}, leaving the | ||
| 110 : | \G subsequent words to be executed as normal. | ||
| 111 : | \G Immediate word. | ||
| 112 : | 0 postpone [IF] ; immediate | ||
| 113 : | |||
| 114 : | : [THEN] ( -- ) \ tools-ext bracket-then | ||
| 115 : | \G Do nothing; used as a marker for other words to parse | ||
| 116 : | crook | 1.9 | \G and discard up to. Immediate word. |
| 117 : | crook | 1.8 | ; immediate |
| 118 : | |||
| 119 : | : [ENDIF] ( -- ) \ gforth bracket-end-if | ||
| 120 : | crook | 1.9 | \G Do nothing; synonym for @code{[THEN]} |
| 121 : | crook | 1.8 | ; immediate |
| 122 : | anton | 1.1 | |
| 123 : | \ Structs for interpreter 28nov92py | ||
| 124 : | |||
| 125 : | User (i) | ||
| 126 : | |||
| 127 : | crook | 1.8 | : [DO] ( n-limit n-index -- ) \ gforth bracket-do |
| 128 : | >in @ -rot | ||
| 129 : | anton | 1.1 | DO I (i) ! dup >r >in ! interpret r> swap +LOOP drop ; |
| 130 : | immediate | ||
| 131 : | crook | 1.8 | |
| 132 : | : [?DO] ( n-limit n-index -- ) \ gforth bracket-question-do | ||
| 133 : | 2dup = IF 2drop postpone [ELSE] ELSE postpone [DO] THEN ; | ||
| 134 : | anton | 1.1 | immediate |
| 135 : | crook | 1.8 | |
| 136 : | : [+LOOP] ( n -- ) \ gforth bracket-question-plus-loop | ||
| 137 : | pazsan | 1.29 | rdrop lp+ ; immediate |
| 138 : | crook | 1.8 | |
| 139 : | : [LOOP] ( -- ) \ gforth bracket-loop | ||
| 140 : | pazsan | 1.29 | 1 rdrop lp+ ; immediate |
| 141 : | crook | 1.8 | |
| 142 : | : [FOR] ( n -- ) \ gforth bracket-for | ||
| 143 : | 0 swap postpone [DO] ; immediate | ||
| 144 : | |||
| 145 : | : [NEXT] ( n -- ) \ gforth bracket-next | ||
| 146 : | pazsan | 1.29 | -1 rdrop lp+ ; immediate |
| 147 : | crook | 1.8 | |
| 148 : | pazsan | 1.4 | :noname (i) @ ; |
| 149 : | :noname (i) @ postpone Literal ; | ||
| 150 : | crook | 1.8 | interpret/compile: [I] ( -- n ) \ gforth bracket-i |
| 151 : | |||
| 152 : | : [BEGIN] ( -- ) \ gforth bracket-begin | ||
| 153 : | pazsan | 1.29 | >in @ >r BEGIN r@ >in ! interpret UNTIL rdrop lp+ ; immediate |
| 154 : | crook | 1.8 | |
| 155 : | ' [+LOOP] Alias [UNTIL] ( flag -- ) \ gforth bracket-until | ||
| 156 : | anton | 1.1 | immediate |
| 157 : | crook | 1.8 | |
| 158 : | : [REPEAT] ( -- ) \ gforth bracket-repeat | ||
| 159 : | pazsan | 1.29 | false rdrop lp+ ; immediate |
| 160 : | crook | 1.8 | |
| 161 : | ' [REPEAT] Alias [AGAIN] ( -- ) \ gforth bracket-again | ||
| 162 : | immediate | ||
| 163 : | |||
| 164 : | : [WHILE] ( flag -- ) \ gforth bracket-while | ||
| 165 : | pazsan | 1.29 | 0= IF postpone [ELSE] true rdrop lp+ 1 countif +! THEN ; |
| 166 : | anton | 1.1 | immediate |
| 167 : | |||
| 168 : | pazsan | 1.24 | \ Warnings on |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |