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