test-suite/tests/eval.test

   1 ;;;; eval.test --- tests guile's evaluator     -*- scheme -*-
   2 ;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009 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:bad-expression
  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_UNDEFIEND, 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   (pass-if "closure"
 232     (eq? 'foo-closure (procedure-name bar-closure)))
 233
 234   (pass-if "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     ;; Tests that require the debugging evaluator...
 310     (with-debugging-evaluator
 311
 312       (pass-if "unmemoizing a promise"
 313         (display-backtrace
 314          (let ((stack #f))
 315            (false-if-exception (lazy-catch #t
 316                                            (lambda ()
 317                                              (let ((f (lambda (g) (delay (g)))))
 318                                                (force (f error))))
 319                                            (lambda _
 320                                              (set! stack (make-stack #t)))))
 321            stack)
 322          (%make-void-port "w"))
 323         #t))))
 324
 325
 326 ;;;
 327 ;;; stacks
 328 ;;;
 329
 330 (define (stack->frames stack)
 331   ;; Return the list of frames comprising STACK.
 332   (unfold (lambda (i)
 333             (>= i (stack-length stack)))
 334           (lambda (i)
 335             (stack-ref stack i))
 336           1+
 337           0))
 338
 339 (with-test-prefix "stacks"
 340   (with-debugging-evaluator
 341
 342     (pass-if "stack involving a subr"
 343       ;; The subr involving the error must appear exactly once on the stack.
 344       (catch 'result
 345         (lambda ()
 346           (start-stack 'foo
 347             (lazy-catch 'wrong-type-arg
 348               (lambda ()
 349                 ;; Trigger a `wrong-type-arg' exception.
 350                 (fluid-ref 'not-a-fluid))
 351               (lambda _
 352                 (let* ((stack  (make-stack #t))
 353                        (frames (stack->frames stack)))
 354                   (throw 'result
 355                          (count (lambda (frame)
 356                                   (and (frame-procedure? frame)
 357                                        (eq? (frame-procedure frame)
 358                                             fluid-ref)))
 359                                 frames)))))))
 360         (lambda (key result)
 361           (= 1 result))))
 362
 363     (pass-if "stack involving a gsubr"
 364       ;; The gsubr involving the error must appear exactly once on the stack.
 365       ;; This is less obvious since gsubr application may require an
 366       ;; additional `SCM_APPLY ()' call, which should not be visible to the
 367       ;; application.
 368       (catch 'result
 369         (lambda ()
 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 ;;;
 388 ;;; letrec init evaluation
 389 ;;;
 390
 391 (with-test-prefix "letrec init evaluation"
 392
 393   (pass-if "lots of inits calculated in correct order"
 394     (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
 395                      (e 'e) (f 'f) (g 'g) (h 'h)
 396                      (i 'i) (j 'j) (k 'k) (l 'l)
 397                      (m 'm) (n 'n) (o 'o) (p 'p)
 398                      (q 'q) (r 'r) (s 's) (t 't)
 399                      (u 'u) (v 'v) (w 'w) (x 'x)
 400                      (y 'y) (z 'z))
 401               (list a b c d e f g h i j k l m
 402                     n o p q r s t u v w x y z))
 403             '(a b c d e f g h i j k l m
 404               n o p q r s t u v w x y z))))
 405
 406 ;;;
 407 ;;; values
 408 ;;;
 409
 410 (with-test-prefix "values"
 411
 412   (pass-if "single value"
 413     (equal? 1 (values 1)))
 414
 415   (pass-if "call-with-values"
 416     (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
 417             '(1 2 3 4)))
 418
 419   (pass-if "equal?"
 420     (equal? (values 1 2 3 4) (values 1 2 3 4))))
 421
 422 ;;; eval.test ends here