;;;; eval.test --- tests guile's evaluator -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011 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
:use-module (test-suite lib)
: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 documentation)
+ :use-module (ice-9 local-eval))
(define exception:bad-expression
(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"
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.
- (catch 'result
- (lambda ()
- (start-stack 'foo
- (with-throw-handler 'wrong-type-arg
- (lambda ()
- ;; Trigger a `wrong-type-arg' exception.
- (hashq-ref 'wrong 'type 'arg))
- (lambda _
- (let* ((stack (make-stack #t))
- (frames (stack->frames stack)))
- (throw 'result
- (count (lambda (frame)
- (eq? (frame-procedure frame)
- hashq-ref))
- frames)))))))
- (lambda (key result)
- (= 1 result))))
+ (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.
- (catch 'result
- (lambda ()
- (start-stack 'foo
- (with-throw-handler 'wrong-type-arg
- (lambda ()
- ;; Trigger a `wrong-type-arg' exception.
- (substring 'wrong 'type 'arg))
- (lambda _
- (let* ((stack (make-stack #t))
- (frames (stack->frames stack)))
- (throw 'result
- (map (lambda (frame)
- (cons (frame-procedure frame)
- (frame-arguments frame)))
- frames)))))))
- (lambda (key result)
- (and (equal? (car result) `(,make-stack #t))
- (pair? (member `(,substring wrong type arg)
- (cdr result))))))))
+ (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
(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
HCoop / bpt / guile.git / blobdiff