basis/locals/locals-tests.factor

   1 USING: locals math sequences tools.test hashtables words kernel
   2 namespaces arrays strings prettyprint io.streams.string parser
   3 accessors generic eval combinators combinators.short-circuit
   4 combinators.short-circuit.smart math.order ;
   5 IN: locals.tests
   6
   7 :: foo ( a b -- a a ) a a ;
   8
   9 [ 1 1 ] [ 1 2 foo ] unit-test
  10
  11 :: add-test ( a b -- c ) a b + ;
  12
  13 [ 3 ] [ 1 2 add-test ] unit-test
  14
  15 :: sub-test ( a b -- c ) a b - ;
  16
  17 [ -1 ] [ 1 2 sub-test ] unit-test
  18
  19 :: map-test ( a b -- seq ) a [ b + ] map ;
  20
  21 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
  22
  23 :: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
  24
  25 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
  26
  27 :: let-test ( c -- d )
  28     [let | a [ 1 ] b [ 2 ] | a b + c + ] ;
  29
  30 [ 7 ] [ 4 let-test ] unit-test
  31
  32 :: let-test-2 ( a -- a )
  33     a [let | a [ ] | [let | b [ a ] | a ] ] ;
  34
  35 [ 3 ] [ 3 let-test-2 ] unit-test
  36
  37 :: let-test-3 ( a -- a )
  38     a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
  39
  40 :: let-test-4 ( a -- b )
  41     a [let | a [ 1 ] b [ ] | a b 2array ] ;
  42
  43 [ { 1 2 } ] [ 2 let-test-4 ] unit-test
  44
  45 :: let-test-5 ( a -- b )
  46     a [let | a [ ] b [ ] | a b 2array ] ;
  47
  48 [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
  49
  50 :: let-test-6 ( a -- b )
  51     a [let | a [ ] b [ 1 ] | a b 2array ] ;
  52
  53 [ { 2 1 } ] [ 2 let-test-6 ] unit-test
  54
  55 [ -1 ] [ -1 let-test-3 call ] unit-test
  56
  57 [ 5 ] [
  58     [let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
  59 ] unit-test
  60
  61 :: wlet-test-2 ( a b -- seq )
  62     [wlet | add-b [ b + ] |
  63         a [ add-b ] map ] ;
  64
  65
  66 [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
  67
  68 :: wlet-test-3 ( a -- b )
  69     [wlet | add-a [ a + ] | [ add-a ] ]
  70     [let | a [ 3 ] | a swap call ] ;
  71
  72 [ 5 ] [ 2 wlet-test-3 ] unit-test
  73
  74 :: wlet-test-4 ( a -- b )
  75     [wlet | sub-a [| b | b a - ] |
  76         3 sub-a ] ;
  77
  78 [ -7 ] [ 10 wlet-test-4 ] unit-test
  79
  80 :: write-test-1 ( n! -- q )
  81     [| i | n i + dup n! ] ;
  82
  83 0 write-test-1 "q" set
  84
  85 { 1 1 } "q" get must-infer-as
  86
  87 [ 1 ] [ 1 "q" get call ] unit-test
  88
  89 [ 2 ] [ 1 "q" get call ] unit-test
  90
  91 [ 3 ] [ 1 "q" get call ] unit-test
  92
  93 [ 5 ] [ 2 "q" get call ] unit-test
  94
  95 :: write-test-2 ( -- q )
  96     [let | n! [ 0 ] |
  97         [| i | n i + dup n! ] ] ;
  98
  99 write-test-2 "q" set
 100
 101 [ 1 ] [ 1 "q" get call ] unit-test
 102
 103 [ 2 ] [ 1 "q" get call ] unit-test
 104
 105 [ 3 ] [ 1 "q" get call ] unit-test
 106
 107 [ 5 ] [ 2 "q" get call ] unit-test
 108
 109 [ 10 20 ]
 110 [
 111     20 10 [| a! | [| b! | a b ] ] call call
 112 ] unit-test
 113
 114 :: write-test-3 ( a! -- q ) [| b | b a! ] ;
 115
 116 [ ] [ 1 2 write-test-3 call ] unit-test
 117
 118 :: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
 119
 120 [ ] [ 5 write-test-4 drop ] unit-test
 121
 122 ! Not really a write test; just enforcing consistency
 123 :: write-test-5 ( x -- y )
 124     [wlet | fun! [ x + ] | 5 fun! ] ;
 125
 126 [ 9 ] [ 4 write-test-5 ] unit-test
 127
 128 SYMBOL: a
 129
 130 :: use-test ( a b c -- a b c )
 131     USE: kernel ;
 132
 133 [ t ] [ a symbol? ] unit-test
 134
 135 :: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
 136
 137 [ 13 ] [ 10 let-let-test ] unit-test
 138
 139 GENERIC: lambda-generic ( a b -- c )
 140
 141 GENERIC# lambda-generic-1 1 ( a b -- c )
 142
 143 M:: integer lambda-generic-1 ( a b -- c ) a b * ;
 144
 145 M:: string lambda-generic-1 ( a b -- c )
 146     a b CHAR: x <string> lambda-generic ;
 147
 148 M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
 149
 150 GENERIC# lambda-generic-2 1 ( a b -- c )
 151
 152 M:: integer lambda-generic-2 ( a b -- c )
 153     a CHAR: x <string> b lambda-generic ;
 154
 155 M:: string lambda-generic-2 ( a b -- c ) a b append ;
 156
 157 M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
 158
 159 [ 10 ] [ 5 2 lambda-generic ] unit-test
 160
 161 [ "abab" ] [ "aba" "b" lambda-generic ] unit-test
 162
 163 [ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
 164
 165 [ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
 166
 167 [ ] [ \ lambda-generic-1 see ] unit-test
 168
 169 [ ] [ \ lambda-generic-2 see ] unit-test
 170
 171 [ ] [ \ lambda-generic see ] unit-test
 172
 173 :: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
 174
 175 [ "[let | a! [ ] | ]" ] [
 176     \ unparse-test-1 "lambda" word-prop body>> first unparse
 177 ] unit-test
 178
 179 :: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
 180
 181 [ "[wlet | a! [ ] | ]" ] [
 182     \ unparse-test-2 "lambda" word-prop body>> first unparse
 183 ] unit-test
 184
 185 :: unparse-test-3 ( -- b ) [| a! | ] ;
 186
 187 [ "[| a! | ]" ] [
 188     \ unparse-test-3 "lambda" word-prop body>> first unparse
 189 ] unit-test
 190
 191 DEFER: xyzzy
 192
 193 [ ] [
 194     "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
 195     <string-reader> "lambda-generic-test" parse-stream drop
 196 ] unit-test
 197
 198 [ 10 ] [ 10 xyzzy ] unit-test
 199
 200 [ ] [
 201     "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
 202     <string-reader> "lambda-generic-test" parse-stream drop
 203 ] unit-test
 204
 205 [ 5 ] [ 10 xyzzy ] unit-test
 206
 207 :: let*-test-1 ( a -- b )
 208     [let* | b [ a 1+ ]
 209             c [ b 1+ ] |
 210         a b c 3array ] ;
 211
 212 [ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
 213
 214 :: let*-test-2 ( a -- b )
 215     [let* | b [ a 1+ ]
 216             c! [ b 1+ ] |
 217         a b c 3array ] ;
 218
 219 [ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
 220
 221 :: let*-test-3 ( a -- b )
 222     [let* | b [ a 1+ ]
 223             c! [ b 1+ ] |
 224         c 1+ c!  a b c 3array ] ;
 225
 226 [ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
 227
 228 :: let*-test-4 ( a b -- c d )
 229     [let | a [ b ]
 230            b [ a ] |
 231         [let* | a'  [ a  ]
 232                 a'' [ a' ]
 233                 b'  [ b  ]
 234                 b'' [ b' ] |
 235             a'' b'' ] ] ;
 236
 237 [ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
 238
 239 GENERIC: next-method-test ( a -- b )
 240
 241 M: integer next-method-test 3 + ;
 242
 243 M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
 244
 245 [ 5 ] [ 1 next-method-test ] unit-test
 246
 247 : no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
 248
 249 [ { 4 5 6 } ] [ no-with-locals-test ] unit-test
 250
 251 { 3 0 } [| a b c | ] must-infer-as
 252
 253 [ ] [ 1 [let | a [ ] | ] ] unit-test
 254
 255 [ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
 256
 257 [ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
 258
 259 :: a-word-with-locals ( a b -- ) ;
 260
 261 : new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
 262
 263 [ ] [ new-definition eval ] unit-test
 264
 265 [ t ] [
 266     [ \ a-word-with-locals see ] with-string-writer
 267     new-definition =
 268 ] unit-test
 269
 270 : method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ;
 271
 272 GENERIC: method-with-locals ( x -- y )
 273
 274 M:: sequence method-with-locals ( a -- y ) a reverse ;
 275
 276 [ t ] [
 277     [ \ sequence \ method-with-locals method see ] with-string-writer
 278     method-definition =
 279 ] unit-test
 280
 281 :: cond-test ( a b -- c )
 282     {
 283         { [ a b < ] [ 3 ] }
 284         { [ a b = ] [ 4 ] }
 285         { [ a b > ] [ 5 ] }
 286     } cond ;
 287
 288 [ 3 ] [ 1 2 cond-test ] unit-test
 289 [ 4 ] [ 2 2 cond-test ] unit-test
 290 [ 5 ] [ 3 2 cond-test ] unit-test
 291
 292 :: 0&&-test ( a -- ? )
 293     { [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
 294
 295 [ f ] [ 1.5 0&&-test ] unit-test
 296 [ f ] [ 3 0&&-test ] unit-test
 297 [ f ] [ 8 0&&-test ] unit-test
 298 [ t ] [ 12 0&&-test ] unit-test
 299
 300 :: &&-test ( a -- ? )
 301     { [ a integer? ] [ a even? ] [ a 10 > ] } && ;
 302
 303 [ f ] [ 1.5 &&-test ] unit-test
 304 [ f ] [ 3 &&-test ] unit-test
 305 [ f ] [ 8 &&-test ] unit-test
 306 [ t ] [ 12 &&-test ] unit-test
 307
 308 :: wlet-&&-test ( a -- ? )
 309     [wlet | is-integer? [ a integer? ]
 310             is-even? [ a even? ]
 311             >10? [ a 10 > ] |
 312         { [ is-integer? ] [ is-even? ] [ >10? ] } &&
 313     ] ;
 314
 315 ! [ f ] [ 1.5 wlet-&&-test ] unit-test
 316 ! [ f ] [ 3 wlet-&&-test ] unit-test
 317 ! [ f ] [ 8 wlet-&&-test ] unit-test
 318 ! [ t ] [ 12 wlet-&&-test ] unit-test
 319
 320 [ { 10       } ] [ 10       [| a     | { a     } ] call ] unit-test
 321 [ { 10 20    } ] [ 10 20    [| a b   | { a b   } ] call ] unit-test
 322 [ { 10 20 30 } ] [ 10 20 30 [| a b c | { a b c } ] call ] unit-test
 323
 324 [ { 10 20 30 } ] [ [let | a [ 10 ] b [ 20 ] c [ 30 ] | { a b c } ] ] unit-test
 325
 326 [ V{ 10 20 30 } ] [ 10 20 30 [| a b c | V{ a b c } ] call ] unit-test
 327
 328 [ H{ { 10 "a" } { 20 "b" } { 30 "c" } } ]
 329 [ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
 330
 331 [ T{ slice f 0 3 "abc" } ]
 332 [ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
 333
 334 { 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
 335
 336 :: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
 337     obj1 obj2 <=> {
 338         { +lt+ [ lt-quot call ] }
 339         { +eq+ [ eq-quot call ] }
 340         { +gt+ [ gt-quot call ] }
 341     } case ; inline
 342
 343 [ [ ] [ ] [ ] compare-case ] must-infer