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 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 (define (make-tagged-trimmed-stack tag spec)
 338   (catch 'result
 339     (lambda ()
 340       (call-with-prompt
 341         tag
 342         (lambda ()
 343           (with-throw-handler 'wrong-type-arg
 344             (lambda () (substring 'wrong 'type 'arg))
 345             (lambda _ (throw 'result (apply make-stack spec)))))
 346         (lambda () (throw 'make-stack-failed))))
 347     (lambda (key result) result)))
 348
 349 (define tag (make-prompt-tag "foo"))
 350
 351 (with-test-prefix "stacks"
 352   ;; FIXME: Until we get one VM, a call to an RTL primitive from the
 353   ;; stack VM will result in the primitive being on the stack twice.
 354   (expect-fail "stack involving a primitive"
 355     ;; The primitive involving the error must appear exactly once on the
 356     ;; stack.
 357     (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
 358            (frames (stack->frames stack))
 359            (num (count (lambda (frame) (eq? (frame-procedure frame)
 360                                        substring))
 361                        frames)))
 362       (= num 1)))
 363
 364   (pass-if "arguments of a primitive stack frame"
 365     ;; Create a stack with two primitive frames and make sure the
 366     ;; arguments are correct.
 367     (let* ((stack (make-tagged-trimmed-stack tag '(#t)))
 368            (call-list (map (lambda (frame)
 369                              (cons (frame-procedure frame)
 370                                    (frame-arguments frame)))
 371                            (stack->frames stack))))
 372       (and (equal? (car call-list) `(,make-stack #t))
 373            (pair? (member `(,substring wrong type arg)
 374                           (cdr call-list))))))
 375
 376   (pass-if "inner trim with prompt tag"
 377     (let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag)))
 378            (frames (stack->frames stack)))
 379       ;; the top frame on the stack is the lambda inside the 'catch, and the
 380       ;; next frame is the (catch 'result ...)
 381       (and (eq? (frame-procedure (cadr frames))
 382                 catch)
 383            (eq? (car (frame-arguments (cadr frames)))
 384                 'result))))
 385
 386   (pass-if "outer trim with prompt tag"
 387     (let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag)))
 388            (frames (stack->frames stack)))
 389       ;; the top frame on the stack is the make-stack call, and the last
 390       ;; frame is the (with-throw-handler 'wrong-type-arg ...)
 391       (and (eq? (frame-procedure (car frames))
 392                 make-stack)
 393            (eq? (frame-procedure (car (last-pair frames)))
 394                 with-throw-handler)
 395            (eq? (car (frame-arguments (car (last-pair frames))))
 396                 'wrong-type-arg)))))
 397
 398 ;;;
 399 ;;; letrec init evaluation
 400 ;;;
 401
 402 (with-test-prefix "letrec init evaluation"
 403
 404   (pass-if "lots of inits calculated in correct order"
 405     (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
 406                      (e 'e) (f 'f) (g 'g) (h 'h)
 407                      (i 'i) (j 'j) (k 'k) (l 'l)
 408                      (m 'm) (n 'n) (o 'o) (p 'p)
 409                      (q 'q) (r 'r) (s 's) (t 't)
 410                      (u 'u) (v 'v) (w 'w) (x 'x)
 411                      (y 'y) (z 'z))
 412               (list a b c d e f g h i j k l m
 413                     n o p q r s t u v w x y z))
 414             '(a b c d e f g h i j k l m
 415               n o p q r s t u v w x y z))))
 416
 417 ;;;
 418 ;;; values
 419 ;;;
 420
 421 (with-test-prefix "values"
 422
 423   (pass-if "single value"
 424     (equal? 1 (values 1)))
 425
 426   (pass-if "call-with-values"
 427     (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
 428             '(1 2 3 4)))
 429
 430   (pass-if "equal?"
 431     (equal? (values 1 2 3 4) (values 1 2 3 4))))
 432
 433 ;;;
 434 ;;; stack overflow handling
 435 ;;;
 436
 437 (with-test-prefix "stack overflow"
 438
 439   ;; FIXME: this test does not test what it is intending to test
 440   (pass-if-exception "exception raised"
 441     exception:vm-error
 442     (let ((vm    (make-vm))
 443           (thunk (let loop () (cons 's (loop)))))
 444       (call-with-vm vm thunk))))
 445
 446 ;;;
 447 ;;; docstrings
 448 ;;;
 449
 450 (with-test-prefix "docstrings"
 451
 452   (pass-if-equal "fixed closure"
 453       '("hello" "world")
 454     (map procedure-documentation
 455          (list (eval '(lambda (a b) "hello" (+ a b))
 456                      (current-module))
 457                (eval '(lambda (a b) "world" (- a b))
 458                      (current-module)))))
 459
 460   (pass-if-equal "fixed closure with many args"
 461       "So many args."
 462     (procedure-documentation
 463      (eval '(lambda (a b c d e f g h i j k)
 464               "So many args."
 465               (+ a b))
 466            (current-module))))
 467
 468   (pass-if-equal "general closure"
 469       "How general."
 470     (procedure-documentation
 471      (eval '(lambda* (a b #:key k #:rest r)
 472               "How general."
 473               (+ a b))
 474            (current-module)))))
 475
 476 ;;;
 477 ;;; local-eval
 478 ;;;
 479
 480 (with-test-prefix "local evaluation"
 481
 482   (pass-if "local-eval"
 483
 484     (let* ((env1 (local-eval '(let ((x 1) (y 2) (z 3))
 485                                 (define-syntax-rule (foo x) (quote x))
 486                                 (the-environment))
 487                              (current-module)))
 488            (env2 (local-eval '(let ((x 111) (a 'a))
 489                                 (define-syntax-rule (bar x) (quote x))
 490                                 (the-environment))
 491                            env1)))
 492       (local-eval '(set! x 11) env1)
 493       (local-eval '(set! y 22) env1)
 494       (local-eval '(set! z 33) env2)
 495       (and (equal? (local-eval '(list x y z) env1)
 496                    '(11 22 33))
 497            (equal? (local-eval '(list x y z a) env2)
 498                    '(111 22 33 a)))))
 499
 500   (pass-if "local-compile"
 501
 502     (let* ((env1 (local-compile '(let ((x 1) (y 2) (z 3))
 503                                    (define-syntax-rule (foo x) (quote x))
 504                                    (the-environment))
 505                                 (current-module)))
 506            (env2 (local-compile '(let ((x 111) (a 'a))
 507                                    (define-syntax-rule (bar x) (quote x))
 508                                    (the-environment))
 509                                 env1)))
 510       (local-compile '(set! x 11) env1)
 511       (local-compile '(set! y 22) env1)
 512       (local-compile '(set! z 33) env2)
 513       (and (equal? (local-compile '(list x y z) env1)
 514                    '(11 22 33))
 515            (equal? (local-compile '(list x y z a) env2)
 516                    '(111 22 33 a)))))
 517
 518   (pass-if "the-environment within a macro"
 519     (let ((module-a-name '(test module the-environment a))
 520           (module-b-name '(test module the-environment b)))
 521       (let ((module-a (resolve-module module-a-name))
 522             (module-b (resolve-module module-b-name)))
 523         (module-use! module-a (resolve-interface '(guile)))
 524         (module-use! module-a (resolve-interface '(ice-9 local-eval)))
 525         (eval '(begin
 526                  (define z 3)
 527                  (define-syntax-rule (test)
 528                    (let ((x 1) (y 2))
 529                      (the-environment))))
 530               module-a)
 531         (module-use! module-b (resolve-interface '(guile)))
 532         (let ((env (local-eval `(let ((x 111) (y 222))
 533                                   ((@@ ,module-a-name test)))
 534                                module-b)))
 535           (equal? (local-eval '(list x y z) env)
 536                   '(1 2 3))))))
 537
 538   (pass-if "capture pattern variables"
 539     (let ((env (syntax-case #'(((a 1) (b 2) (c 3))
 540                                ((d 4) (e 5) (f 6))) ()
 541                  ((((k v) ...) ...) (the-environment)))))
 542       (equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env))
 543               '((a b c 1 2 3) (d e f 4 5 6)))))
 544
 545   (pass-if "mixed primitive-eval, local-eval and local-compile"
 546
 547     (let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3))
 548                                     (define-syntax-rule (foo x) (quote x))
 549                                     (the-environment))))
 550            (env2 (local-eval '(let ((x 111) (a 'a))
 551                                 (define-syntax-rule (bar x) (quote x))
 552                                 (the-environment))
 553                              env1))
 554            (env3 (local-compile '(let ((y 222) (b 'b))
 555                                    (the-environment))
 556                                 env2)))
 557       (local-eval    '(set! x 11) env1)
 558       (local-compile '(set! y 22) env2)
 559       (local-eval    '(set! z 33) env2)
 560       (local-compile '(set! a (* y 2)) env3)
 561       (and (equal? (local-compile '(list x y z) env1)
 562                    '(11 22 33))
 563            (equal? (local-eval '(list x y z a) env2)
 564                    '(111 22 33 444))
 565            (equal? (local-eval '(list x y z a b) env3)
 566                    '(111 222 33 444 b))))))
 567
 568 ;;; eval.test ends here