mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
f4ca107f7f
* libguile/exceptions.c:
* libguile/exceptions.h: New files.
* libguile.h: Add exceptions.h.
* libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES):
(DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS): Add exceptions.c and
exceptions.h.
* libguile/init.c (scm_i_init_guile): Initialize exceptions.
* libguile/threads.c (scm_spawn_thread): Use new names for
scm_i_make_catch_handler and scm_c_make_thunk.
* libguile/throw.c: Rewrite to be implemented in terms of
with-exception-handler / raise-exception.
* libguile/throw.h: Use data types from exceptions.h. Move
scm_report_stack_overflow and scm_report_out_of_memory to
exceptions.[ch].
* module/ice-9/boot-9.scm (&error, &programming-error)
(&non-continuable, make-exception-from-throw, raise-exception)
(with-exception-handler): New top-level definitions.
(throw, catch, with-throw-handler): Rewrite in terms of
with-exception-handler and raise-exception.
: New top-level definitions.
* module/ice-9/exceptions.scm: Adapt to re-export &error,
&programming-error, &non-continuable, raise-exception, and
with-exception-handler from boot-9.
(make-quit-exception, guile-quit-exception-converter): New exception
converters.
(make-exception-from-throw): Override core binding.
* test-suite/tests/eval.test ("inner trim with prompt tag"): Adapt to
"with-exception-handler" being the procedure on the stack.
("outer trim with prompt tag"): Likewise.
* test-suite/tests/exceptions.test (throw-test): Use pass-if-equal.
* module/srfi/srfi-34.scm: Reimplement in terms of core exceptions, and
make "guard" actually re-raise continuations with the original "raise"
continuation.
655 lines
19 KiB
Scheme
655 lines
19 KiB
Scheme
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
|
|
;;;; Copyright (C) 2000-2001,2003-2015,2017,2019
|
|
;;;; 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 body of the catch, and the
|
|
;; next frame is the with-exception-handler corresponding to the
|
|
;; (catch 'result ...)
|
|
(eq? (car (frame-call-representation (cadr frames)))
|
|
'with-exception-handler)))
|
|
|
|
(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-exception-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
|