git.gag.com Git - debian/pforth/blob - fth/t_corex.fth

   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 \  ----------------------------------------------------- PROGRAMMING
 334
 335 T{ exists? words }T{ true }T  \ high level
 336 T{ exists? swap }T{ true }T   \ in kernel
 337 T{ exists? lkajsdlakjs }T{ false }T
 338
 339 T{ [defined] if }T{ true }T   \ high level
 340 T{ [defined] dup }T{ true }T  \ in kernel
 341 T{ [defined] k23jh42 }T{ false }T
 342
 343 T{ [undefined] if }T{ false }T  \ high level
 344 T{ [undefined] dup }T{ false }T \ in kernel
 345 T{ [undefined] k23jh42 }T{ true }T
 346
 347 }TEST
 348