/core/kernel/kernel-tests.factor

http://github.com/abeaumont/factor · Factor · 192 lines · 124 code · 58 blank · 10 comment · 30 complexity · 93c6e55a2bb0087cee1693ca49df5ffd MD5 · raw file

  1. USING: arrays byte-arrays kernel kernel.private math memory
  2. namespaces sequences tools.test math.private quotations
  3. continuations prettyprint io.streams.string debugger assocs
  4. sequences.private accessors locals.backend grouping words
  5. system alien alien.accessors ;
  6. IN: kernel.tests
  7. [ 0 ] [ f size ] unit-test
  8. [ t ] [ [ \ = \ = ] all-equal? ] unit-test
  9. ! Don't leak extra roots if error is thrown
  10. [ ] [ 1000 [ [ 3 throw ] ignore-errors ] times ] unit-test
  11. [ ] [ 1000 [ [ -1 f <array> ] ignore-errors ] times ] unit-test
  12. ! Make sure we report the correct error on stack underflow
  13. [ clear drop ] [ { "kernel-error" 10 f f } = ] must-fail-with
  14. [ ] [ :c ] unit-test
  15. [ 3 [ { } set-retainstack ] dip ] [ { "kernel-error" 12 f f } = ] must-fail-with
  16. [ ] [ :c ] unit-test
  17. : overflow-d ( -- ) 3 overflow-d ;
  18. : (overflow-d-alt) ( -- n ) 3 ;
  19. : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
  20. : overflow-r ( -- ) 3 load-local overflow-r ;
  21. <<
  22. { overflow-d (overflow-d-alt) overflow-d-alt overflow-r }
  23. [ t "no-compile" set-word-prop ] each
  24. >>
  25. [ overflow-d ] [ { "kernel-error" 11 f f } = ] must-fail-with
  26. [ ] [ :c ] unit-test
  27. [ overflow-d-alt ] [ { "kernel-error" 11 f f } = ] must-fail-with
  28. [ ] [ [ :c ] with-string-writer drop ] unit-test
  29. [ overflow-r ] [ { "kernel-error" 13 f f } = ] must-fail-with
  30. [ ] [ :c ] unit-test
  31. : overflow-c ( -- ) overflow-c overflow-c ;
  32. ! The VM cannot recover from callstack overflow on Windows,
  33. ! because no facility exists to run memory protection
  34. ! fault handlers on an alternate callstack.
  35. os windows? [
  36. [ overflow-c ] [ { "kernel-error" 15 f f } = ] must-fail-with
  37. ] unless
  38. [ -7 <byte-array> ] must-fail
  39. [ 3 ] [ t 3 and ] unit-test
  40. [ f ] [ f 3 and ] unit-test
  41. [ f ] [ 3 f and ] unit-test
  42. [ 4 ] [ 4 6 or ] unit-test
  43. [ 6 ] [ f 6 or ] unit-test
  44. [ f ] [ 1 2 xor ] unit-test
  45. [ 1 ] [ 1 f xor ] unit-test
  46. [ 2 ] [ f 2 xor ] unit-test
  47. [ f ] [ f f xor ] unit-test
  48. [ dip ] must-fail
  49. [ ] [ :c ] unit-test
  50. [ 1 [ call ] dip ] must-fail
  51. [ ] [ :c ] unit-test
  52. [ 1 2 [ call ] dip ] must-fail
  53. [ ] [ :c ] unit-test
  54. [ 5 ] [ 1 [ 2 2 + ] dip + ] unit-test
  55. [ [ ] keep ] must-fail
  56. [ 6 ] [ 2 [ sq ] keep + ] unit-test
  57. [ [ ] 2keep ] must-fail
  58. [ 1 [ ] 2keep ] must-fail
  59. [ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test
  60. [ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test
  61. [ 4 ] [ 2 [ sq ] [ 0 ] if* ] unit-test
  62. [ 0 ] [ f [ 0 ] unless* ] unit-test
  63. [ t ] [ t [ "Hello" ] unless* ] unit-test
  64. [ "2\n" ] [ [ 1 2 [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
  65. [ "9\n" ] [ [ 3 f [ . ] [ sq . ] ?if ] with-string-writer ] unit-test
  66. [ f ] [ f (clone) ] unit-test
  67. [ -123 ] [ -123 (clone) ] unit-test
  68. [ 6 2 ] [ 1 2 [ 5 + ] dip ] unit-test
  69. [ ] [ callstack set-callstack ] unit-test
  70. [ 3drop datastack ] must-fail
  71. [ ] [ :c ] unit-test
  72. ! Doesn't compile; important
  73. : foo ( a -- b ) ;
  74. << \ foo t "no-compile" set-word-prop >>
  75. [ drop foo ] must-fail
  76. [ ] [ :c ] unit-test
  77. ! Regression
  78. : (loop) ( a b c d -- )
  79. [ pick ] dip swap [ pick ] dip swap
  80. < [ [ 1 + ] 3dip (loop) ] [ 4drop ] if ; inline recursive
  81. : loop ( obj -- )
  82. H{ } values swap [ dup length swap ] dip [ 0 ] 3dip (loop) ;
  83. [ loop ] must-fail
  84. ! Discovered on Windows
  85. : total-failure-1 ( -- a ) "" [ ] map unimplemented ;
  86. [ total-failure-1 ] must-fail
  87. [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] tri@ ] unit-test
  88. [ 1 4 9 ] [ 1 2 3 [ sq ] tri@ ] unit-test
  89. [ [ sq ] tri@ ] must-infer
  90. [ 4 ] [ 1 { [ 1 ] [ 2 ] } dispatch sq ] unit-test
  91. ! Test traceback accuracy
  92. : last-frame ( -- pair )
  93. error-continuation get call>> callstack>array 6 head* 3 tail* ;
  94. [
  95. { [ 1 2 [ 3 throw ] call 4 ] [ 1 2 [ 3 throw ] call 4 ] 3 }
  96. ] [
  97. [ [ 1 2 [ 3 throw ] call 4 ] call ] ignore-errors
  98. last-frame
  99. ] unit-test
  100. [
  101. { [ 1 2 [ 3 throw ] dip 4 ] [ 1 2 [ 3 throw ] dip 4 ] 3 }
  102. ] [
  103. [ [ 1 2 [ 3 throw ] dip 4 ] call ] ignore-errors
  104. last-frame
  105. ] unit-test
  106. [
  107. { [ 1 2 3 throw [ ] call 4 ] [ 1 2 3 throw [ ] call 4 ] 3 }
  108. ] [
  109. [ [ 1 2 3 throw [ ] call 4 ] call ] ignore-errors
  110. last-frame
  111. ] unit-test
  112. [
  113. { [ 1 2 3 throw [ ] dip 4 ] [ 1 2 3 throw [ ] dip 4 ] 3 }
  114. ] [
  115. [ [ 1 2 3 throw [ ] dip 4 ] call ] ignore-errors
  116. last-frame
  117. ] unit-test
  118. [
  119. { [ 1 2 3 throw [ ] [ ] if 4 ] [ 1 2 3 throw [ ] [ ] if 4 ] 3 }
  120. ] [
  121. [ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors
  122. last-frame
  123. ] unit-test
  124. [ 10 2 3 4 5 ] [ 1 2 3 4 5 [ 10 * ] 4dip ] unit-test
  125. [ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
  126. [ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
  127. [ t ] [ { } identity-hashcode fixnum? ] unit-test
  128. [ 123 ] [ 123 identity-hashcode ] unit-test
  129. [ t ] [ f identity-hashcode fixnum? ] unit-test
  130. ! Make sure memory protection faults work
  131. [ f 0 alien-unsigned-1 ] [ vm-error? ] must-fail-with
  132. [ 1 <alien> 0 alien-unsigned-1 ] [ vm-error? ] must-fail-with
  133. { 1 2 3 1 2 3 } [ 1 2 3 3dup ] unit-test
  134. { 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4dup ] unit-test