| 1 | \ @(#) t_corex.fth 98/03/16 1.2 |
| 2 | \ Test ANS Forth Core Extensions |
| 3 | \ |
| 4 | \ Copyright 1994 3DO, Phil Burk |
| 5 | |
| 6 | INCLUDE? }T{ t_tools.fth |
| 7 | |
| 8 | ANEW TASK-T_COREX.FTH |
| 9 | |
| 10 | DECIMAL |
| 11 | |
| 12 | TEST{ |
| 13 | |
| 14 | \ ========================================================== |
| 15 | T{ 1 2 3 }T{ 1 2 3 }T |
| 16 | |
| 17 | \ ----------------------------------------------------- .( |
| 18 | T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T |
| 19 | |
| 20 | CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR |
| 21 | |
| 22 | T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T |
| 23 | |
| 24 | \ ----------------------------------------------------- 0<> |
| 25 | T{ 5 0<> }T{ TRUE }T |
| 26 | T{ 0 0<> }T{ 0 }T |
| 27 | T{ -1000 0<> }T{ TRUE }T |
| 28 | |
| 29 | \ ----------------------------------------------------- 2>R 2R> 2R@ |
| 30 | : T2>R ( -- .... ) |
| 31 | 17 |
| 32 | 20 5 2>R |
| 33 | 19 |
| 34 | 2R@ |
| 35 | 37 |
| 36 | 2R> |
| 37 | \ 2>R should be the equivalent of SWAP >R >R so this next construct |
| 38 | \ should reduce to a SWAP. |
| 39 | 88 77 2>R R> R> |
| 40 | ; |
| 41 | T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T |
| 42 | |
| 43 | \ ----------------------------------------------------- :NONAME |
| 44 | T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T |
| 45 | |
| 46 | \ ----------------------------------------------------- <> |
| 47 | T{ 12345 12305 <> }T{ TRUE }T |
| 48 | T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T |
| 49 | |
| 50 | \ ----------------------------------------------------- ?DO |
| 51 | : T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ; |
| 52 | T{ 0 T?DO }T{ 0 }T |
| 53 | T{ 4 T?DO }T{ 10 }T |
| 54 | |
| 55 | \ ----------------------------------------------------- AGAIN |
| 56 | : T.AGAIN ( n -- ) |
| 57 | BEGIN |
| 58 | DUP . |
| 59 | DUP 6 < IF EXIT THEN |
| 60 | 1- |
| 61 | AGAIN |
| 62 | ; |
| 63 | T{ 10 T.AGAIN CR }T{ 5 }T |
| 64 | |
| 65 | \ ----------------------------------------------------- C" |
| 66 | : T.C" ( -- $STRING ) |
| 67 | C" x5&" |
| 68 | ; |
| 69 | T{ T.C" C@ }T{ 3 }T |
| 70 | T{ T.C" COUNT DROP C@ }T{ CHAR x }T |
| 71 | T{ T.C" COUNT DROP CHAR+ C@ }T{ CHAR 5 }T |
| 72 | T{ T.C" COUNT DROP 2 CHARS + C@ }T{ CHAR & }T |
| 73 | |
| 74 | \ ----------------------------------------------------- CASE |
| 75 | : T.CASE ( N -- ) |
| 76 | CASE |
| 77 | 1 OF 101 ENDOF |
| 78 | 27 OF 892 ENDOF |
| 79 | 941 SWAP \ default |
| 80 | ENDCASE |
| 81 | ; |
| 82 | T{ 1 T.CASE }T{ 101 }T |
| 83 | T{ 27 T.CASE }T{ 892 }T |
| 84 | T{ 49 T.CASE }T{ 941 }T |
| 85 | |
| 86 | \ ----------------------------------------------------- COMPILE, |
| 87 | : COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE |
| 88 | : T.COMPILE, |
| 89 | 19 20 27 COMPILE.SWAP 39 |
| 90 | ; |
| 91 | T{ T.COMPILE, }T{ 19 27 20 39 }T |
| 92 | |
| 93 | \ ----------------------------------------------------- CONVERT |
| 94 | : T.CONVERT |
| 95 | 0 S>D S" 1234xyz" DROP CONVERT |
| 96 | >R |
| 97 | D>S |
| 98 | R> C@ |
| 99 | ; |
| 100 | T{ T.CONVERT }T{ 1234 CHAR x }T |
| 101 | |
| 102 | \ ----------------------------------------------------- ERASE |
| 103 | : T.COMMA.SEQ ( n -- , lay down N sequential bytes ) |
| 104 | 0 ?DO I C, LOOP |
| 105 | ; |
| 106 | CREATE T-ERASE-DATA 64 T.COMMA.SEQ |
| 107 | T{ T-ERASE-DATA 8 + C@ }T{ 8 }T |
| 108 | T{ T-ERASE-DATA 7 + 3 ERASE |
| 109 | T{ T-ERASE-DATA 6 + C@ }T{ 6 }T |
| 110 | T{ T-ERASE-DATA 7 + C@ }T{ 0 }T |
| 111 | T{ T-ERASE-DATA 8 + C@ }T{ 0 }T |
| 112 | T{ T-ERASE-DATA 9 + C@ }T{ 0 }T |
| 113 | T{ T-ERASE-DATA 10 + C@ }T{ 10 }T |
| 114 | |
| 115 | \ ----------------------------------------------------- FALSE |
| 116 | T{ FALSE }T{ 0 }T |
| 117 | |
| 118 | \ ----------------------------------------------------- HEX |
| 119 | T{ HEX 10 DECIMAL }T{ 16 }T |
| 120 | |
| 121 | \ ----------------------------------------------------- MARKER |
| 122 | : INDIC? ( <name> -- ifInDic , is the following word defined? ) |
| 123 | bl word find |
| 124 | swap drop 0= 0= |
| 125 | ; |
| 126 | create FOOBAR |
| 127 | MARKER MYMARK \ create word that forgets itself |
| 128 | create GOOFBALL |
| 129 | MYMARK |
| 130 | T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T |
| 131 | |
| 132 | \ ----------------------------------------------------- NIP |
| 133 | T{ 33 44 55 NIP }T{ 33 55 }T |
| 134 | |
| 135 | \ ----------------------------------------------------- PARSE |
| 136 | : T.PARSE ( char <string>char -- addr num ) |
| 137 | PARSE |
| 138 | >R \ save length |
| 139 | PAD R@ CMOVE \ move string to pad |
| 140 | PAD R> |
| 141 | ; |
| 142 | T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T |
| 143 | |
| 144 | \ ----------------------------------------------------- PICK |
| 145 | T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T |
| 146 | |
| 147 | \ ----------------------------------------------------- QUERY |
| 148 | T{ ' QUERY 0<> }T{ TRUE }T |
| 149 | |
| 150 | \ ----------------------------------------------------- REFILL |
| 151 | T{ ' REFILL 0<> }T{ TRUE }T |
| 152 | |
| 153 | \ ----------------------------------------------------- RESTORE-INPUT |
| 154 | T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T |
| 155 | |
| 156 | \ TESTING SAVE-INPUT and RESTORE-INPUT with a string source |
| 157 | |
| 158 | VARIABLE SI_INC 0 SI_INC ! |
| 159 | |
| 160 | : SI1 |
| 161 | SI_INC @ >IN +! |
| 162 | 15 SI_INC ! |
| 163 | ; |
| 164 | |
| 165 | : S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; |
| 166 | |
| 167 | T{ S$ EVALUATE SI_INC @ }T{ 0 2345 15 }T |
| 168 | |
| 169 | \ ----------------------------------------------------- ROLL |
| 170 | T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T |
| 171 | T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T |
| 172 | T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T |
| 173 | T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T |
| 174 | T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T |
| 175 | |
| 176 | \ ----------------------------------------------------- SOURCE-ID |
| 177 | T{ SOURCE-ID 0<> }T{ TRUE }T |
| 178 | T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T |
| 179 | |
| 180 | \ ----------------------------------------------------- SPAN |
| 181 | T{ ' SPAN 0<> }T{ TRUE }T |
| 182 | |
| 183 | \ ----------------------------------------------------- TO VALUE |
| 184 | 333 VALUE MY-VALUE |
| 185 | T{ MY-VALUE }T{ 333 }T |
| 186 | T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T |
| 187 | : TEST.VALUE ( -- 19 100 ) |
| 188 | 100 TO MY-VALUE |
| 189 | 19 |
| 190 | MY-VALUE |
| 191 | ; |
| 192 | T{ TEST.VALUE }T{ 19 100 }T |
| 193 | |
| 194 | \ ----------------------------------------------------- TRUE |
| 195 | T{ TRUE }T{ 0 0= }T |
| 196 | |
| 197 | \ ----------------------------------------------------- TUCK |
| 198 | T{ 44 55 66 TUCK }T{ 44 66 55 66 }T |
| 199 | |
| 200 | \ ----------------------------------------------------- U.R |
| 201 | HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR |
| 202 | ABCD4321 C U.R CR DECIMAL |
| 203 | |
| 204 | \ ----------------------------------------------------- U> |
| 205 | T{ -5 3 U> }T{ TRUE }T |
| 206 | T{ 10 8 U> }T{ TRUE }T |
| 207 | |
| 208 | \ ----------------------------------------------------- UNUSED |
| 209 | T{ UNUSED 0> }T{ TRUE }T |
| 210 | |
| 211 | \ ----------------------------------------------------- WITHIN |
| 212 | T{ 4 5 10 WITHIN }T{ 0 }T |
| 213 | T{ 5 5 10 WITHIN }T{ TRUE }T |
| 214 | T{ 9 5 10 WITHIN }T{ TRUE }T |
| 215 | T{ 10 5 10 WITHIN }T{ 0 }T |
| 216 | |
| 217 | T{ 4 10 5 WITHIN }T{ TRUE }T |
| 218 | T{ 5 10 5 WITHIN }T{ 0 }T |
| 219 | T{ 9 10 5 WITHIN }T{ 0 }T |
| 220 | T{ 10 10 5 WITHIN }T{ TRUE }T |
| 221 | |
| 222 | T{ -6 -5 10 WITHIN }T{ 0 }T |
| 223 | T{ -5 -5 10 WITHIN }T{ TRUE }T |
| 224 | T{ 9 -5 10 WITHIN }T{ TRUE }T |
| 225 | T{ 10 -5 10 WITHIN }T{ 0 }T |
| 226 | |
| 227 | |
| 228 | \ ----------------------------------------------------- [COMPILE] |
| 229 | : T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE |
| 230 | : T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ; |
| 231 | T{ T.[COMPILE] }T{ TRUE }T |
| 232 | |
| 233 | \ ----------------------------------------------------- \ |
| 234 | |
| 235 | \ .( TESTING DO +LOOP with large and small increments ) |
| 236 | |
| 237 | \ Contributed by Andrew Haley |
| 238 | 0 invert CONSTANT MAX-UINT |
| 239 | 0 INVERT 1 RSHIFT CONSTANT MAX-INT |
| 240 | 0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT |
| 241 | MAX-UINT 8 RSHIFT 1+ CONSTANT USTEP |
| 242 | USTEP NEGATE CONSTANT -USTEP |
| 243 | MAX-INT 7 RSHIFT 1+ CONSTANT STEP |
| 244 | STEP NEGATE CONSTANT -STEP |
| 245 | |
| 246 | VARIABLE BUMP |
| 247 | |
| 248 | T{ : GD8 BUMP ! DO 1+ BUMP @ +LOOP ; }T{ }T |
| 249 | |
| 250 | T{ 0 MAX-UINT 0 USTEP GD8 }T{ 256 }T |
| 251 | T{ 0 0 MAX-UINT -USTEP GD8 }T{ 256 }T |
| 252 | |
| 253 | T{ 0 MAX-INT MIN-INT STEP GD8 }T{ 256 }T |
| 254 | T{ 0 MIN-INT MAX-INT -STEP GD8 }T{ 256 }T |
| 255 | |
| 256 | \ Two's complement arithmetic, wraps around modulo wordsize |
| 257 | \ Only tested if the Forth system does wrap around, use of conditional |
| 258 | \ compilation deliberately avoided |
| 259 | |
| 260 | MAX-INT 1+ MIN-INT = CONSTANT +WRAP? |
| 261 | MIN-INT 1- MAX-INT = CONSTANT -WRAP? |
| 262 | MAX-UINT 1+ 0= CONSTANT +UWRAP? |
| 263 | 0 1- MAX-UINT = CONSTANT -UWRAP? |
| 264 | |
| 265 | : GD9 ( n limit start step f result -- ) |
| 266 | >R IF GD8 ELSE 2DROP 2DROP R@ THEN }T{ R> }T |
| 267 | ; |
| 268 | |
| 269 | T{ 0 0 0 USTEP +UWRAP? 256 GD9 |
| 270 | T{ 0 0 0 -USTEP -UWRAP? 1 GD9 |
| 271 | T{ 0 MIN-INT MAX-INT STEP +WRAP? 1 GD9 |
| 272 | T{ 0 MAX-INT MIN-INT -STEP -WRAP? 1 GD9 |
| 273 | |
| 274 | \ -------------------------------------------------------------------------- |
| 275 | \ .( TESTING DO +LOOP with maximum and minimum increments ) |
| 276 | |
| 277 | : (-MI) MAX-INT DUP NEGATE + 0= IF MAX-INT NEGATE ELSE -32767 THEN ; |
| 278 | (-MI) CONSTANT -MAX-INT |
| 279 | |
| 280 | T{ 0 1 0 MAX-INT GD8 }T{ 1 }T |
| 281 | T{ 0 -MAX-INT NEGATE -MAX-INT OVER GD8 }T{ 2 }T |
| 282 | |
| 283 | T{ 0 MAX-INT 0 MAX-INT GD8 }T{ 1 }T |
| 284 | T{ 0 MAX-INT 1 MAX-INT GD8 }T{ 1 }T |
| 285 | T{ 0 MAX-INT -1 MAX-INT GD8 }T{ 2 }T |
| 286 | T{ 0 MAX-INT DUP 1- MAX-INT GD8 }T{ 1 }T |
| 287 | |
| 288 | T{ 0 MIN-INT 1+ 0 MIN-INT GD8 }T{ 1 }T |
| 289 | T{ 0 MIN-INT 1+ -1 MIN-INT GD8 }T{ 1 }T |
| 290 | T{ 0 MIN-INT 1+ 1 MIN-INT GD8 }T{ 2 }T |
| 291 | T{ 0 MIN-INT 1+ DUP MIN-INT GD8 }T{ 1 }T |
| 292 | |
| 293 | \ ---------------------------------------------------------------------------- |
| 294 | \ .( TESTING number prefixes # $ % and 'c' character input ) |
| 295 | \ Adapted from the Forth 200X Draft 14.5 document |
| 296 | |
| 297 | VARIABLE OLD-BASE |
| 298 | DECIMAL BASE @ OLD-BASE ! |
| 299 | T{ #1289 }T{ 1289 }T |
| 300 | T{ #-1289 }T{ -1289 }T |
| 301 | T{ $12eF }T{ 4847 }T |
| 302 | T{ $-12eF }T{ -4847 }T |
| 303 | T{ %10010110 }T{ 150 }T |
| 304 | T{ %-10010110 }T{ -150 }T |
| 305 | T{ 'z' }T{ 122 }T |
| 306 | T{ 'Z' }T{ 90 }T |
| 307 | \ Check BASE is unchanged |
| 308 | T{ BASE @ OLD-BASE @ = }T{ TRUE }T |
| 309 | |
| 310 | \ Repeat in Hex mode |
| 311 | 16 OLD-BASE ! 16 BASE ! |
| 312 | T{ #1289 }T{ 509 }T |
| 313 | T{ #-1289 }T{ -509 }T |
| 314 | T{ $12eF }T{ 12EF }T |
| 315 | T{ $-12eF }T{ -12EF }T |
| 316 | T{ %10010110 }T{ 96 }T |
| 317 | T{ %-10010110 }T{ -96 }T |
| 318 | T{ 'z' }T{ 7a }T |
| 319 | T{ 'Z' }T{ 5a }T |
| 320 | \ Check BASE is unchanged |
| 321 | T{ BASE @ OLD-BASE @ = }T{ TRUE }T \ 2 |
| 322 | |
| 323 | DECIMAL |
| 324 | \ Check number prefixes in compile mode |
| 325 | T{ : nmp #8327 $-2cbe %011010111 ''' ; nmp }T{ 8327 -11454 215 39 }T |
| 326 | |
| 327 | \ ----------------------------------------------------- ENVIRONMENT? |
| 328 | |
| 329 | T{ s" unknown-query-string" ENVIRONMENT? }T{ FALSE }T |
| 330 | T{ s" MAX-CHAR" ENVIRONMENT? }T{ 255 TRUE }T |
| 331 | T{ s" ADDRESS-UNITS-BITS" ENVIRONMENT? }T{ 8 TRUE }T |
| 332 | |
| 333 | }TEST |
| 334 | |