test-suite/tests/eval.test

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