test-suite/tests/eval.test

   1 ;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
   2 ;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 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   :use-module (ice-9 local-eval))
  24
  25
  26 (define exception:bad-expression
  27   (cons 'syntax-error "Bad expression"))
  28
  29 (define exception:failed-match
  30   (cons 'syntax-error "failed to match any pattern"))
  31
  32 (define exception:not-a-list
  33   (cons 'wrong-type-arg "Not a list"))
  34
  35 (define exception:wrong-length
  36   (cons 'wrong-type-arg "wrong length"))
  37
  38 ;;;
  39 ;;; miscellaneous
  40 ;;;
  41
  42 (define (documented? object)
  43   (not (not (object-documentation object))))
  44
  45
  46 ;;;
  47 ;;; memoization
  48 ;;;
  49
  50 (with-test-prefix "memoization"
  51
  52   (with-test-prefix "copy-tree"
  53
  54     (pass-if "(#t . #(#t))"
  55       (let* ((foo (cons #t (vector #t)))
  56              (bar (copy-tree foo)))
  57         (vector-set! (cdr foo) 0 #f)
  58         (equal? bar '(#t . #(#t)))))
  59
  60     (pass-if-exception "circular lists in forms"
  61       exception:wrong-type-arg
  62       (let ((foo (list #f)))
  63         (set-cdr! foo foo)
  64         (copy-tree foo))))
  65
  66   (pass-if "transparency"
  67     (let ((x '(begin 1)))
  68       (eval x (current-module))
  69       (equal? '(begin 1) x))))
  70
  71
  72 ;;;
  73 ;;; eval
  74 ;;;
  75
  76 (with-test-prefix "evaluator"
  77
  78   (pass-if "definitions return #<unspecified>"
  79     (eq? (primitive-eval '(define test-var 'foo))
  80          (if #f #f)))
  81
  82   (with-test-prefix "symbol lookup"
  83
  84     (with-test-prefix "top level"
  85
  86       (with-test-prefix "unbound"
  87
  88         (pass-if-exception "variable reference"
  89           exception:unbound-var
  90           x)
  91
  92         (pass-if-exception "procedure"
  93           exception:unbound-var
  94           (x)))))
  95
  96   (with-test-prefix "parameter error"
  97
  98     ;; This is currently a bug in guile:
  99     ;; Macros are accepted as function parameters.
 100     ;; Functions that 'apply' macros are rewritten!!!
 101
 102     (pass-if-exception "macro as argument"
 103       exception:failed-match
 104       (primitive-eval
 105        '(let ((f (lambda (p a b) (p a b))))
 106           (f and #t #t))))
 107
 108     (pass-if-exception "passing macro as parameter"
 109       exception:failed-match
 110       (primitive-eval
 111        '(let* ((f (lambda (p a b) (p a b)))
 112                (foo (procedure-source f)))
 113           (f and #t #t)
 114           (equal? (procedure-source f) foo))))
 115
 116     ))
 117
 118 ;;;
 119 ;;; call
 120 ;;;
 121
 122 (with-test-prefix "call"
 123
 124   (with-test-prefix "wrong number of arguments"
 125
 126     (pass-if-exception "((lambda () #f) 1)"
 127       exception:wrong-num-args
 128       ((lambda () #f) 1))
 129
 130     (pass-if-exception "((lambda (x) #f))"
 131       exception:wrong-num-args
 132       ((lambda (x) #f)))
 133
 134     (pass-if-exception "((lambda (x) #f) 1 2)"
 135       exception:wrong-num-args
 136       ((lambda (x) #f) 1 2))
 137
 138     (pass-if-exception "((lambda (x y) #f))"
 139       exception:wrong-num-args
 140       ((lambda (x y) #f)))
 141
 142     (pass-if-exception "((lambda (x y) #f) 1)"
 143       exception:wrong-num-args
 144       ((lambda (x y) #f) 1))
 145
 146     (pass-if-exception "((lambda (x y) #f) 1 2 3)"
 147       exception:wrong-num-args
 148       ((lambda (x y) #f) 1 2 3))
 149
 150     (pass-if-exception "((lambda (x . rest) #f))"
 151       exception:wrong-num-args
 152       ((lambda (x . rest) #f)))
 153
 154     (pass-if-exception "((lambda (x y . rest) #f))"
 155       exception:wrong-num-args
 156       ((lambda (x y . rest) #f)))
 157
 158     (pass-if-exception "((lambda (x y . rest) #f) 1)"
 159       exception:wrong-num-args
 160       ((lambda (x y . rest) #f) 1))))
 161
 162 ;;;
 163 ;;; apply
 164 ;;;
 165
 166 (with-test-prefix "apply"
 167
 168   (with-test-prefix "scm_tc7_subr_2o"
 169
 170     ;; prior to guile 1.6.9 and 1.8.1 this called the function with
 171     ;; SCM_UNDEFINED, which in the case of make-vector resulted in
 172     ;; wrong-type-arg, instead of the intended wrong-num-args
 173     (pass-if-exception "0 args" exception:wrong-num-args
 174       (apply make-vector '()))
 175
 176     (pass-if "1 arg"
 177       (vector? (apply make-vector '(1))))
 178
 179     (pass-if "2 args"
 180       (vector? (apply make-vector '(1 2))))
 181
 182     ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected
 183     (pass-if-exception "3 args" exception:wrong-num-args
 184       (apply make-vector '(1 2 3)))))
 185
 186 ;;;
 187 ;;; map
 188 ;;;
 189
 190 (with-test-prefix "map"
 191
 192   ;; Is documentation available?
 193
 194   (expect-fail "documented?"
 195     (documented? map))
 196
 197   (with-test-prefix "argument error"
 198
 199     (with-test-prefix "non list argument"
 200       #t)
 201
 202     (with-test-prefix "different length lists"
 203
 204       (pass-if-exception "first list empty"
 205         exception:wrong-length
 206         (map + '() '(1)))
 207
 208       (pass-if-exception "second list empty"
 209         exception:wrong-length
 210         (map + '(1) '()))
 211
 212       (pass-if-exception "first list shorter"
 213         exception:wrong-length
 214         (map + '(1) '(2 3)))
 215
 216       (pass-if-exception "second list shorter"
 217         exception:wrong-length
 218         (map + '(1 2) '(3)))
 219     )))
 220
 221 ;;;
 222 ;;; define with procedure-name
 223 ;;;
 224
 225 ;; names are only set on top-level procedures (currently), so these can't be
 226 ;; hidden in a let
 227 ;;
 228 (define foo-closure (lambda () "hello"))
 229 (define bar-closure foo-closure)
 230 ;; make sure that make-procedure-with-setter returns an anonymous
 231 ;; procedure-with-setter by passing it an anonymous getter.
 232 (define foo-pws (make-procedure-with-setter
 233                  (lambda (x) (car x))
 234                  (lambda (x y) (set-car! x y))))
 235 (define bar-pws foo-pws)
 236
 237 (with-test-prefix "define set procedure-name"
 238
 239   (pass-if "closure"
 240     (eq? 'foo-closure (procedure-name bar-closure)))
 241
 242   (expect-fail "procedure-with-setter" ; FIXME: `pass-if' when it's supported
 243     (eq? 'foo-pws (procedure-name bar-pws))))
 244
 245 ;;;
 246 ;;; promises
 247 ;;;
 248
 249 (with-test-prefix "promises"
 250
 251   (with-test-prefix "basic promise behaviour"
 252
 253     (pass-if "delay gives a promise"
 254       (promise? (delay 1)))
 255
 256     (pass-if "force evaluates a promise"
 257       (eqv? (force (delay (+ 1 2))) 3))
 258
 259     (pass-if "a forced promise is a promise"
 260       (let ((p (delay (+ 1 2))))
 261         (force p)
 262         (promise? p)))
 263
 264     (pass-if "forcing a forced promise works"
 265       (let ((p (delay (+ 1 2))))
 266         (force p)
 267         (eqv? (force p) 3)))
 268
 269     (pass-if "a promise is evaluated once"
 270       (let* ((x 1)
 271              (p (delay (+ x 1))))
 272         (force p)
 273         (set! x (+ x 1))
 274         (eqv? (force p) 2)))
 275
 276     (pass-if "a promise may call itself"
 277       (define p
 278         (let ((x 0))
 279           (delay
 280             (begin
 281               (set! x (+ x 1))
 282               (if (> x 1) x (force p))))))
 283       (eqv? (force p) 2))
 284
 285     (pass-if "a promise carries its environment"
 286       (let* ((x 1) (p #f))
 287         (let* ((x 2))
 288           (set! p (delay (+ x 1))))
 289         (eqv? (force p) 3)))
 290
 291     (pass-if "a forced promise does not reference its environment"
 292       (let* ((g (make-guardian))
 293              (p #f))
 294         (let* ((x (cons #f #f)))
 295           (g x)
 296           (set! p (delay (car x))))
 297         (force p)
 298         (gc)
 299         (if (not (equal? (g) (cons #f #f)))
 300             (throw 'unresolved)
 301             #t))))
 302
 303   (with-test-prefix "extended promise behaviour"
 304
 305     (pass-if-exception "forcing a non-promise object is not supported"
 306       exception:wrong-type-arg
 307       (force 1))
 308
 309     (pass-if "unmemoizing a promise"
 310       (display-backtrace
 311        (let ((stack #f))
 312          (false-if-exception
 313           (with-throw-handler #t
 314                               (lambda ()
 315                                 (let ((f (lambda (g) (delay (g)))))
 316                                   (force (f error))))
 317                               (lambda _
 318                                 (set! stack (make-stack #t)))))
 319          stack)
 320        (%make-void-port "w"))
 321       #t)))
 322
 323
 324 ;;;
 325 ;;; stacks
 326 ;;;
 327
 328 (define (stack->frames stack)
 329   ;; Return the list of frames comprising STACK.
 330   (unfold (lambda (i)
 331             (>= i (stack-length stack)))
 332           (lambda (i)
 333             (stack-ref stack i))
 334           1+
 335           0))
 336
 337 (with-test-prefix "stacks"
 338   (pass-if "stack involving a primitive"
 339     ;; The primitive involving the error must appear exactly once on the
 340     ;; stack.
 341     (catch 'result
 342       (lambda ()
 343         (start-stack 'foo
 344                      (with-throw-handler 'wrong-type-arg
 345                        (lambda ()
 346                          ;; Trigger a `wrong-type-arg' exception.
 347                          (hashq-ref 'wrong 'type 'arg))
 348                        (lambda _
 349                          (let* ((stack  (make-stack #t))
 350                                 (frames (stack->frames stack)))
 351                            (throw 'result
 352                                   (count (lambda (frame)
 353                                            (eq? (frame-procedure frame)
 354                                                 hashq-ref))
 355                                          frames)))))))
 356       (lambda (key result)
 357         (= 1 result))))
 358
 359   (pass-if "arguments of a primitive stack frame"
 360     ;; Create a stack with two primitive frames and make sure the
 361     ;; arguments are correct.
 362     (catch 'result
 363       (lambda ()
 364         (start-stack 'foo
 365                      (with-throw-handler 'wrong-type-arg
 366                        (lambda ()
 367                          ;; Trigger a `wrong-type-arg' exception.
 368                          (substring 'wrong 'type 'arg))
 369                        (lambda _
 370                          (let* ((stack  (make-stack #t))
 371                                 (frames (stack->frames stack)))
 372                            (throw 'result
 373                                   (map (lambda (frame)
 374                                          (cons (frame-procedure frame)
 375                                                (frame-arguments frame)))
 376                                        frames)))))))
 377       (lambda (key result)
 378         (and (equal? (car result) `(,make-stack #t))
 379              (pair? (member `(,substring  wrong type arg)
 380                             (cdr result))))))))
 381
 382 ;;;
 383 ;;; letrec init evaluation
 384 ;;;
 385
 386 (with-test-prefix "letrec init evaluation"
 387
 388   (pass-if "lots of inits calculated in correct order"
 389     (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
 390                      (e 'e) (f 'f) (g 'g) (h 'h)
 391                      (i 'i) (j 'j) (k 'k) (l 'l)
 392                      (m 'm) (n 'n) (o 'o) (p 'p)
 393                      (q 'q) (r 'r) (s 's) (t 't)
 394                      (u 'u) (v 'v) (w 'w) (x 'x)
 395                      (y 'y) (z 'z))
 396               (list a b c d e f g h i j k l m
 397                     n o p q r s t u v w x y z))
 398             '(a b c d e f g h i j k l m
 399               n o p q r s t u v w x y z))))
 400
 401 ;;;
 402 ;;; values
 403 ;;;
 404
 405 (with-test-prefix "values"
 406
 407   (pass-if "single value"
 408     (equal? 1 (values 1)))
 409
 410   (pass-if "call-with-values"
 411     (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
 412             '(1 2 3 4)))
 413
 414   (pass-if "equal?"
 415     (equal? (values 1 2 3 4) (values 1 2 3 4))))
 416
 417 ;;;
 418 ;;; stack overflow handling
 419 ;;;
 420
 421 (with-test-prefix "stack overflow"
 422
 423   ;; FIXME: this test does not test what it is intending to test
 424   (pass-if-exception "exception raised"
 425     exception:vm-error
 426     (let ((vm    (make-vm))
 427           (thunk (let loop () (cons 's (loop)))))
 428       (call-with-vm vm thunk))))
 429
 430 ;;;
 431 ;;; docstrings
 432 ;;;
 433
 434 (with-test-prefix "docstrings"
 435
 436   (pass-if-equal "fixed closure"
 437       '("hello" "world")
 438     (map procedure-documentation
 439          (list (eval '(lambda (a b) "hello" (+ a b))
 440                      (current-module))
 441                (eval '(lambda (a b) "world" (- a b))
 442                      (current-module)))))
 443
 444   (pass-if-equal "fixed closure with many args"
 445       "So many args."
 446     (procedure-documentation
 447      (eval '(lambda (a b c d e f g h i j k)
 448               "So many args."
 449               (+ a b))
 450            (current-module))))
 451
 452   (pass-if-equal "general closure"
 453       "How general."
 454     (procedure-documentation
 455      (eval '(lambda* (a b #:key k #:rest r)
 456               "How general."
 457               (+ a b))
 458            (current-module)))))
 459
 460 ;;;
 461 ;;; local-eval
 462 ;;;
 463
 464 (with-test-prefix "local evaluation"
 465
 466   (pass-if "local-eval"
 467
 468     (let* ((env1 (local-eval '(let ((x 1) (y 2) (z 3))
 469                                 (define-syntax-rule (foo x) (quote x))
 470                                 (the-environment))
 471                              (current-module)))
 472            (env2 (local-eval '(let ((x 111) (a 'a))
 473                                 (define-syntax-rule (bar x) (quote x))
 474                                 (the-environment))
 475                            env1)))
 476       (local-eval '(set! x 11) env1)
 477       (local-eval '(set! y 22) env1)
 478       (local-eval '(set! z 33) env2)
 479       (and (equal? (local-eval '(list x y z) env1)
 480                    '(11 22 33))
 481            (equal? (local-eval '(list x y z a) env2)
 482                    '(111 22 33 a)))))
 483
 484   (pass-if "local-compile"
 485
 486     (let* ((env1 (local-compile '(let ((x 1) (y 2) (z 3))
 487                                    (define-syntax-rule (foo x) (quote x))
 488                                    (the-environment))
 489                                 (current-module)))
 490            (env2 (local-compile '(let ((x 111) (a 'a))
 491                                    (define-syntax-rule (bar x) (quote x))
 492                                    (the-environment))
 493                                 env1)))
 494       (local-compile '(set! x 11) env1)
 495       (local-compile '(set! y 22) env1)
 496       (local-compile '(set! z 33) env2)
 497       (and (equal? (local-compile '(list x y z) env1)
 498                    '(11 22 33))
 499            (equal? (local-compile '(list x y z a) env2)
 500                    '(111 22 33 a)))))
 501
 502   (pass-if "the-environment within a macro"
 503     (let ((module-a-name '(test module the-environment a))
 504           (module-b-name '(test module the-environment b)))
 505       (let ((module-a (resolve-module module-a-name))
 506             (module-b (resolve-module module-b-name)))
 507         (module-use! module-a (resolve-interface '(guile)))
 508         (module-use! module-a (resolve-interface '(ice-9 local-eval)))
 509         (eval '(begin
 510                  (define z 3)
 511                  (define-syntax-rule (test)
 512                    (let ((x 1) (y 2))
 513                      (the-environment))))
 514               module-a)
 515         (module-use! module-b (resolve-interface '(guile)))
 516         (let ((env (local-eval `(let ((x 111) (y 222))
 517                                   ((@@ ,module-a-name test)))
 518                                module-b)))
 519           (equal? (local-eval '(list x y z) env)
 520                   '(1 2 3))))))
 521
 522   (pass-if "capture pattern variables"
 523     (let ((env (syntax-case #'(((a 1) (b 2) (c 3))
 524                                ((d 4) (e 5) (f 6))) ()
 525                  ((((k v) ...) ...) (the-environment)))))
 526       (equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env))
 527               '((a b c 1 2 3) (d e f 4 5 6)))))
 528
 529   (pass-if "mixed primitive-eval, local-eval and local-compile"
 530
 531     (let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3))
 532                                     (define-syntax-rule (foo x) (quote x))
 533                                     (the-environment))))
 534            (env2 (local-eval '(let ((x 111) (a 'a))
 535                                 (define-syntax-rule (bar x) (quote x))
 536                                 (the-environment))
 537                              env1))
 538            (env3 (local-compile '(let ((y 222) (b 'b))
 539                                    (the-environment))
 540                                 env2)))
 541       (local-eval    '(set! x 11) env1)
 542       (local-compile '(set! y 22) env2)
 543       (local-eval    '(set! z 33) env2)
 544       (local-compile '(set! a (* y 2)) env3)
 545       (and (equal? (local-compile '(list x y z) env1)
 546                    '(11 22 33))
 547            (equal? (local-eval '(list x y z a) env2)
 548                    '(111 22 33 444))
 549            (equal? (local-eval '(list x y z a b) env3)
 550                    '(111 222 33 444 b))))))
 551
 552 ;;; eval.test ends here