;;;; eval.test --- tests guile's evaluator -*- scheme -*-
-;;;; Copyright (C) 2000, 2001 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 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 2.1 of the License, or (at your option) any later version.
+;;;; 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
;;;;
;;;; 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+;;;; 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 (ice-9 documentation))
+ :use-module ((srfi srfi-1) :select (unfold count))
+ :use-module ((system vm vm) :select (make-vm call-with-vm))
+ :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
(equal? bar '(#t . #(#t)))))
(pass-if-exception "circular lists in forms"
- exception:bad-expression
+ exception:wrong-type-arg
(let ((foo (list #f)))
(set-cdr! foo foo)
(copy-tree foo))))
(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"
;; Macros are accepted as function parameters.
;; Functions that 'apply' macros are rewritten!!!
- (expect-fail-exception "macro as argument"
- exception:wrong-type-arg
- (let ((f (lambda (p a b) (p a b))))
- (f and #t #t)))
+ (pass-if-exception "macro as argument"
+ exception:failed-match
+ (primitive-eval
+ '(let ((f (lambda (p a b) (p a b))))
+ (f and #t #t))))
- (expect-fail-exception "passing macro as parameter"
- exception:wrong-type-arg
- (let* ((f (lambda (p a b) (p a b)))
- (foo (procedure-source f)))
- (f and #t #t)
- (equal? (procedure-source f) foo)))
+ (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))))
))
;;;
-;;; apply
+;;; call
;;;
-(with-test-prefix "application"
+(with-test-prefix "call"
(with-test-prefix "wrong number of arguments"
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 "different length lists"
(pass-if-exception "first list empty"
- exception:out-of-range
+ exception:wrong-length
(map + '() '(1)))
(pass-if-exception "second list empty"
- exception:out-of-range
+ exception:wrong-length
(map + '(1) '()))
(pass-if-exception "first list shorter"
- exception:out-of-range
+ exception:wrong-length
(map + '(1) '(2 3)))
(pass-if-exception "second list shorter"
- exception:out-of-range
+ exception:wrong-length
(map + '(1 2) '(3)))
)))
+;;;
+;;; 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
;;;
exception:wrong-type-arg
(force 1))
- (pass-if-exception "implicit forcing is not supported"
- exception:wrong-type-arg
- (+ (delay (* 3 7)) 13))))
+ (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 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 (lambda (frame)
+ (cons (frame-procedure frame)
+ (frame-arguments frame)))
+ (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? (frame-procedure (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? (frame-procedure (car frames))
+ make-stack)
+ (eq? (frame-procedure (car (last-pair frames)))
+ with-throw-handler)
+ (eq? (car (frame-arguments (car (last-pair frames))))
+ 'wrong-type-arg)))))
+
+;;;
+;;; 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"
+
+ ;; FIXME: this test does not test what it is intending to test
+ (pass-if-exception "exception raised"
+ exception:vm-error
+ (let ((vm (make-vm))
+ (thunk (let loop () (cons 's (loop)))))
+ (call-with-vm vm thunk))))
+
+;;;
+;;; 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