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