extra/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 ;
   4 IN: locals.tests
   5
   6 :: foo ( a b -- a a ) a a ;
   7
   8 [ 1 1 ] [ 1 2 foo ] unit-test
   9
  10 :: add-test ( a b -- c ) a b + ;
  11
  12 [ 3 ] [ 1 2 add-test ] unit-test
  13
  14 :: sub-test ( a b -- c ) a b - ;
  15
  16 [ -1 ] [ 1 2 sub-test ] unit-test
  17
  18 :: map-test ( a b -- seq ) a [ b + ] map ;
  19
  20 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
  21
  22 :: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
  23
  24 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
  25
  26 :: let-test ( c -- d )
  27     [let | a [ 1 ] b [ 2 ] | a b + c + ] ;
  28
  29 [ 7 ] [ 4 let-test ] unit-test
  30
  31 :: let-test-2 ( a -- a )
  32     a [let | a [ ] | [let | b [ a ] | a ] ] ;
  33
  34 [ 3 ] [ 3 let-test-2 ] unit-test
  35
  36 :: let-test-3 ( a -- a )
  37     a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
  38
  39 :: let-test-4 ( a -- b )
  40     a [let | a [ 1 ] b [ ] | a b 2array ] ;
  41
  42 [ { 1 2 } ] [ 2 let-test-4 ] unit-test
  43
  44 :: let-test-5 ( a -- b )
  45     a [let | a [ ] b [ ] | a b 2array ] ;
  46
  47 [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
  48
  49 :: let-test-6 ( a -- b )
  50     a [let | a [ ] b [ 1 ] | a b 2array ] ;
  51
  52 [ { 2 1 } ] [ 2 let-test-6 ] unit-test
  53
  54 [ -1 ] [ -1 let-test-3 call ] unit-test
  55
  56 [ 5 ] [
  57     [let | a [ 3 ] | [wlet | func [ a + ] | 2 func ] ]
  58 ] unit-test
  59
  60 :: wlet-test-2 ( a b -- seq )
  61     [wlet | add-b [ b + ] |
  62         a [ add-b ] map ] ;
  63
  64
  65 [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
  66
  67 :: wlet-test-3 ( a -- b )
  68     [wlet | add-a [ a + ] | [ add-a ] ]
  69     [let | a [ 3 ] | a swap call ] ;
  70
  71 [ 5 ] [ 2 wlet-test-3 ] unit-test
  72
  73 :: wlet-test-4 ( a -- b )
  74     [wlet | sub-a [| b | b a - ] |
  75         3 sub-a ] ;
  76
  77 [ -7 ] [ 10 wlet-test-4 ] unit-test
  78
  79 :: write-test-1 ( n! -- q )
  80     [| i | n i + dup n! ] ;
  81
  82 0 write-test-1 "q" set
  83
  84 { 1 1 } "q" get must-infer-as
  85
  86 [ 1 ] [ 1 "q" get call ] unit-test
  87
  88 [ 2 ] [ 1 "q" get call ] unit-test
  89
  90 [ 3 ] [ 1 "q" get call ] unit-test
  91
  92 [ 5 ] [ 2 "q" get call ] unit-test
  93
  94 :: write-test-2 ( -- q )
  95     [let | n! [ 0 ] |
  96         [| i | n i + dup n! ] ] ;
  97
  98 write-test-2 "q" set
  99
 100 [ 1 ] [ 1 "q" get call ] unit-test
 101
 102 [ 2 ] [ 1 "q" get call ] unit-test
 103
 104 [ 3 ] [ 1 "q" get call ] unit-test
 105
 106 [ 5 ] [ 2 "q" get call ] unit-test
 107
 108 [ 10 20 ]
 109 [
 110     20 10 [| a! | [| b! | a b ] ] call call
 111 ] unit-test
 112
 113 :: write-test-3 ( a! -- q ) [| b | b a! ] ;
 114
 115 [ ] [ 1 2 write-test-3 call ] unit-test
 116
 117 :: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
 118
 119 [ ] [ 5 write-test-4 drop ] unit-test
 120
 121 ! Not really a write test; just enforcing consistency
 122 :: write-test-5 ( x -- y )
 123     [wlet | fun! [ x + ] | 5 fun! ] ;
 124
 125 [ 9 ] [ 4 write-test-5 ] unit-test
 126
 127 SYMBOL: a
 128
 129 :: use-test ( a b c -- a b c )
 130     USE: kernel ;
 131
 132 [ t ] [ a symbol? ] unit-test
 133
 134 :: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
 135
 136 [ 13 ] [ 10 let-let-test ] unit-test
 137
 138 GENERIC: lambda-generic ( a b -- c )
 139
 140 GENERIC# lambda-generic-1 1 ( a b -- c )
 141
 142 M:: integer lambda-generic-1 ( a b -- c ) a b * ;
 143
 144 M:: string lambda-generic-1 ( a b -- c )
 145     a b CHAR: x <string> lambda-generic ;
 146
 147 M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
 148
 149 GENERIC# lambda-generic-2 1 ( a b -- c )
 150
 151 M:: integer lambda-generic-2 ( a b -- c )
 152     a CHAR: x <string> b lambda-generic ;
 153
 154 M:: string lambda-generic-2 ( a b -- c ) a b append ;
 155
 156 M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
 157
 158 [ 10 ] [ 5 2 lambda-generic ] unit-test
 159
 160 [ "abab" ] [ "aba" "b" lambda-generic ] unit-test
 161
 162 [ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
 163
 164 [ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
 165
 166 [ ] [ \ lambda-generic-1 see ] unit-test
 167
 168 [ ] [ \ lambda-generic-2 see ] unit-test
 169
 170 [ ] [ \ lambda-generic see ] unit-test
 171
 172 :: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
 173
 174 [ "[let | a! [ ] | ]" ] [
 175     \ unparse-test-1 "lambda" word-prop body>> first unparse
 176 ] unit-test
 177
 178 :: unparse-test-2 ( -- ) [wlet | a! [ ] | ] ;
 179
 180 [ "[wlet | a! [ ] | ]" ] [
 181     \ unparse-test-2 "lambda" word-prop body>> first unparse
 182 ] unit-test
 183
 184 :: unparse-test-3 ( -- b ) [| a! | ] ;
 185
 186 [ "[| a! | ]" ] [
 187     \ unparse-test-3 "lambda" word-prop body>> first unparse
 188 ] unit-test
 189
 190 DEFER: xyzzy
 191
 192 [ ] [
 193     "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
 194     <string-reader> "lambda-generic-test" parse-stream drop
 195 ] unit-test
 196
 197 [ 10 ] [ 10 xyzzy ] unit-test
 198
 199 [ ] [
 200     "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
 201     <string-reader> "lambda-generic-test" parse-stream drop
 202 ] unit-test
 203
 204 [ 5 ] [ 10 xyzzy ] unit-test
 205
 206 :: let*-test-1 ( a -- b )
 207     [let* | b [ a 1+ ]
 208             c [ b 1+ ] |
 209         a b c 3array ] ;
 210
 211 [ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
 212
 213 :: let*-test-2 ( a -- b )
 214     [let* | b [ a 1+ ]
 215             c! [ b 1+ ] |
 216         a b c 3array ] ;
 217
 218 [ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
 219
 220 :: let*-test-3 ( a -- b )
 221     [let* | b [ a 1+ ]
 222             c! [ b 1+ ] |
 223         c 1+ c!  a b c 3array ] ;
 224
 225 [ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
 226
 227 :: let*-test-4 ( a b -- c d )
 228     [let | a [ b ]
 229            b [ a ] |
 230         [let* | a'  [ a  ]
 231                 a'' [ a' ]
 232                 b'  [ b  ]
 233                 b'' [ b' ] |
 234             a'' b'' ] ] ;
 235
 236 [ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
 237
 238 GENERIC: next-method-test ( a -- b )
 239
 240 M: integer next-method-test 3 + ;
 241
 242 M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
 243
 244 [ 5 ] [ 1 next-method-test ] unit-test
 245
 246 : no-with-locals-test { 1 2 3 } [| x | x 3 + ] map ;
 247
 248 [ { 4 5 6 } ] [ no-with-locals-test ] unit-test
 249
 250 { 3 0 } [| a b c | ] must-infer-as
 251
 252 [ ] [ 1 [let | a [ ] | ] ] unit-test
 253
 254 [ 3 ] [ 1 [let | a [ ] | 3 ] ] unit-test
 255
 256 [ ] [ 1 2 [let | a [ ] b [ ] | ] ] unit-test
 257
 258 :: a-word-with-locals ( a b -- ) ;
 259
 260 : new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" ;
 261
 262 [ ] [ new-definition eval ] unit-test
 263
 264 [ t ] [
 265     [ \ a-word-with-locals see ] with-string-writer
 266     new-definition =
 267 ] unit-test
 268
 269 : method-definition "USING: locals locals.tests sequences ;\nM:: sequence method-with-locals ( a -- y ) a reverse ;\n" ;
 270
 271 GENERIC: method-with-locals ( x -- y )
 272
 273 M:: sequence method-with-locals ( a -- y ) a reverse ;
 274
 275 [ t ] [
 276     [ \ sequence \ method-with-locals method see ] with-string-writer
 277     method-definition =
 278 ] unit-test