rtl-compilation.test 6.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221
  1. ;;;; rtl-compilation.test --- test suite for compiling via bytecode -*- scheme -*-
  2. ;;;;
  3. ;;;; Copyright (C) 2013 Free Software Foundation, Inc.
  4. ;;;;
  5. ;;;; This library is free software; you can redistribute it and/or
  6. ;;;; modify it under the terms of the GNU Lesser General Public
  7. ;;;; License as published by the Free Software Foundation; either
  8. ;;;; version 3 of the License, or (at your option) any later version.
  9. ;;;;
  10. ;;;; This library is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13. ;;;; Lesser General Public License for more details.
  14. ;;;;
  15. ;;;; You should have received a copy of the GNU Lesser General Public
  16. ;;;; License along with this library; if not, write to the Free Software
  17. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18. (define-module (test-suite bytecode-compilation)
  19. #:use-module (test-suite lib)
  20. #:use-module (system base compile)
  21. #:use-module (system vm loader))
  22. (define* (compile-via-bytecode exp #:key peval? cse? (env (make-fresh-user-module)))
  23. (load-thunk-from-memory
  24. (compile exp #:env env #:to 'bytecode
  25. #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
  26. (define* (run-bytecode exp #:key (env (make-fresh-user-module)))
  27. (let ((thunk (compile-via-bytecode exp #:env env)))
  28. (save-module-excursion
  29. (lambda ()
  30. (set-current-module env)
  31. (thunk)))))
  32. (with-test-prefix "tail context"
  33. (pass-if-equal 1
  34. (run-bytecode '(let ((x 1)) x)))
  35. (pass-if-equal 1
  36. (run-bytecode 1))
  37. (pass-if-equal (if #f #f)
  38. (run-bytecode '(if #f #f)))
  39. (pass-if-equal "top-level define"
  40. (list (if #f #f) 1)
  41. (let ((mod (make-fresh-user-module)))
  42. (let ((result (run-bytecode '(define v 1) #:env mod)))
  43. (list result (module-ref mod 'v)))))
  44. (pass-if-equal "top-level set!"
  45. (list (if #f #f) 1)
  46. (let ((mod (make-fresh-user-module)))
  47. (module-define! mod 'v #f)
  48. (let ((result (run-bytecode '(set! v 1) #:env mod)))
  49. (list result (module-ref mod 'v)))))
  50. (pass-if-equal "top-level apply [single value]"
  51. 8
  52. (let ((mod (make-fresh-user-module)))
  53. (module-define! mod 'args '(2 3))
  54. (run-bytecode '(apply expt args) #:env mod)))
  55. (pass-if-equal "top-level apply [zero values]"
  56. '()
  57. (let ((mod (make-fresh-user-module)))
  58. (module-define! mod 'proc (lambda () (values)))
  59. (module-define! mod 'args '())
  60. (call-with-values
  61. (lambda () (run-bytecode '(apply proc args) #:env mod))
  62. list)))
  63. (pass-if-equal "top-level apply [two values]"
  64. '(1 2)
  65. (let ((mod (make-fresh-user-module)))
  66. (module-define! mod 'proc (lambda (n d) (floor/ n d)))
  67. (module-define! mod 'args '(5 3))
  68. (call-with-values
  69. (lambda () (run-bytecode '(apply proc args) #:env mod))
  70. list)))
  71. (pass-if-equal "call-with-values"
  72. '(1 2 3)
  73. ((run-bytecode '(lambda (n d)
  74. (call-with-values (lambda () (floor/ n d))
  75. (lambda (q r) (list q r (+ q r))))))
  76. 5 3))
  77. (pass-if-equal cons
  78. (run-bytecode 'cons))
  79. (pass-if-equal 1
  80. ((run-bytecode '(lambda () 1))))
  81. (pass-if-equal 1
  82. ((run-bytecode '(lambda (x) 1)) 2))
  83. (pass-if-equal 1
  84. ((run-bytecode '(lambda (x) x)) 1))
  85. (pass-if-equal 6
  86. ((((run-bytecode '(lambda (x)
  87. (lambda (y)
  88. (lambda (z)
  89. (+ x y z))))) 1) 2) 3))
  90. (pass-if-equal 1
  91. (run-bytecode '(identity 1)))
  92. (pass-if-equal '(1 . 2)
  93. (run-bytecode '(cons 1 2)))
  94. (pass-if-equal '(1 2)
  95. (call-with-values (lambda () (run-bytecode '(values 1 2))) list))
  96. (pass-if-equal 28
  97. ((run-bytecode '(lambda (x y z rest) (apply + x y z rest)))
  98. 2 3 5 '(7 11)))
  99. ;; prompts
  100. )
  101. (with-test-prefix "value context"
  102. 1
  103. )
  104. (with-test-prefix "drop context"
  105. 1
  106. )
  107. (with-test-prefix "test context"
  108. 1
  109. )
  110. (with-test-prefix "values context"
  111. (pass-if-equal '(3 . 1)
  112. (run-bytecode
  113. '(let ((rat (lambda (n d)
  114. (call-with-values
  115. (lambda () (floor/ n d))
  116. (lambda (q r)
  117. (cons q r))))))
  118. (rat 10 3)))))
  119. (with-test-prefix "contification"
  120. (pass-if ((run-bytecode '(lambda (x)
  121. (define (even? x)
  122. (if (null? x) #t (odd? (cdr x))))
  123. (define (odd? x)
  124. (if (null? x) #f (even? (cdr x))))
  125. (even? x)))
  126. '(1 2 3 4)))
  127. (pass-if (not ((run-bytecode '(lambda (x)
  128. (define (even? x)
  129. (if (null? x) #t (odd? (cdr x))))
  130. (define (odd? x)
  131. (if (null? x) #f (even? (cdr x))))
  132. (even? x)))
  133. '(1 2 3))))
  134. (pass-if-equal '(#t)
  135. ((run-bytecode '(lambda (x)
  136. (define (even? x)
  137. (if (null? x) #t (odd? (cdr x))))
  138. (define (odd? x)
  139. (if (null? x) #f (even? (cdr x))))
  140. (list (even? x))))
  141. '(1 2 3 4)))
  142. ;; An irreducible loop between even? and odd?.
  143. (pass-if-equal '#t
  144. ((run-bytecode '(lambda (x do-even?)
  145. (define (even? x)
  146. (if (null? x) #t (odd? (cdr x))))
  147. (define (odd? x)
  148. (if (null? x) #f (even? (cdr x))))
  149. (if do-even? (even? x) (odd? x))))
  150. '(1 2 3 4)
  151. #t)))
  152. (with-test-prefix "case-lambda"
  153. (pass-if-equal "simple"
  154. '(0 3 9 28)
  155. (let ((proc (run-bytecode '(case-lambda
  156. (() 0)
  157. ((x) x)
  158. ((x y) (+ x y))
  159. ((x y z . rest) (apply + x y z rest))))))
  160. (map (lambda (args) (apply proc args))
  161. '(() (3) (2 7) (2 3 5 7 11)))))
  162. (pass-if-exception "no match"
  163. exception:wrong-num-args
  164. ((run-bytecode '(case-lambda ((x) x) ((x y) (+ x y))))
  165. 1 2 3))
  166. (pass-if-exception "zero clauses called with no args"
  167. exception:wrong-num-args
  168. ((run-bytecode '(case-lambda))))
  169. (pass-if-exception "zero clauses called with args"
  170. exception:wrong-num-args
  171. ((run-bytecode '(case-lambda)) 1)))
  172. (with-test-prefix "mixed contexts"
  173. (pass-if-equal "sequences" '(3 4 5)
  174. (let* ((pair (cons 1 2))
  175. (result ((run-bytecode '(lambda (pair)
  176. (set-car! pair 3)
  177. (set-cdr! pair 4)
  178. 5))
  179. pair)))
  180. (list (car pair)
  181. (cdr pair)
  182. result)))
  183. (pass-if-equal "mutable lexicals" 2
  184. (run-bytecode '(let ((n 1)) (set! n 2) n))))