guile18/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 (define foo-pws (make-procedure-with-setter car set-car!))
 218 (define bar-pws foo-pws)
 219
 220 (with-test-prefix "define set procedure-name"
 221
 222   (pass-if "closure"
 223     (eq? 'foo-closure (procedure-name bar-closure)))
 224
 225   (pass-if "procedure-with-setter"
 226     (eq? 'foo-pws (pk (procedure-name bar-pws)))))
 227
 228 (if old-procnames-flag
 229     (debug-enable 'procnames)
 230     (debug-disable 'procnames))
 231
 232 ;;;
 233 ;;; promises
 234 ;;;
 235
 236 (with-test-prefix "promises"
 237
 238   (with-test-prefix "basic promise behaviour"
 239
 240     (pass-if "delay gives a promise"
 241       (promise? (delay 1)))
 242
 243     (pass-if "force evaluates a promise"
 244       (eqv? (force (delay (+ 1 2))) 3))
 245
 246     (pass-if "a forced promise is a promise"
 247       (let ((p (delay (+ 1 2))))
 248         (force p)
 249         (promise? p)))
 250
 251     (pass-if "forcing a forced promise works"
 252       (let ((p (delay (+ 1 2))))
 253         (force p)
 254         (eqv? (force p) 3)))
 255
 256     (pass-if "a promise is evaluated once"
 257       (let* ((x 1)
 258              (p (delay (+ x 1))))
 259         (force p)
 260         (set! x (+ x 1))
 261         (eqv? (force p) 2)))
 262
 263     (pass-if "a promise may call itself"
 264       (define p
 265         (let ((x 0))
 266           (delay
 267             (begin
 268               (set! x (+ x 1))
 269               (if (> x 1) x (force p))))))
 270       (eqv? (force p) 2))
 271
 272     (pass-if "a promise carries its environment"
 273       (let* ((x 1) (p #f))
 274         (let* ((x 2))
 275           (set! p (delay (+ x 1))))
 276         (eqv? (force p) 3)))
 277
 278     (pass-if "a forced promise does not reference its environment"
 279       (let* ((g (make-guardian))
 280              (p #f))
 281         (let* ((x (cons #f #f)))
 282           (g x)
 283           (set! p (delay (car x))))
 284         (force p)
 285         (gc)
 286         (if (not (equal? (g) (cons #f #f)))
 287             (throw 'unresolved)
 288             #t))))
 289
 290   (with-test-prefix "extended promise behaviour"
 291
 292     (pass-if-exception "forcing a non-promise object is not supported"
 293       exception:wrong-type-arg
 294       (force 1))
 295
 296     (pass-if-exception "implicit forcing is not supported"
 297       exception:wrong-type-arg
 298       (+ (delay (* 3 7)) 13))
 299
 300     ;; Tests that require the debugging evaluator...
 301     (with-debugging-evaluator
 302
 303       (pass-if "unmemoizing a promise"
 304         (display-backtrace
 305          (let ((stack #f))
 306            (false-if-exception (lazy-catch #t
 307                                            (lambda ()
 308                                              (let ((f (lambda (g) (delay (g)))))
 309                                                (force (f error))))
 310                                            (lambda _
 311                                              (set! stack (make-stack #t)))))
 312            stack)
 313          (%make-void-port "w"))
 314         #t))))
 315
 316
 317 ;;;
 318 ;;; stacks
 319 ;;;
 320
 321 (define (stack->frames stack)
 322   ;; Return the list of frames comprising STACK.
 323   (unfold (lambda (i)
 324             (>= i (stack-length stack)))
 325           (lambda (i)
 326             (stack-ref stack i))
 327           1+
 328           0))
 329
 330 (with-test-prefix "stacks"
 331   (with-debugging-evaluator
 332
 333     (pass-if "stack involving a subr"
 334       ;; The subr involving the error must appear exactly once on the stack.
 335       (catch 'result
 336         (lambda ()
 337           (start-stack 'foo
 338             (lazy-catch 'wrong-type-arg
 339               (lambda ()
 340                 ;; Trigger a `wrong-type-arg' exception.
 341                 (fluid-ref 'not-a-fluid))
 342               (lambda _
 343                 (let* ((stack  (make-stack #t))
 344                        (frames (stack->frames stack)))
 345                   (throw 'result
 346                          (count (lambda (frame)
 347                                   (and (frame-procedure? frame)
 348                                        (eq? (frame-procedure frame)
 349                                             fluid-ref)))
 350                                 frames)))))))
 351         (lambda (key result)
 352           (= 1 result))))
 353
 354     (pass-if "stack involving a gsubr"
 355       ;; The gsubr involving the error must appear exactly once on the stack.
 356       ;; This is less obvious since gsubr application may require an
 357       ;; additional `SCM_APPLY ()' call, which should not be visible to the
 358       ;; application.
 359       (catch 'result
 360         (lambda ()
 361           (start-stack 'foo
 362             (lazy-catch 'wrong-type-arg
 363               (lambda ()
 364                 ;; Trigger a `wrong-type-arg' exception.
 365                 (hashq-ref 'wrong 'type 'arg))
 366               (lambda _
 367                 (let* ((stack  (make-stack #t))
 368                        (frames (stack->frames stack)))
 369                   (throw 'result
 370                          (count (lambda (frame)
 371                                   (and (frame-procedure? frame)
 372                                        (eq? (frame-procedure frame)
 373                                             hashq-ref)))
 374                                 frames)))))))
 375         (lambda (key result)
 376           (= 1 result))))))
 377
 378 ;;;
 379 ;;; letrec init evaluation
 380 ;;;
 381
 382 (with-test-prefix "letrec init evaluation"
 383
 384   (pass-if "lots of inits calculated in correct order"
 385     (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd)
 386                      (e 'e) (f 'f) (g 'g) (h 'h)
 387                      (i 'i) (j 'j) (k 'k) (l 'l)
 388                      (m 'm) (n 'n) (o 'o) (p 'p)
 389                      (q 'q) (r 'r) (s 's) (t 't)
 390                      (u 'u) (v 'v) (w 'w) (x 'x)
 391                      (y 'y) (z 'z))
 392               (list a b c d e f g h i j k l m
 393                     n o p q r s t u v w x y z))
 394             '(a b c d e f g h i j k l m
 395               n o p q r s t u v w x y z))))
 396
 397 ;;;
 398 ;;; values
 399 ;;;
 400
 401 (with-test-prefix "values"
 402
 403   (pass-if "single value"
 404     (equal? 1 (values 1)))
 405
 406   (pass-if "call-with-values"
 407     (equal? (call-with-values (lambda () (values 1 2 3 4)) list)
 408             '(1 2 3 4)))
 409
 410   (pass-if "equal?"
 411     (equal? (values 1 2 3 4) (values 1 2 3 4))))
 412
 413 ;;; eval.test ends here