test-suite/tests/eval.test

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