eval.test 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455
  1. ;;;; eval.test --- tests guile's evaluator -*- scheme -*-
  2. ;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc.
  3. ;;;;
  4. ;;;; This library is free software; you can redistribute it and/or
  5. ;;;; modify it under the terms of the GNU Lesser General Public
  6. ;;;; License as published by the Free Software Foundation; either
  7. ;;;; version 3 of the License, or (at your option) any later version.
  8. ;;;;
  9. ;;;; This library is distributed in the hope that it will be useful,
  10. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;;;; Lesser General Public License for more details.
  13. ;;;;
  14. ;;;; You should have received a copy of the GNU Lesser General Public
  15. ;;;; License along with this library; if not, write to the Free Software
  16. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17. (define-module (test-suite test-eval)
  18. :use-module (test-suite lib)
  19. :use-module ((srfi srfi-1) :select (unfold count))
  20. :use-module ((system vm vm) :select (make-vm call-with-vm))
  21. :use-module (ice-9 documentation))
  22. (define exception:bad-expression
  23. (cons 'syntax-error "Bad expression"))
  24. (define exception:failed-match
  25. (cons 'syntax-error "failed to match any pattern"))
  26. (define exception:not-a-list
  27. (cons 'wrong-type-arg "Not a list"))
  28. (define exception:wrong-length
  29. (cons 'wrong-type-arg "wrong length"))
  30. ;;;
  31. ;;; miscellaneous
  32. ;;;
  33. (define (documented? object)
  34. (not (not (object-documentation object))))
  35. ;;;
  36. ;;; memoization
  37. ;;;
  38. (with-test-prefix "memoization"
  39. (with-test-prefix "copy-tree"
  40. (pass-if "(#t . #(#t))"
  41. (let* ((foo (cons #t (vector #t)))
  42. (bar (copy-tree foo)))
  43. (vector-set! (cdr foo) 0 #f)
  44. (equal? bar '(#t . #(#t)))))
  45. (pass-if-exception "circular lists in forms"
  46. exception:wrong-type-arg
  47. (let ((foo (list #f)))
  48. (set-cdr! foo foo)
  49. (copy-tree foo))))
  50. (pass-if "transparency"
  51. (let ((x '(begin 1)))
  52. (eval x (current-module))
  53. (equal? '(begin 1) x))))
  54. ;;;
  55. ;;; eval
  56. ;;;
  57. (with-test-prefix "evaluator"
  58. (with-test-prefix "symbol lookup"
  59. (with-test-prefix "top level"
  60. (with-test-prefix "unbound"
  61. (pass-if-exception "variable reference"
  62. exception:unbound-var
  63. x)
  64. (pass-if-exception "procedure"
  65. exception:unbound-var
  66. (x)))))
  67. (with-test-prefix "parameter error"
  68. ;; This is currently a bug in guile:
  69. ;; Macros are accepted as function parameters.
  70. ;; Functions that 'apply' macros are rewritten!!!
  71. (pass-if-exception "macro as argument"
  72. exception:failed-match
  73. (primitive-eval
  74. '(let ((f (lambda (p a b) (p a b))))
  75. (f and #t #t))))
  76. (pass-if-exception "passing macro as parameter"
  77. exception:failed-match
  78. (primitive-eval
  79. '(let* ((f (lambda (p a b) (p a b)))
  80. (foo (procedure-source f)))
  81. (f and #t #t)
  82. (equal? (procedure-source f) foo))))
  83. ))
  84. ;;;
  85. ;;; call
  86. ;;;
  87. (with-test-prefix "call"
  88. (with-test-prefix "wrong number of arguments"
  89. (pass-if-exception "((lambda () #f) 1)"
  90. exception:wrong-num-args
  91. ((lambda () #f) 1))
  92. (pass-if-exception "((lambda (x) #f))"
  93. exception:wrong-num-args
  94. ((lambda (x) #f)))
  95. (pass-if-exception "((lambda (x) #f) 1 2)"
  96. exception:wrong-num-args
  97. ((lambda (x) #f) 1 2))
  98. (pass-if-exception "((lambda (x y) #f))"
  99. exception:wrong-num-args
  100. ((lambda (x y) #f)))
  101. (pass-if-exception "((lambda (x y) #f) 1)"
  102. exception:wrong-num-args
  103. ((lambda (x y) #f) 1))
  104. (pass-if-exception "((lambda (x y) #f) 1 2 3)"
  105. exception:wrong-num-args
  106. ((lambda (x y) #f) 1 2 3))
  107. (pass-if-exception "((lambda (x . rest) #f))"
  108. exception:wrong-num-args
  109. ((lambda (x . rest) #f)))
  110. (pass-if-exception "((lambda (x y . rest) #f))"
  111. exception:wrong-num-args
  112. ((lambda (x y . rest) #f)))
  113. (pass-if-exception "((lambda (x y . rest) #f) 1)"
  114. exception:wrong-num-args
  115. ((lambda (x y . rest) #f) 1))))
  116. ;;;
  117. ;;; apply
  118. ;;;
  119. (with-test-prefix "apply"
  120. (with-test-prefix "scm_tc7_subr_2o"
  121. ;; prior to guile 1.6.9 and 1.8.1 this called the function with
  122. ;; SCM_UNDEFINED, which in the case of make-vector resulted in
  123. ;; wrong-type-arg, instead of the intended wrong-num-args
  124. (pass-if-exception "0 args" exception:wrong-num-args
  125. (apply make-vector '()))
  126. (pass-if "1 arg"
  127. (vector? (apply make-vector '(1))))
  128. (pass-if "2 args"
  129. (vector? (apply make-vector '(1 2))))
  130. ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected
  131. (pass-if-exception "3 args" exception:wrong-num-args
  132. (apply make-vector '(1 2 3)))))
  133. ;;;
  134. ;;; map
  135. ;;;
  136. (with-test-prefix "map"
  137. ;; Is documentation available?
  138. (expect-fail "documented?"
  139. (documented? map))
  140. (with-test-prefix "argument error"
  141. (with-test-prefix "non list argument"
  142. #t)
  143. (with-test-prefix "different length lists"
  144. (pass-if-exception "first list empty"
  145. exception:wrong-length
  146. (map + '() '(1)))
  147. (pass-if-exception "second list empty"
  148. exception:wrong-length
  149. (map + '(1) '()))
  150. (pass-if-exception "first list shorter"
  151. exception:wrong-length
  152. (map + '(1) '(2 3)))
  153. (pass-if-exception "second list shorter"
  154. exception:wrong-length
  155. (map + '(1 2) '(3)))
  156. )))
  157. ;;;
  158. ;;; define with procedure-name
  159. ;;;
  160. ;; names are only set on top-level procedures (currently), so these can't be
  161. ;; hidden in a let
  162. ;;
  163. (define foo-closure (lambda () "hello"))
  164. (define bar-closure foo-closure)
  165. ;; make sure that make-procedure-with-setter returns an anonymous
  166. ;; procedure-with-setter by passing it an anonymous getter.
  167. (define foo-pws (make-procedure-with-setter
  168. (lambda (x) (car x))
  169. (lambda (x y) (set-car! x y))))
  170. (define bar-pws foo-pws)
  171. (with-test-prefix "define set procedure-name"
  172. (expect-fail "closure"
  173. (eq? 'foo-closure (procedure-name bar-closure)))
  174. (expect-fail "procedure-with-setter"
  175. (eq? 'foo-pws (procedure-name bar-pws))))
  176. ;;;
  177. ;;; promises
  178. ;;;
  179. (with-test-prefix "promises"
  180. (with-test-prefix "basic promise behaviour"
  181. (pass-if "delay gives a promise"
  182. (promise? (delay 1)))
  183. (pass-if "force evaluates a promise"
  184. (eqv? (force (delay (+ 1 2))) 3))
  185. (pass-if "a forced promise is a promise"
  186. (let ((p (delay (+ 1 2))))
  187. (force p)
  188. (promise? p)))
  189. (pass-if "forcing a forced promise works"
  190. (let ((p (delay (+ 1 2))))
  191. (force p)
  192. (eqv? (force p) 3)))
  193. (pass-if "a promise is evaluated once"
  194. (let* ((x 1)
  195. (p (delay (+ x 1))))
  196. (force p)
  197. (set! x (+ x 1))
  198. (eqv? (force p) 2)))
  199. (pass-if "a promise may call itself"
  200. (define p
  201. (let ((x 0))
  202. (delay
  203. (begin
  204. (set! x (+ x 1))
  205. (if (> x 1) x (force p))))))
  206. (eqv? (force p) 2))
  207. (pass-if "a promise carries its environment"
  208. (let* ((x 1) (p #f))
  209. (let* ((x 2))
  210. (set! p (delay (+ x 1))))
  211. (eqv? (force p) 3)))
  212. (pass-if "a forced promise does not reference its environment"
  213. (let* ((g (make-guardian))
  214. (p #f))
  215. (let* ((x (cons #f #f)))
  216. (g x)
  217. (set! p (delay (car x))))
  218. (force p)
  219. (gc)
  220. (if (not (equal? (g) (cons #f #f)))
  221. (throw 'unresolved)
  222. #t))))
  223. (with-test-prefix "extended promise behaviour"
  224. (pass-if-exception "forcing a non-promise object is not supported"
  225. exception:wrong-type-arg
  226. (force 1))
  227. (pass-if "unmemoizing a promise"
  228. (display-backtrace
  229. (let ((stack #f))
  230. (false-if-exception
  231. (with-throw-handler #t
  232. (lambda ()
  233. (let ((f (lambda (g) (delay (g)))))
  234. (force (f error))))
  235. (lambda _
  236. (set! stack (make-stack #t)))))
  237. stack)
  238. (%make-void-port "w"))
  239. #t)))
  240. ;;;
  241. ;;; stacks
  242. ;;;
  243. (define (stack->frames stack)
  244. ;; Return the list of frames comprising STACK.
  245. (unfold (lambda (i)
  246. (>= i (stack-length stack)))
  247. (lambda (i)
  248. (stack-ref stack i))
  249. 1+
  250. 0))
  251. (with-test-prefix "stacks"
  252. (with-debugging-evaluator
  253. (pass-if "stack involving a subr"
  254. ;; The subr involving the error must appear exactly once on the stack.
  255. (catch 'result
  256. (lambda ()
  257. (throw 'unresolved)
  258. (start-stack 'foo
  259. (lazy-catch 'wrong-type-arg
  260. (lambda ()
  261. ;; Trigger a `wrong-type-arg' exception.
  262. (fluid-ref 'not-a-fluid))
  263. (lambda _
  264. (let* ((stack (make-stack #t))
  265. (frames (stack->frames stack)))
  266. (throw 'result
  267. (count (lambda (frame)
  268. (and (frame-procedure? frame)
  269. (eq? (frame-procedure frame)
  270. fluid-ref)))
  271. frames)))))))
  272. (lambda (key result)
  273. (= 1 result))))
  274. (pass-if "stack involving a gsubr"
  275. ;; The gsubr involving the error must appear exactly once on the stack.
  276. ;; This is less obvious since gsubr application may require an
  277. ;; additional `SCM_APPLY ()' call, which should not be visible to the
  278. ;; application.
  279. (catch 'result
  280. (lambda ()
  281. (throw 'unresolved)
  282. (start-stack 'foo
  283. (lazy-catch 'wrong-type-arg
  284. (lambda ()
  285. ;; Trigger a `wrong-type-arg' exception.
  286. (hashq-ref 'wrong 'type 'arg))
  287. (lambda _
  288. (let* ((stack (make-stack #t))
  289. (frames (stack->frames stack)))
  290. (throw 'result
  291. (count (lambda (frame)
  292. (and (frame-procedure? frame)
  293. (eq? (frame-procedure frame)
  294. hashq-ref)))
  295. frames)))))))
  296. (lambda (key result)
  297. (= 1 result))))
  298. (pass-if "arguments of a gsubr stack frame"
  299. ;; Create a stack with two gsubr frames and make sure the arguments are
  300. ;; correct.
  301. (catch 'result
  302. (lambda ()
  303. (throw 'unresolved)
  304. (start-stack 'foo
  305. (lazy-catch 'wrong-type-arg
  306. (lambda ()
  307. ;; Trigger a `wrong-type-arg' exception.
  308. (substring 'wrong 'type 'arg))
  309. (lambda _
  310. (let* ((stack (make-stack #t))
  311. (frames (stack->frames stack)))
  312. (throw 'result
  313. (map (lambda (frame)
  314. (cons (frame-procedure frame)
  315. (frame-arguments frame)))
  316. frames)))))))
  317. (lambda (key result)
  318. (and (equal? (car result) `(,make-stack #t))
  319. (pair? (member `(,substring wrong type arg)
  320. (cdr result)))))))))
  321. ;;;
  322. ;;; letrec init evaluation
  323. ;;;
  324. (with-test-prefix "letrec init evaluation"
  325. (pass-if "lots of inits calculated in correct order"
  326. (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
  327. (e 'e) (f 'f) (g 'g) (h 'h)
  328. (i 'i) (j 'j) (k 'k) (l 'l)
  329. (m 'm) (n 'n) (o 'o) (p 'p)
  330. (q 'q) (r 'r) (s 's) (t 't)
  331. (u 'u) (v 'v) (w 'w) (x 'x)
  332. (y 'y) (z 'z))
  333. (list a b c d e f g h i j k l m
  334. n o p q r s t u v w x y z))
  335. '(a b c d e f g h i j k l m
  336. n o p q r s t u v w x y z))))
  337. ;;;
  338. ;;; values
  339. ;;;
  340. (with-test-prefix "values"
  341. (pass-if "single value"
  342. (equal? 1 (values 1)))
  343. (pass-if "call-with-values"
  344. (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
  345. '(1 2 3 4)))
  346. (pass-if "equal?"
  347. (equal? (values 1 2 3 4) (values 1 2 3 4))))
  348. ;;;
  349. ;;; stack overflow handling
  350. ;;;
  351. (with-test-prefix "stack overflow"
  352. ;; FIXME: this test does not test what it is intending to test
  353. (pass-if-exception "exception raised"
  354. exception:vm-error
  355. (let ((vm (make-vm))
  356. (thunk (let loop () (cons 's (loop)))))
  357. (call-with-vm vm thunk))))
  358. ;;; eval.test ends here