diff options
Diffstat (limited to 'test-suite/tests/eval.test')
-rw-r--r-- | test-suite/tests/eval.test | 655 |
1 files changed, 655 insertions, 0 deletions
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test new file mode 100644 index 000000000..8a52e11f2 --- /dev/null +++ b/test-suite/tests/eval.test @@ -0,0 +1,655 @@ +;;;; eval.test --- tests guile's evaluator -*- scheme -*- +;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite test-eval) + :use-module (test-suite lib) + :use-module ((srfi srfi-1) :select (unfold count)) + :use-module ((system vm vm) :select (call-with-stack-overflow-handler)) + :use-module ((system vm frame) :select (frame-call-representation)) + :use-module (ice-9 documentation) + :use-module (ice-9 local-eval)) + + +(define exception:bad-expression + (cons 'syntax-error "Bad expression")) + +(define exception:failed-match + (cons 'syntax-error "failed to match any pattern")) + +(define exception:not-a-list + (cons 'wrong-type-arg "Not a list")) + +(define exception:wrong-length + (cons 'wrong-type-arg "wrong length")) + +;;; +;;; miscellaneous +;;; + +(define (documented? object) + (not (not (object-documentation object)))) + + +;;; +;;; memoization +;;; + +(with-test-prefix "memoization" + + (with-test-prefix "copy-tree" + + (pass-if "(#t . #(#t))" + (let* ((foo (cons #t (vector #t))) + (bar (copy-tree foo))) + (vector-set! (cdr foo) 0 #f) + (equal? bar '(#t . #(#t))))) + + (pass-if-exception "circular lists in forms" + exception:wrong-type-arg + (let ((foo (list #f))) + (set-cdr! foo foo) + (copy-tree foo)))) + + (pass-if "transparency" + (let ((x '(begin 1))) + (eval x (current-module)) + (equal? '(begin 1) x)))) + + +;;; +;;; eval +;;; + +(with-test-prefix "evaluator" + + (pass-if "definitions return #<unspecified>" + (eq? (primitive-eval '(define test-var 'foo)) + (if #f #f))) + + (with-test-prefix "symbol lookup" + + (with-test-prefix "top level" + + (with-test-prefix "unbound" + + (pass-if-exception "variable reference" + exception:unbound-var + x) + + (pass-if-exception "procedure" + exception:unbound-var + (x))))) + + (with-test-prefix "parameter error" + + ;; This is currently a bug in guile: + ;; Macros are accepted as function parameters. + ;; Functions that 'apply' macros are rewritten!!! + + (pass-if-exception "macro as argument" + exception:failed-match + (primitive-eval + '(let ((f (lambda (p a b) (p a b)))) + (f and #t #t)))) + + (pass-if-exception "passing macro as parameter" + exception:failed-match + (primitive-eval + '(let* ((f (lambda (p a b) (p a b))) + (foo (procedure-source f))) + (f and #t #t) + (equal? (procedure-source f) foo)))) + + )) + +;;; +;;; call +;;; + +(with-test-prefix "call" + + (with-test-prefix "wrong number of arguments" + + (pass-if-exception "((lambda () #f) 1)" + exception:wrong-num-args + ((lambda () #f) 1)) + + (pass-if-exception "((lambda (x) #f))" + exception:wrong-num-args + ((lambda (x) #f))) + + (pass-if-exception "((lambda (x) #f) 1 2)" + exception:wrong-num-args + ((lambda (x) #f) 1 2)) + + (pass-if-exception "((lambda (x y) #f))" + exception:wrong-num-args + ((lambda (x y) #f))) + + (pass-if-exception "((lambda (x y) #f) 1)" + exception:wrong-num-args + ((lambda (x y) #f) 1)) + + (pass-if-exception "((lambda (x y) #f) 1 2 3)" + exception:wrong-num-args + ((lambda (x y) #f) 1 2 3)) + + (pass-if-exception "((lambda (x . rest) #f))" + exception:wrong-num-args + ((lambda (x . rest) #f))) + + (pass-if-exception "((lambda (x y . rest) #f))" + exception:wrong-num-args + ((lambda (x y . rest) #f))) + + (pass-if-exception "((lambda (x y . rest) #f) 1)" + exception:wrong-num-args + ((lambda (x y . rest) #f) 1)))) + +;;; +;;; apply +;;; + +(with-test-prefix "apply" + + (with-test-prefix "scm_tc7_subr_2o" + + ;; prior to guile 1.6.9 and 1.8.1 this called the function with + ;; SCM_UNDEFINED, which in the case of make-vector resulted in + ;; wrong-type-arg, instead of the intended wrong-num-args + (pass-if-exception "0 args" exception:wrong-num-args + (apply make-vector '())) + + (pass-if "1 arg" + (vector? (apply make-vector '(1)))) + + (pass-if "2 args" + (vector? (apply make-vector '(1 2)))) + + ;; prior to guile 1.6.9 and 1.8.1 this error wasn't detected + (pass-if-exception "3 args" exception:wrong-num-args + (apply make-vector '(1 2 3))))) + +;;; +;;; map +;;; + +(with-test-prefix "map" + + ;; Is documentation available? + + (expect-fail "documented?" + (documented? map)) + + (with-test-prefix "argument error" + + (with-test-prefix "non list argument" + #t) + + (with-test-prefix "different length lists" + + (pass-if-exception "first list empty" + exception:wrong-length + (map + '() '(1))) + + (pass-if-exception "second list empty" + exception:wrong-length + (map + '(1) '())) + + (pass-if-exception "first list shorter" + exception:wrong-length + (map + '(1) '(2 3))) + + (pass-if-exception "second list shorter" + exception:wrong-length + (map + '(1 2) '(3))) + ))) + +(with-test-prefix "for-each" + + (pass-if-exception "1 arg, non-list, even number of elements" + exception:not-a-list + (for-each values '(1 2 3 4 . 5))) + + (pass-if-exception "1 arg, non-list, odd number of elements" + exception:not-a-list + (for-each values '(1 2 3 . 4)))) + +;;; +;;; define with procedure-name +;;; + +;; names are only set on top-level procedures (currently), so these can't be +;; hidden in a let +;; +(define foo-closure (lambda () "hello")) +(define bar-closure foo-closure) +;; make sure that make-procedure-with-setter returns an anonymous +;; procedure-with-setter by passing it an anonymous getter. +(define foo-pws (make-procedure-with-setter + (lambda (x) (car x)) + (lambda (x y) (set-car! x y)))) +(define bar-pws foo-pws) + +(with-test-prefix "define set procedure-name" + + (pass-if "closure" + (eq? 'foo-closure (procedure-name bar-closure))) + + (expect-fail "procedure-with-setter" ; FIXME: `pass-if' when it's supported + (eq? 'foo-pws (procedure-name bar-pws)))) + +;;; +;;; promises +;;; + +(with-test-prefix "promises" + + (with-test-prefix "basic promise behaviour" + + (pass-if "delay gives a promise" + (promise? (delay 1))) + + (pass-if "force evaluates a promise" + (eqv? (force (delay (+ 1 2))) 3)) + + (pass-if "a forced promise is a promise" + (let ((p (delay (+ 1 2)))) + (force p) + (promise? p))) + + (pass-if "forcing a forced promise works" + (let ((p (delay (+ 1 2)))) + (force p) + (eqv? (force p) 3))) + + (pass-if "a promise is evaluated once" + (let* ((x 1) + (p (delay (+ x 1)))) + (force p) + (set! x (+ x 1)) + (eqv? (force p) 2))) + + (pass-if "a promise may call itself" + (define p + (let ((x 0)) + (delay + (begin + (set! x (+ x 1)) + (if (> x 1) x (force p)))))) + (eqv? (force p) 2)) + + (pass-if "a promise carries its environment" + (let* ((x 1) (p #f)) + (let* ((x 2)) + (set! p (delay (+ x 1)))) + (eqv? (force p) 3))) + + (pass-if "a forced promise does not reference its environment" + (let* ((g (make-guardian)) + (p #f)) + (let* ((x (cons #f #f))) + (g x) + (set! p (delay (car x)))) + (force p) + (gc) + ;; Though this test works reliably when running just eval.test, + ;; it often does the unresolved case when running the full + ;; suite. Adding this extra gc makes the full-suite behavior + ;; pass more reliably. + (gc) + (if (not (equal? (g) (cons #f #f))) + (throw 'unresolved) + #t)))) + + (with-test-prefix "extended promise behaviour" + + (pass-if-exception "forcing a non-promise object is not supported" + exception:wrong-type-arg + (force 1)) + + (pass-if "unmemoizing a promise" + (display-backtrace + (let ((stack #f)) + (false-if-exception + (with-throw-handler #t + (lambda () + (let ((f (lambda (g) (delay (g))))) + (force (f error)))) + (lambda _ + (set! stack (make-stack #t))))) + stack) + (%make-void-port "w")) + #t))) + + +;;; +;;; stacks +;;; + +(define (stack->frames stack) + ;; Return the list of frames comprising STACK. + (unfold (lambda (i) + (>= i (stack-length stack))) + (lambda (i) + (stack-ref stack i)) + 1+ + 0)) + +(define (make-tagged-trimmed-stack tag spec) + (catch 'result + (lambda () + (call-with-prompt + tag + (lambda () + (with-throw-handler 'wrong-type-arg + (lambda () (substring 'wrong 'type 'arg)) + (lambda _ (throw 'result (apply make-stack spec))))) + (lambda () (throw 'make-stack-failed)))) + (lambda (key result) result))) + +(define tag (make-prompt-tag "foo")) + +(with-test-prefix "stacks" + (pass-if "stack involving a primitive" + ;; The primitive involving the error must appear exactly once on the + ;; stack. + (let* ((stack (make-tagged-trimmed-stack tag '(#t))) + (frames (stack->frames stack)) + (num (count (lambda (frame) (eq? (frame-procedure-name frame) + 'substring)) + frames))) + (= num 1))) + + (pass-if "arguments of a primitive stack frame" + ;; Create a stack with two primitive frames and make sure the + ;; arguments are correct. + (let* ((stack (make-tagged-trimmed-stack tag '(#t))) + (call-list (map frame-call-representation (stack->frames stack)))) + (and (equal? (car call-list) '(make-stack #t)) + (pair? (member '(substring wrong type arg) + (cdr call-list)))))) + + (pass-if "inner trim with prompt tag" + (let* ((stack (make-tagged-trimmed-stack tag `(#t ,tag))) + (frames (stack->frames stack))) + ;; the top frame on the stack is the lambda inside the 'catch, and the + ;; next frame is the (catch 'result ...) + (and (eq? (car (frame-call-representation (cadr frames))) + 'catch) + (eq? (car (frame-arguments (cadr frames))) + 'result)))) + + (pass-if "outer trim with prompt tag" + (let* ((stack (make-tagged-trimmed-stack tag `(#t 0 ,tag))) + (frames (stack->frames stack))) + ;; the top frame on the stack is the make-stack call, and the last + ;; frame is the (with-throw-handler 'wrong-type-arg ...) + (and (eq? (car (frame-call-representation (car frames))) + 'make-stack) + (eq? (car (frame-call-representation (car (last-pair frames)))) + 'with-throw-handler))))) + +;;; +;;; letrec init evaluation +;;; + +(with-test-prefix "letrec init evaluation" + + (pass-if "lots of inits calculated in correct order" + (equal? (letrec ((a 'a) (b 'b) (c 'c) (d 'd) + (e 'e) (f 'f) (g 'g) (h 'h) + (i 'i) (j 'j) (k 'k) (l 'l) + (m 'm) (n 'n) (o 'o) (p 'p) + (q 'q) (r 'r) (s 's) (t 't) + (u 'u) (v 'v) (w 'w) (x 'x) + (y 'y) (z 'z)) + (list a b c d e f g h i j k l m + n o p q r s t u v w x y z)) + '(a b c d e f g h i j k l m + n o p q r s t u v w x y z)))) + +;;; +;;; values +;;; + +(with-test-prefix "values" + + (pass-if "single value" + (equal? 1 (values 1))) + + (pass-if "call-with-values" + (equal? (call-with-values (lambda () (values 1 2 3 4)) list) + '(1 2 3 4))) + + (pass-if "equal?" + (equal? (values 1 2 3 4) (values 1 2 3 4)))) + +;;; +;;; stack overflow handling +;;; + +(with-test-prefix "stack overflow handlers" + (define (trigger-overflow) + (trigger-overflow) + (error "not reached")) + + (define (dynwind-test n) + (catch 'foo + (lambda () + (call-with-stack-overflow-handler n + (lambda () + (dynamic-wind (lambda () #t) + trigger-overflow + trigger-overflow)) + (lambda () + (throw 'foo)))) + (lambda _ #t))) + + (pass-if-exception "limit should be number" + exception:wrong-type-arg + (call-with-stack-overflow-handler #t + trigger-overflow trigger-overflow)) + + (pass-if-exception "limit should be exact integer" + exception:wrong-type-arg + (call-with-stack-overflow-handler 2.0 + trigger-overflow trigger-overflow)) + + (pass-if-exception "limit should be nonnegative" + exception:out-of-range + (call-with-stack-overflow-handler -1 + trigger-overflow trigger-overflow)) + + (pass-if-exception "limit should be positive" + exception:out-of-range + (call-with-stack-overflow-handler 0 + trigger-overflow trigger-overflow)) + + (pass-if-exception "limit should be within address space" + exception:out-of-range + (call-with-stack-overflow-handler (ash 1 64) + trigger-overflow trigger-overflow)) + + (pass-if "exception on overflow" + (catch 'foo + (lambda () + (call-with-stack-overflow-handler 10000 + trigger-overflow + (lambda () + (throw 'foo)))) + (lambda _ #t))) + + (pass-if "exception on overflow with dynwind" + ;; Try all limits between 1 and 200 words. + (let lp ((n 1)) + (or (= n 200) + (and (dynwind-test n) + (lp (1+ n)))))) + + (pass-if-exception "overflow handler should return number" + exception:wrong-type-arg + (call-with-stack-overflow-handler 1000 + trigger-overflow + (lambda () #t))) + (pass-if-exception "overflow handler should return exact integer" + exception:wrong-type-arg + (call-with-stack-overflow-handler 1000 + trigger-overflow + (lambda () 2.0))) + (pass-if-exception "overflow handler should be nonnegative" + exception:out-of-range + (call-with-stack-overflow-handler 1000 + trigger-overflow + (lambda () -1))) + (pass-if-exception "overflow handler should be positive" + exception:out-of-range + (call-with-stack-overflow-handler 1000 + trigger-overflow + (lambda () 0))) + + (letrec ((fac (lambda (n) + (if (zero? n) 1 (* n (fac (1- n))))))) + (pass-if-equal "overflow handler can allow recursion to continue" + (fac 10) + (call-with-stack-overflow-handler 1 + (lambda () (fac 10)) + (lambda () 1))))) + +;;; +;;; docstrings +;;; + +(with-test-prefix "docstrings" + + (pass-if-equal "fixed closure" + '("hello" "world") + (map procedure-documentation + (list (eval '(lambda (a b) "hello" (+ a b)) + (current-module)) + (eval '(lambda (a b) "world" (- a b)) + (current-module))))) + + (pass-if-equal "fixed closure with many args" + "So many args." + (procedure-documentation + (eval '(lambda (a b c d e f g h i j k) + "So many args." + (+ a b)) + (current-module)))) + + (pass-if-equal "general closure" + "How general." + (procedure-documentation + (eval '(lambda* (a b #:key k #:rest r) + "How general." + (+ a b)) + (current-module))))) + +;;; +;;; local-eval +;;; + +(with-test-prefix "local evaluation" + + (pass-if "local-eval" + + (let* ((env1 (local-eval '(let ((x 1) (y 2) (z 3)) + (define-syntax-rule (foo x) (quote x)) + (the-environment)) + (current-module))) + (env2 (local-eval '(let ((x 111) (a 'a)) + (define-syntax-rule (bar x) (quote x)) + (the-environment)) + env1))) + (local-eval '(set! x 11) env1) + (local-eval '(set! y 22) env1) + (local-eval '(set! z 33) env2) + (and (equal? (local-eval '(list x y z) env1) + '(11 22 33)) + (equal? (local-eval '(list x y z a) env2) + '(111 22 33 a))))) + + (pass-if "local-compile" + + (let* ((env1 (local-compile '(let ((x 1) (y 2) (z 3)) + (define-syntax-rule (foo x) (quote x)) + (the-environment)) + (current-module))) + (env2 (local-compile '(let ((x 111) (a 'a)) + (define-syntax-rule (bar x) (quote x)) + (the-environment)) + env1))) + (local-compile '(set! x 11) env1) + (local-compile '(set! y 22) env1) + (local-compile '(set! z 33) env2) + (and (equal? (local-compile '(list x y z) env1) + '(11 22 33)) + (equal? (local-compile '(list x y z a) env2) + '(111 22 33 a))))) + + (pass-if "the-environment within a macro" + (let ((module-a-name '(test module the-environment a)) + (module-b-name '(test module the-environment b))) + (let ((module-a (resolve-module module-a-name)) + (module-b (resolve-module module-b-name))) + (module-use! module-a (resolve-interface '(guile))) + (module-use! module-a (resolve-interface '(ice-9 local-eval))) + (eval '(begin + (define z 3) + (define-syntax-rule (test) + (let ((x 1) (y 2)) + (the-environment)))) + module-a) + (module-use! module-b (resolve-interface '(guile))) + (let ((env (local-eval `(let ((x 111) (y 222)) + ((@@ ,module-a-name test))) + module-b))) + (equal? (local-eval '(list x y z) env) + '(1 2 3)))))) + + (pass-if "capture pattern variables" + (let ((env (syntax-case #'(((a 1) (b 2) (c 3)) + ((d 4) (e 5) (f 6))) () + ((((k v) ...) ...) (the-environment))))) + (equal? (syntax->datum (local-eval '#'((k ... v ...) ...) env)) + '((a b c 1 2 3) (d e f 4 5 6))))) + + (pass-if "mixed primitive-eval, local-eval and local-compile" + + (let* ((env1 (primitive-eval '(let ((x 1) (y 2) (z 3)) + (define-syntax-rule (foo x) (quote x)) + (the-environment)))) + (env2 (local-eval '(let ((x 111) (a 'a)) + (define-syntax-rule (bar x) (quote x)) + (the-environment)) + env1)) + (env3 (local-compile '(let ((y 222) (b 'b)) + (the-environment)) + env2))) + (local-eval '(set! x 11) env1) + (local-compile '(set! y 22) env2) + (local-eval '(set! z 33) env2) + (local-compile '(set! a (* y 2)) env3) + (and (equal? (local-compile '(list x y z) env1) + '(11 22 33)) + (equal? (local-eval '(list x y z a) env2) + '(111 22 33 444)) + (equal? (local-eval '(list x y z a b) env3) + '(111 222 33 444 b)))))) + +;;; eval.test ends here |