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