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

   1 \ @(#) t_corex.fth 98/03/16 1.2\r
   2 \ Test ANS Forth Core Extensions\r
   3 \\r
   4 \ Copyright 1994 3DO, Phil Burk\r
   5 \r
   6 INCLUDE? }T{  t_tools.fth\r
   7 \r
   8 ANEW TASK-T_COREX.FTH\r
   9 \r
  10 DECIMAL\r
  11 \r
  12 \ STUB because missing definition in pForth - FIXME\r
  13 : SAVE-INPUT ;\r
  14 : RESTORE-INPUT -1 ;\r
  15 \r
  16 TEST{\r
  17 \r
  18 \ ==========================================================\r
  19 T{ 1 2 3 }T{ 1 2 3 }T\r
  20 \r
  21 \  ----------------------------------------------------- .(\r
  22 T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T\r
  23 \r
  24 CR .(     1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR\r
  25 \r
  26 T{ .( )   987   .( TEST NULL STRING IN .( ) CR }T{ 987 }T\r
  27 \r
  28 \  ----------------------------------------------------- 0<>\r
  29 T{ 5 0<> }T{ TRUE }T\r
  30 T{ 0 0<> }T{ 0 }T\r
  31 T{ -1000 0<> }T{ TRUE }T\r
  32 \r
  33 \  ----------------------------------------------------- 2>R 2R> 2R@\r
  34 : T2>R  ( -- .... )\r
  35         17\r
  36         20 5 2>R\r
  37         19\r
  38         2R@\r
  39         37\r
  40         2R>\r
  41 \ 2>R should be the equivalent of SWAP >R >R so this next construct\r
  42 \ should reduce to a SWAP.\r
  43         88 77 2>R R> R>\r
  44 ;\r
  45 T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T\r
  46 \r
  47 \  ----------------------------------------------------- :NONAME\r
  48 T{ :NONAME  100 50 + ; EXECUTE }T{ 150 }T\r
  49 \r
  50 \  ----------------------------------------------------- <>\r
  51 T{ 12345 12305 <> }T{ TRUE }T\r
  52 T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T\r
  53 \r
  54 \  ----------------------------------------------------- ?DO\r
  55 : T?DO  ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;\r
  56 T{ 0 T?DO }T{ 0 }T\r
  57 T{ 4 T?DO }T{ 10 }T\r
  58 \r
  59 \  ----------------------------------------------------- AGAIN\r
  60 : T.AGAIN  ( n --  )\r
  61         BEGIN\r
  62                 DUP .\r
  63                 DUP 6 < IF EXIT THEN\r
  64                 1-\r
  65         AGAIN\r
  66 ;\r
  67 T{ 10 T.AGAIN CR }T{ 5 }T\r
  68 \r
  69 \  ----------------------------------------------------- C"\r
  70 : T.C"  ( -- $STRING )\r
  71         C" x5&"\r
  72 ;\r
  73 T{ T.C"  C@  }T{ 3 }T\r
  74 T{ T.C"  COUNT DROP C@  }T{ CHAR x }T\r
  75 T{ T.C"  COUNT DROP CHAR+ C@ }T{  CHAR 5 }T\r
  76 T{ T.C"  COUNT DROP 2 CHARS + C@  }T{ CHAR & }T\r
  77 \r
  78 \  ----------------------------------------------------- CASE\r
  79 : T.CASE  ( N -- )\r
  80         CASE\r
  81                 1 OF 101 ENDOF\r
  82                 27 OF 892 ENDOF\r
  83                 941 SWAP \ default\r
  84         ENDCASE\r
  85 ;\r
  86 T{ 1 T.CASE }T{ 101 }T\r
  87 T{ 27 T.CASE }T{ 892 }T\r
  88 T{ 49 T.CASE }T{ 941 }T\r
  89 \r
  90 \  ----------------------------------------------------- COMPILE,\r
  91 : COMPILE.SWAP    ['] SWAP COMPILE, ; IMMEDIATE\r
  92 : T.COMPILE,\r
  93         19 20 27 COMPILE.SWAP 39\r
  94 ;\r
  95 T{ T.COMPILE, }T{ 19 27 20 39 }T\r
  96 \r
  97 \  ----------------------------------------------------- CONVERT\r
  98 : T.CONVERT\r
  99         0 S>D  S" 1234xyz" DROP CONVERT\r
 100         >R\r
 101         D>S\r
 102         R> C@\r
 103 ;\r
 104 T{ T.CONVERT }T{ 1234 CHAR x }T\r
 105 \r
 106 \  ----------------------------------------------------- ERASE\r
 107 : T.COMMA.SEQ  ( n -- , lay down N sequential bytes )\r
 108         0 ?DO I C, LOOP\r
 109 ;\r
 110 CREATE T-ERASE-DATA   64 T.COMMA.SEQ\r
 111 T{ T-ERASE-DATA 8 + C@ }T{ 8 }T\r
 112 T{ T-ERASE-DATA 7 + 3 ERASE\r
 113 T{ T-ERASE-DATA 6 + C@ }T{ 6 }T\r
 114 T{ T-ERASE-DATA 7 + C@ }T{ 0 }T\r
 115 T{ T-ERASE-DATA 8 + C@ }T{ 0 }T\r
 116 T{ T-ERASE-DATA 9 + C@ }T{ 0 }T\r
 117 T{ T-ERASE-DATA 10 + C@ }T{ 10 }T\r
 118 \r
 119 \  ----------------------------------------------------- FALSE\r
 120 T{ FALSE }T{ 0 }T\r
 121 \r
 122 \  ----------------------------------------------------- HEX\r
 123 T{ HEX 10 DECIMAL }T{ 16 }T\r
 124 \r
 125 \  ----------------------------------------------------- MARKER\r
 126 : INDIC?  ( <name> -- ifInDic , is the following word defined? )\r
 127         bl word find\r
 128         swap drop 0= 0=\r
 129 ;\r
 130 create FOOBAR\r
 131 MARKER MYMARK  \ create word that forgets itself\r
 132 create GOOFBALL\r
 133 MYMARK\r
 134 T{ indic? foobar  indic? mymark indic? goofball }T{ true false false }T\r
 135 \r
 136 \  ----------------------------------------------------- NIP\r
 137 T{ 33 44 55 NIP  }T{ 33 55 }T\r
 138 \r
 139 \  ----------------------------------------------------- PARSE\r
 140 : T.PARSE  ( char <string>char -- addr num )\r
 141         PARSE\r
 142         >R  \ save length\r
 143         PAD R@ CMOVE  \ move string to pad\r
 144         PAD R>\r
 145 ;\r
 146 T{ CHAR % T.PARSE wxyz% SWAP C@ }T{  4  CHAR w }T\r
 147 \r
 148 \  ----------------------------------------------------- PICK\r
 149 T{ 13 12 11 10 2 PICK  }T{ 13 12 11 10 12 }T\r
 150 \r
 151 \  ----------------------------------------------------- QUERY\r
 152 T{ ' QUERY 0<> }T{ TRUE }T\r
 153 \r
 154 \  ----------------------------------------------------- REFILL\r
 155 T{ ' REFILL 0<> }T{ TRUE }T\r
 156 \r
 157 \  ----------------------------------------------------- RESTORE-INPUT\r
 158 T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T  \ EXPECTED FAILURE\r
 159 \r
 160 \  ----------------------------------------------------- ROLL\r
 161 T{ 15 14 13 12 11 10 0 ROLL  }T{  15 14 13 12 11 10 }T\r
 162 T{ 15 14 13 12 11 10 1 ROLL  }T{  15 14 13 12 10 11 }T\r
 163 T{ 15 14 13 12 11 10 2 ROLL  }T{  15 14 13 11 10 12 }T\r
 164 T{ 15 14 13 12 11 10 3 ROLL  }T{  15 14 12 11 10 13 }T\r
 165 T{ 15 14 13 12 11 10 4 ROLL  }T{  15 13 12 11 10 14 }T\r
 166 \r
 167 \  ----------------------------------------------------- SOURCE-ID\r
 168 T{ SOURCE-ID 0<> }T{ TRUE }T\r
 169 T{ : T.SOURCE-ID  S" SOURCE-ID" EVALUATE  ;   T.SOURCE-ID }T{ -1 }T\r
 170 \r
 171 \  ----------------------------------------------------- SPAN\r
 172 T{ ' SPAN 0<>  }T{ TRUE }T\r
 173 \r
 174 \  ----------------------------------------------------- TO VALUE\r
 175 333 VALUE  MY-VALUE\r
 176 T{ MY-VALUE }T{ 333 }T\r
 177 T{ 1000 TO MY-VALUE   MY-VALUE }T{ 1000 }T\r
 178 : TEST.VALUE  ( -- 19 100 )\r
 179         100 TO MY-VALUE\r
 180         19\r
 181         MY-VALUE\r
 182 ;\r
 183 T{ TEST.VALUE }T{ 19 100 }T\r
 184 \r
 185 \  ----------------------------------------------------- TRUE\r
 186 T{ TRUE }T{ 0 0= }T\r
 187 \r
 188 \  ----------------------------------------------------- TUCK\r
 189 T{ 44 55 66 TUCK }T{ 44 66 55 66 }T\r
 190 \r
 191 \  ----------------------------------------------------- U.R\r
 192 HEX CR .(     ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR\r
 193 ABCD4321 C U.R CR DECIMAL\r
 194 \r
 195 \  ----------------------------------------------------- U>\r
 196 T{ -5 3 U> }T{ TRUE }T\r
 197 T{ 10 8 U> }T{ TRUE }T\r
 198 \r
 199 \  ----------------------------------------------------- UNUSED\r
 200 T{ UNUSED 0> }T{ TRUE }T\r
 201 \r
 202 \  ----------------------------------------------------- WITHIN\r
 203 T{  4  5 10 WITHIN }T{ 0 }T\r
 204 T{  5  5 10 WITHIN }T{ TRUE }T\r
 205 T{  9  5 10 WITHIN }T{ TRUE }T\r
 206 T{ 10  5 10 WITHIN }T{ 0 }T\r
 207 \r
 208 T{  4  10 5 WITHIN }T{ TRUE }T\r
 209 T{  5  10 5 WITHIN }T{ 0 }T\r
 210 T{  9  10 5 WITHIN }T{ 0 }T\r
 211 T{ 10  10 5 WITHIN }T{ TRUE }T\r
 212 \r
 213 T{  -6  -5 10 WITHIN }T{ 0 }T\r
 214 T{  -5  -5 10 WITHIN    }T{ TRUE }T\r
 215 T{  9  -5 10 WITHIN    }T{ TRUE }T\r
 216 T{ 10  -5 10 WITHIN }T{ 0 }T\r
 217 \r
 218 \r
 219 \  ----------------------------------------------------- [COMPILE]\r
 220 : T.[COMPILE].IF  [COMPILE] IF ; IMMEDIATE\r
 221 : T.[COMPILE]  40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ;\r
 222 T{ T.[COMPILE] }T{ TRUE }T\r
 223 \r
 224 \  ----------------------------------------------------- \\r
 225 }TEST\r
 226 \r