test-suite/tests/eval.test

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