mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
ea9f4f4b15
* libguile/vm.h (scm_c_vm_run): Make internal.
* libguile/vm.c (vm_default_engine): New static global variable.
(make_vm): Set vp->engine based on
(scm_vm_apply): Remove in favor of call-with-vm.
(scm_thread_vm, scm_set_thread_vm_x): Remove these, as they did not
have a well-defined meaning, and were dangerous to call on other
threads.
(scm_the_vm): Reinstate previous definition.
(symbol_to_vm_engine, vm_engine_to_symbol)
(vm_has_pending_computation): New helpers.
(scm_vm_engine, scm_set_vm_engine_x, scm_c_set_vm_engine_x): New
accessors for VM engines.
(scm_c_set_default_vm_engine_x, scm_set_default_vm_engine_x): New
setters for the default VM engine.
(scm_call_with_vm): New function, applies a procedure to arguments in
a context in which a given VM is current.
* libguile/eval.c (eval, scm_apply): VM dispatch goes through
scm_call_with_vm.
* test-suite/tests/control.test ("the-vm"):
* module/system/vm/coverage.scm (with-code-coverage): Use call-with-vm.
* module/system/vm/vm.scm: Update exports.
* test-suite/vm/run-vm-tests.scm (run-vm-program):
* test-suite/tests/compiler.test ("current-reader"): Just rely on the
result of make-program being an applicable.
* test-suite/tests/eval.test ("stack overflow"): Add a note that this
test does not test what it should.
449 lines
12 KiB
Scheme
449 lines
12 KiB
Scheme
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
|
|
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010 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 (make-vm call-with-vm))
|
|
:use-module (ice-9 documentation))
|
|
|
|
|
|
(define exception:bad-expression
|
|
(cons 'syntax-error "Bad expression"))
|
|
|
|
(define exception:failed-match
|
|
(cons 'syntax-error "failed to match any pattern"))
|
|
|
|
|
|
;;;
|
|
;;; 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"
|
|
|
|
(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:out-of-range
|
|
(map + '() '(1)))
|
|
|
|
(pass-if-exception "second list empty"
|
|
exception:out-of-range
|
|
(map + '(1) '()))
|
|
|
|
(pass-if-exception "first list shorter"
|
|
exception:out-of-range
|
|
(map + '(1) '(2 3)))
|
|
|
|
(pass-if-exception "second list shorter"
|
|
exception:out-of-range
|
|
(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"
|
|
|
|
(expect-fail "closure"
|
|
(eq? 'foo-closure (procedure-name bar-closure)))
|
|
|
|
(expect-fail "procedure-with-setter"
|
|
(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)
|
|
(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))
|
|
|
|
(with-test-prefix "stacks"
|
|
(with-debugging-evaluator
|
|
|
|
(pass-if "stack involving a subr"
|
|
;; The subr involving the error must appear exactly once on the stack.
|
|
(catch 'result
|
|
(lambda ()
|
|
(throw 'unresolved)
|
|
(start-stack 'foo
|
|
(lazy-catch 'wrong-type-arg
|
|
(lambda ()
|
|
;; Trigger a `wrong-type-arg' exception.
|
|
(fluid-ref 'not-a-fluid))
|
|
(lambda _
|
|
(let* ((stack (make-stack #t))
|
|
(frames (stack->frames stack)))
|
|
(throw 'result
|
|
(count (lambda (frame)
|
|
(and (frame-procedure? frame)
|
|
(eq? (frame-procedure frame)
|
|
fluid-ref)))
|
|
frames)))))))
|
|
(lambda (key result)
|
|
(= 1 result))))
|
|
|
|
(pass-if "stack involving a gsubr"
|
|
;; The gsubr involving the error must appear exactly once on the stack.
|
|
;; This is less obvious since gsubr application may require an
|
|
;; additional `SCM_APPLY ()' call, which should not be visible to the
|
|
;; application.
|
|
(catch 'result
|
|
(lambda ()
|
|
(throw 'unresolved)
|
|
(start-stack 'foo
|
|
(lazy-catch '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)
|
|
(and (frame-procedure? frame)
|
|
(eq? (frame-procedure frame)
|
|
hashq-ref)))
|
|
frames)))))))
|
|
(lambda (key result)
|
|
(= 1 result))))
|
|
|
|
(pass-if "arguments of a gsubr stack frame"
|
|
;; Create a stack with two gsubr frames and make sure the arguments are
|
|
;; correct.
|
|
(catch 'result
|
|
(lambda ()
|
|
(throw 'unresolved)
|
|
(start-stack 'foo
|
|
(lazy-catch '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)))))))))
|
|
|
|
;;;
|
|
;;; 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))))
|
|
|
|
;;; eval.test ends here
|