/core/combinators/combinators-tests.factor

http://github.com/abeaumont/factor · Factor · 326 lines · 248 code · 75 blank · 3 comment · 97 complexity · 0c121329cd06b7c5059a4933c1709026 MD5 · raw file

  1. USING: alien strings kernel math tools.test io prettyprint
  2. namespaces combinators words classes sequences accessors
  3. math.functions arrays combinators.private stack-checker ;
  4. IN: combinators.tests
  5. [ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
  6. [ 1 2 [ + ] call( -- z ) ] must-fail
  7. [ 1 2 [ + ] call( x y -- z a ) ] must-fail
  8. [ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
  9. [ [ + ] call( x y -- z ) ] must-infer
  10. [ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
  11. [ 1 2 \ + execute( -- z ) ] must-fail
  12. [ 1 2 \ + execute( x y -- z a ) ] must-fail
  13. [ \ + execute( x y -- z ) ] must-infer
  14. : compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
  15. [ t ] [ \ compile-execute(-test-1 optimized? ] unit-test
  16. [ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
  17. : compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
  18. [ t ] [ \ compile-execute(-test-2 optimized? ] unit-test
  19. [ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
  20. [ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
  21. [ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
  22. [ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
  23. : compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ;
  24. [ t ] [ \ compile-call(-test-1 optimized? ] unit-test
  25. [ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test
  26. [ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test
  27. [ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
  28. [ 4 ] [ 1 3 [ { + } [ ] like call ] compile-call(-test-1 ] unit-test
  29. [ [ ] call( -- * ) ] must-fail
  30. : compile-call(-test-2 ( -- ) [ ] call( -- * ) ;
  31. [ compile-call(-test-2 ] [ wrong-values? ] must-fail-with
  32. : compile-call(-test-3 ( quot -- ) call( -- * ) ;
  33. [ [ ] compile-call(-test-3 ] [ wrong-values? ] must-fail-with
  34. : compile-execute(-test-3 ( a -- ) \ . execute( value -- * ) ;
  35. [ 10 compile-execute(-test-3 ] [ wrong-values? ] must-fail-with
  36. : compile-execute(-test-4 ( a word -- ) execute( value -- * ) ;
  37. [ 10 \ . compile-execute(-test-4 ] [ wrong-values? ] must-fail-with
  38. ! Cond
  39. : cond-test-1 ( obj -- str )
  40. {
  41. { [ dup 2 mod 0 = ] [ drop "even" ] }
  42. { [ dup 2 mod 1 = ] [ drop "odd" ] }
  43. } cond ;
  44. \ cond-test-1 def>> must-infer
  45. [ "even" ] [ 2 cond-test-1 ] unit-test
  46. [ "even" ] [ 2 \ cond-test-1 def>> call ] unit-test
  47. [ "odd" ] [ 3 cond-test-1 ] unit-test
  48. [ "odd" ] [ 3 \ cond-test-1 def>> call ] unit-test
  49. : cond-test-2 ( obj -- str )
  50. {
  51. { [ dup t = ] [ drop "true" ] }
  52. { [ dup f = ] [ drop "false" ] }
  53. [ drop "something else" ]
  54. } cond ;
  55. \ cond-test-2 def>> must-infer
  56. [ "true" ] [ t cond-test-2 ] unit-test
  57. [ "true" ] [ t \ cond-test-2 def>> call ] unit-test
  58. [ "false" ] [ f cond-test-2 ] unit-test
  59. [ "false" ] [ f \ cond-test-2 def>> call ] unit-test
  60. [ "something else" ] [ "ohio" cond-test-2 ] unit-test
  61. [ "something else" ] [ "ohio" \ cond-test-2 def>> call ] unit-test
  62. : cond-test-3 ( obj -- str )
  63. {
  64. [ drop "something else" ]
  65. { [ dup t = ] [ drop "true" ] }
  66. { [ dup f = ] [ drop "false" ] }
  67. } cond ;
  68. \ cond-test-3 def>> must-infer
  69. [ "something else" ] [ t cond-test-3 ] unit-test
  70. [ "something else" ] [ t \ cond-test-3 def>> call ] unit-test
  71. [ "something else" ] [ f cond-test-3 ] unit-test
  72. [ "something else" ] [ f \ cond-test-3 def>> call ] unit-test
  73. [ "something else" ] [ "ohio" cond-test-3 ] unit-test
  74. [ "something else" ] [ "ohio" \ cond-test-3 def>> call ] unit-test
  75. : cond-test-4 ( -- )
  76. {
  77. } cond ;
  78. \ cond-test-4 def>> must-infer
  79. [ cond-test-4 ] [ no-cond? ] must-fail-with
  80. [ \ cond-test-4 def>> call ] [ no-cond? ] must-fail-with
  81. : cond-test-5 ( a -- b )
  82. {
  83. { [ dup 2 mod 1 = ] [ drop "odd" ] }
  84. [ drop "early" ]
  85. { [ dup 2 mod 0 = ] [ drop "even" ] }
  86. } cond ;
  87. [ "early" ] [ 2 cond-test-5 ] unit-test
  88. [ "early" ] [ 2 \ cond-test-5 def>> call ] unit-test
  89. : cond-test-6 ( a -- b )
  90. {
  91. [ drop "really early" ]
  92. { [ dup 2 mod 1 = ] [ drop "odd" ] }
  93. { [ dup 2 mod 0 = ] [ drop "even" ] }
  94. } cond ;
  95. [ "really early" ] [ 2 cond-test-6 ] unit-test
  96. [ "really early" ] [ 2 \ cond-test-6 def>> call ] unit-test
  97. ! Case
  98. : case-test-1 ( obj -- obj' )
  99. {
  100. { 1 [ "one" ] }
  101. { 2 [ "two" ] }
  102. { 3 [ "three" ] }
  103. { 4 [ "four" ] }
  104. } case ;
  105. \ case-test-1 def>> must-infer
  106. [ "two" ] [ 2 case-test-1 ] unit-test
  107. [ "two" ] [ 2 \ case-test-1 def>> call ] unit-test
  108. [ "x" case-test-1 ] must-fail
  109. [ "x" \ case-test-1 def>> call ] must-fail
  110. : case-test-2 ( obj -- obj' )
  111. {
  112. { 1 [ "one" ] }
  113. { 2 [ "two" ] }
  114. { 3 [ "three" ] }
  115. { 4 [ "four" ] }
  116. [ sq ]
  117. } case ;
  118. \ case-test-2 def>> must-infer
  119. [ 25 ] [ 5 case-test-2 ] unit-test
  120. [ 25 ] [ 5 \ case-test-2 def>> call ] unit-test
  121. : case-test-3 ( obj -- obj' )
  122. {
  123. { 1 [ "one" ] }
  124. { 2 [ "two" ] }
  125. { 3 [ "three" ] }
  126. { 4 [ "four" ] }
  127. { H{ } [ "a hashtable" ] }
  128. { { 1 2 3 } [ "an array" ] }
  129. [ sq ]
  130. } case ;
  131. \ case-test-3 def>> must-infer
  132. [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
  133. [ "an array" ] [ { 1 2 3 } \ case-test-3 def>> call ] unit-test
  134. CONSTANT: case-const-1 1
  135. CONSTANT: case-const-2 2
  136. ! Compiled
  137. : case-test-4 ( obj -- str )
  138. {
  139. { case-const-1 [ "uno" ] }
  140. { case-const-2 [ "dos" ] }
  141. { 3 [ "tres" ] }
  142. { 4 [ "cuatro" ] }
  143. { 5 [ "cinco" ] }
  144. [ drop "demasiado" ]
  145. } case ;
  146. \ case-test-4 def>> must-infer
  147. [ "uno" ] [ 1 case-test-4 ] unit-test
  148. [ "dos" ] [ 2 case-test-4 ] unit-test
  149. [ "tres" ] [ 3 case-test-4 ] unit-test
  150. [ "demasiado" ] [ 100 case-test-4 ] unit-test
  151. [ "uno" ] [ 1 \ case-test-4 def>> call ] unit-test
  152. [ "dos" ] [ 2 \ case-test-4 def>> call ] unit-test
  153. [ "tres" ] [ 3 \ case-test-4 def>> call ] unit-test
  154. [ "demasiado" ] [ 100 \ case-test-4 def>> call ] unit-test
  155. : case-test-5 ( obj -- )
  156. {
  157. { case-const-1 [ "uno" print ] }
  158. { case-const-2 [ "dos" print ] }
  159. { 3 [ "tres" print ] }
  160. { 4 [ "cuatro" print ] }
  161. { 5 [ "cinco" print ] }
  162. [ drop "demasiado" print ]
  163. } case ;
  164. \ case-test-5 def>> must-infer
  165. [ ] [ 1 case-test-5 ] unit-test
  166. [ ] [ 1 \ case-test-5 def>> call ] unit-test
  167. : do-not-call ( -- * ) "do not call" throw ;
  168. : test-case-6 ( obj -- value )
  169. {
  170. { \ do-not-call [ "do-not-call" ] }
  171. { 3 [ "three" ] }
  172. } case ;
  173. \ test-case-6 def>> must-infer
  174. [ "three" ] [ 3 test-case-6 ] unit-test
  175. [ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
  176. [ t ] [ { 1 3 2 } contiguous-range? ] unit-test
  177. [ f ] [ { 1 2 2 4 } contiguous-range? ] unit-test
  178. [ f ] [ { + 3 2 } contiguous-range? ] unit-test
  179. [ f ] [ { 1 0 7 } contiguous-range? ] unit-test
  180. [ f ] [ { 1 1 3 7 } contiguous-range? ] unit-test
  181. [ t ] [ { 7 6 4 8 5 } contiguous-range? ] unit-test
  182. : test-case-7 ( obj -- str )
  183. {
  184. { \ + [ "plus" ] }
  185. { \ - [ "minus" ] }
  186. { \ * [ "times" ] }
  187. { \ / [ "divide" ] }
  188. { \ ^ [ "power" ] }
  189. { \ [ [ "obama" ] }
  190. } case ;
  191. \ test-case-7 def>> must-infer
  192. [ "plus" ] [ \ + test-case-7 ] unit-test
  193. [ "plus" ] [ \ + \ test-case-7 def>> call ] unit-test
  194. DEFER: corner-case-1
  195. << \ corner-case-1 2 [ + ] curry 1array [ case ] curry ( a -- b ) define-declared >>
  196. [ t ] [ \ corner-case-1 optimized? ] unit-test
  197. [ 4 ] [ 2 corner-case-1 ] unit-test
  198. [ 4 ] [ 2 \ corner-case-1 def>> call ] unit-test
  199. : test-case-8 ( n -- string )
  200. {
  201. { 1 [ "foo" ] }
  202. } case ;
  203. [ 3 test-case-8 ] [ object>> 3 = ] must-fail-with
  204. [ 3 \ test-case-8 def>> call ] [ object>> 3 = ] must-fail-with
  205. : test-case-9 ( a -- b )
  206. {
  207. { \ + [ "plus" ] }
  208. { \ + [ "plus 2" ] }
  209. { \ - [ "minus" ] }
  210. { \ - [ "minus 2" ] }
  211. } case ;
  212. [ "plus" ] [ \ + test-case-9 ] unit-test
  213. [ "plus" ] [ \ + \ test-case-9 def>> call ] unit-test
  214. [ "minus" ] [ \ - test-case-9 ] unit-test
  215. [ "minus" ] [ \ - \ test-case-9 def>> call ] unit-test
  216. : test-case-10 ( a -- b )
  217. {
  218. { 1 [ "uno" ] }
  219. { 2 [ "dos" ] }
  220. { 2 [ "DOS" ] }
  221. { 3 [ "tres" ] }
  222. { 4 [ "cuatro" ] }
  223. { 5 [ "cinco" ] }
  224. } case ;
  225. [ "dos" ] [ 2 test-case-10 ] unit-test
  226. [ "dos" ] [ 2 \ test-case-10 def>> call ] unit-test
  227. : test-case-11 ( a -- b )
  228. {
  229. { 11 [ "uno" ] }
  230. { 22 [ "dos" ] }
  231. { 22 [ "DOS" ] }
  232. { 33 [ "tres" ] }
  233. { 44 [ "cuatro" ] }
  234. { 55 [ "cinco" ] }
  235. } case ;
  236. [ "dos" ] [ 22 test-case-11 ] unit-test
  237. [ "dos" ] [ 22 \ test-case-11 def>> call ] unit-test
  238. : test-case-12 ( a -- b )
  239. {
  240. { 11 [ "uno" ] }
  241. { 22 [ "dos" ] }
  242. [ drop "nachos" ]
  243. { 33 [ "tres" ] }
  244. { 44 [ "cuatro" ] }
  245. { 55 [ "cinco" ] }
  246. } case ;
  247. [ "nachos" ] [ 33 test-case-12 ] unit-test
  248. [ "nachos" ] [ 33 \ test-case-12 def>> call ] unit-test
  249. [ ( x x -- x x ) ] [
  250. [ { [ ] [ ] } spread ] infer
  251. ] unit-test