test-suite/tests/eval.test

   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
  18 (define-module (test-suite test-eval)
  19   :use-module (test-suite lib)
  20   :use-module ((srfi srfi-1) :select (unfold count))
  21   :use-module ((system vm vm) :select (make-vm call-with-vm))
  22   :use-module (ice-9 documentation))
  23
  24
  25 (define exception:bad-expression
  26   (cons 'syntax-error "Bad expression"))
  27
  28 (define exception:failed-match
  29   (cons 'syntax-error "failed to match any pattern"))
  30
  31 (define exception:not-a-list
  32   (cons 'wrong-type-arg "Not a list"))
  33
  34 (define exception:wrong-length
  35   (cons 'wrong-type-arg "wrong length"))
  36
  37 ;;;
  38 ;;; miscellaneous
  39 ;;;
  40
  41 (define (documented? object)
  42   (not (not (object-documentation object))))
  43
  44
  45 ;;;
  46 ;;; memoization
  47 ;;;
  48
  49 (with-test-prefix "memoization"
  50
  51   (with-test-prefix "copy-tree"
  52
  53     (pass-if "(#t . #(#t))"
  54       (let* ((foo (cons #t (vector #t)))
  55              (bar (copy-tree foo)))
  56         (vector-set! (cdr foo) 0 #f)
  57         (equal? bar '(#t . #(#t)))))
  58
  59     (pass-if-exception "circular lists in forms"
  60       exception:wrong-type-arg
  61       (let ((foo (list #f)))
  62         (set-cdr! foo foo)
  63         (copy-tree foo))))
  64
  65   (pass-if "transparency"
  66     (let ((x '(begin 1)))
  67       (eval x (current-module))
  68       (equal? '(begin 1) x))))
  69
  70
  71 ;;;
  72 ;;; eval
  73 ;;;
  74
  75 (with-test-prefix "evaluator"
  76
  77   (with-test-prefix "symbol lookup"
  78
  79     (with-test-prefix "top level"
  80
  81       (with-test-prefix "unbound"
  82
  83         (pass-if-exception "variable reference"
  84           exception:unbound-var
  85           x)
  86
  87         (pass-if-exception "procedure"
  88           exception:unbound-var
  89           (x)))))
  90
  91   (with-test-prefix "parameter error"
  92
  93     ;; This is currently a bug in guile:
  94     ;; Macros are accepted as function parameters.
  95     ;; Functions that 'apply' macros are rewritten!!!
  96
  97     (pass-if-exception "macro as argument"
  98       exception:failed-match
  99       (primitive-eval
 100        '(let ((f (lambda (p a b) (p a b))))
 101           (f and #t #t))))
 102
 103     (pass-if-exception "passing macro as parameter"
 104       exception:failed-match
 105       (primitive-eval
 106        '(let* ((f (lambda (p a b) (p a b)))
 107                (foo (procedure-source f)))
 108           (f and #t #t)
 109           (equal? (procedure-source f) foo))))
 110
 111     ))
 112
 113 ;;;
 114 ;;; call
 115 ;;;
 116
 117 (with-test-prefix "call"
 118
 119   (with-test-prefix "wrong number of arguments"
 120
 121     (pass-if-exception "((lambda () #f) 1)"
 122       exception:wrong-num-args
 123       ((lambda () #f) 1))
 124
 125     (pass-if-exception "((lambda (x) #f))"
 126       exception:wrong-num-args
 127       ((lambda (x) #f)))
 128
 129     (pass-if-exception "((lambda (x) #f) 1 2)"
 130       exception:wrong-num-args
 131       ((lambda (x) #f) 1 2))
 132
 133     (pass-if-exception "((lambda (x y) #f))"
 134       exception:wrong-num-args
 135       ((lambda (x y) #f)))
 136
 137     (pass-if-exception "((lambda (x y) #f) 1)"
 138       exception:wrong-num-args
 139       ((lambda (x y) #f) 1))
 140
 141     (pass-if-exception "((lambda (x y) #f) 1 2 3)"
 142       exception:wrong-num-args
 143       ((lambda (x y) #f) 1 2 3))
 144
 145     (pass-if-exception "((lambda (x . rest) #f))"
 146       exception:wrong-num-args
 147       ((lambda (x . rest) #f)))
 148
 149     (pass-if-exception "((lambda (x y . rest) #f))"
 150       exception:wrong-num-args
 151       ((lambda (x y . rest) #f)))
 152
 153     (pass-if-exception "((lambda (x y . rest) #f) 1)"
 154       exception:wrong-num-args
 155       ((lambda (x y . rest) #f) 1))))
 156
 157 ;;;
 158 ;;; apply
 159 ;;;
 160
 161 (with-test-prefix "apply"
 162
 163   (with-test-prefix "scm_tc7_subr_2o"
 164
 165     ;; prior to guile 1.6.9 and 1.8.1 this called the function with
 166     ;; SCM_UNDEFINED, which in the case of make-vector resulted in
 167     ;; wrong-type-arg, instead of the intended wrong-num-args
 168     (pass-if-exception "0 args" exception:wrong-num-args
 169       (apply make-vector '()))
 170
 171     (pass-if "1 arg"
 172       (vector? (apply make-vector '(1))))
 173
 174     (pass-if "2 args"
 175       (vector? (apply make-vector '(1 2))))
 176
 177     ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected
 178     (pass-if-exception "3 args" exception:wrong-num-args
 179       (apply make-vector '(1 2 3)))))
 180
 181 ;;;
 182 ;;; map
 183 ;;;
 184
 185 (with-test-prefix "map"
 186
 187   ;; Is documentation available?
 188
 189   (expect-fail "documented?"
 190     (documented? map))
 191
 192   (with-test-prefix "argument error"
 193
 194     (with-test-prefix "non list argument"
 195       #t)
 196
 197     (with-test-prefix "different length lists"
 198
 199       (pass-if-exception "first list empty"
 200         exception:wrong-length
 201         (map + '() '(1)))
 202
 203       (pass-if-exception "second list empty"
 204         exception:wrong-length
 205         (map + '(1) '()))
 206
 207       (pass-if-exception "first list shorter"
 208         exception:wrong-length
 209         (map + '(1) '(2 3)))
 210
 211       (pass-if-exception "second list shorter"
 212         exception:wrong-length
 213         (map + '(1 2) '(3)))
 214     )))
 215
 216 ;;;
 217 ;;; define with procedure-name
 218 ;;;
 219
 220 ;; names are only set on top-level procedures (currently), so these can't be
 221 ;; hidden in a let
 222 ;;
 223 (define foo-closure (lambda () "hello"))
 224 (define bar-closure foo-closure)
 225 ;; make sure that make-procedure-with-setter returns an anonymous
 226 ;; procedure-with-setter by passing it an anonymous getter.
 227 (define foo-pws (make-procedure-with-setter
 228                  (lambda (x) (car x))
 229                  (lambda (x y) (set-car! x y))))
 230 (define bar-pws foo-pws)
 231
 232 (with-test-prefix "define set procedure-name"
 233
 234   (pass-if "closure"
 235     (eq? 'foo-closure (procedure-name bar-closure)))
 236
 237   (expect-fail "procedure-with-setter" ; FIXME: `pass-if' when it's supported
 238     (eq? 'foo-pws (procedure-name bar-pws))))
 239
 240 ;;;
 241 ;;; promises
 242 ;;;
 243
 244 (with-test-prefix "promises"
 245
 246   (with-test-prefix "basic promise behaviour"
 247
 248     (pass-if "delay gives a promise"
 249       (promise? (delay 1)))
 250
 251     (pass-if "force evaluates a promise"
 252       (eqv? (force (delay (+ 1 2))) 3))
 253
 254     (pass-if "a forced promise is a promise"
 255       (let ((p (delay (+ 1 2))))
 256         (force p)
 257         (promise? p)))
 258
 259     (pass-if "forcing a forced promise works"
 260       (let ((p (delay (+ 1 2))))
 261         (force p)
 262         (eqv? (force p) 3)))
 263
 264     (pass-if "a promise is evaluated once"
 265       (let* ((x 1)
 266              (p (delay (+ x 1))))
 267         (force p)
 268         (set! x (+ x 1))
 269         (eqv? (force p) 2)))
 270
 271     (pass-if "a promise may call itself"
 272       (define p
 273         (let ((x 0))
 274           (delay
 275             (begin
 276               (set! x (+ x 1))
 277               (if (> x 1) x (force p))))))
 278       (eqv? (force p) 2))
 279
 280     (pass-if "a promise carries its environment"
 281       (let* ((x 1) (p #f))
 282         (let* ((x 2))
 283           (set! p (delay (+ x 1))))
 284         (eqv? (force p) 3)))
 285
 286     (pass-if "a forced promise does not reference its environment"
 287       (let* ((g (make-guardian))
 288              (p #f))
 289         (let* ((x (cons #f #f)))
 290           (g x)
 291           (set! p (delay (car x))))
 292         (force p)
 293         (gc)
 294         (if (not (equal? (g) (cons #f #f)))
 295             (throw 'unresolved)
 296             #t))))
 297
 298   (with-test-prefix "extended promise behaviour"
 299
 300     (pass-if-exception "forcing a non-promise object is not supported"
 301       exception:wrong-type-arg
 302       (force 1))
 303
 304     (pass-if "unmemoizing a promise"
 305       (display-backtrace
 306        (let ((stack #f))
 307          (false-if-exception
 308           (with-throw-handler #t
 309                               (lambda ()
 310                                 (let ((f (lambda (g) (delay (g)))))
 311                                   (force (f error))))
 312                               (lambda _
 313                                 (set! stack (make-stack #t)))))
 314          stack)
 315        (%make-void-port "w"))
 316       #t)))
 317
 318
 319 ;;;
 320 ;;; stacks
 321 ;;;
 322
 323 (define (stack->frames stack)
 324   ;; Return the list of frames comprising STACK.
 325   (unfold (lambda (i)
 326             (>= i (stack-length stack)))
 327           (lambda (i)
 328             (stack-ref stack i))
 329           1+
 330           0))
 331
 332 (with-test-prefix "stacks"
 333   (pass-if "stack involving a primitive"
 334     ;; The primitive involving the error must appear exactly once on the
 335     ;; stack.
 336     (catch 'result
 337       (lambda ()
 338         (start-stack 'foo
 339                      (with-throw-handler 'wrong-type-arg
 340                        (lambda ()
 341                          ;; Trigger a `wrong-type-arg' exception.
 342                          (hashq-ref 'wrong 'type 'arg))
 343                        (lambda _
 344                          (let* ((stack  (make-stack #t))
 345                                 (frames (stack->frames stack)))
 346                            (throw 'result
 347                                   (count (lambda (frame)
 348                                            (eq? (frame-procedure frame)
 349                                                 hashq-ref))
 350                                          frames)))))))
 351       (lambda (key result)
 352         (= 1 result))))
 353
 354   (pass-if "arguments of a primitive stack frame"
 355     ;; Create a stack with two primitive frames and make sure the
 356     ;; arguments are correct.
 357     (catch 'result
 358       (lambda ()
 359         (start-stack 'foo
 360                      (with-throw-handler 'wrong-type-arg
 361                        (lambda ()
 362                          ;; Trigger a `wrong-type-arg' exception.
 363                          (substring 'wrong 'type 'arg))
 364                        (lambda _
 365                          (let* ((stack  (make-stack #t))
 366                                 (frames (stack->frames stack)))
 367                            (throw 'result
 368                                   (map (lambda (frame)
 369                                          (cons (frame-procedure frame)
 370                                                (frame-arguments frame)))
 371                                        frames)))))))
 372       (lambda (key result)
 373         (and (equal? (car result) `(,make-stack #t))
 374              (pair? (member `(,substring  wrong type arg)
 375                             (cdr result))))))))
 376
 377 ;;;
 378 ;;; letrec init evaluation
 379 ;;;
 380
 381 (with-test-prefix "letrec init evaluation"
 382
 383   (pass-if "lots of inits calculated in correct order"
 384     (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
 385                      (e 'e) (f 'f) (g 'g) (h 'h)
 386                      (i 'i) (j 'j) (k 'k) (l 'l)
 387                      (m 'm) (n 'n) (o 'o) (p 'p)
 388                      (q 'q) (r 'r) (s 's) (t 't)
 389                      (u 'u) (v 'v) (w 'w) (x 'x)
 390                      (y 'y) (z 'z))
 391               (list a b c d e f g h i j k l m
 392                     n o p q r s t u v w x y z))
 393             '(a b c d e f g h i j k l m
 394               n o p q r s t u v w x y z))))
 395
 396 ;;;
 397 ;;; values
 398 ;;;
 399
 400 (with-test-prefix "values"
 401
 402   (pass-if "single value"
 403     (equal? 1 (values 1)))
 404
 405   (pass-if "call-with-values"
 406     (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
 407             '(1 2 3 4)))
 408
 409   (pass-if "equal?"
 410     (equal? (values 1 2 3 4) (values 1 2 3 4))))
 411
 412 ;;;
 413 ;;; stack overflow handling
 414 ;;;
 415
 416 (with-test-prefix "stack overflow"
 417
 418   ;; FIXME: this test does not test what it is intending to test
 419   (pass-if-exception "exception raised"
 420     exception:vm-error
 421     (let ((vm    (make-vm))
 422           (thunk (let loop () (cons 's (loop)))))
 423       (call-with-vm vm thunk))))
 424
 425 ;;; eval.test ends here