mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-12 16:50:22 +02:00
27337b6373
* libguile/gsubr.c: Define RTL stubs instead of stack VM stubs.
(SUBR_STUB_CODE, get_subr_stub_code): Adapt to return a uint32_t*
pointer instead of a SCM value.
(create_subr): Create RTL procedures instead of stack VM procedures.
For RTL procedures, the function pointer, name, and generic address
pointer go inline to the procedure, as free variables.
(scm_i_primitive_arity, scm_i_primitive_call_ip): New helpers.
(scm_c_make_gsubr, scm_c_define_gsubr, scm_c_make_gsubr_with_generic)
(scm_c_define_gsubr_with_generic): Adapt to create_gsubr being renamed
to create_subr.
Remove gsubr test code.
* libguile/gsubr.h (SCM_PRIMITIVE_P, SCM_PRIMITIVE_GENERIC_P): Only RTL
programs can be primitives now.
(SCM_SUBRF, SCM_SUBR_NAME, SCM_SUBR_GENERIC): These fields are now in
the RTL free variables, not the object table.
* libguile/programs.c (scm_i_rtl_program_name):
(scm_i_rtl_program_documentation):
(scm_i_rtl_program_properties):
(scm_i_rtl_program_minimum_arity): Implement these appropriately for
primitives, which lack debugging information.
(scm_primitive_p, scm_primitive_call_ip): New helpers.
* libguile/snarf.h: Remove static allocation for subrs. Since there is
nothing to allocate besides the program itself, which needs runtime
relocation, static allocation is not a win.
* system/vm/program.scm: Fix up various arity-related things for
primitives, which don't use ELF arity info.
* test-suite/tests/eval.test ("stack involving a primitive"): Add an
XFAIL until we get just one VM.
568 lines
16 KiB
Scheme
568 lines
16 KiB
Scheme
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
|
|
;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013 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)
|
|
: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)))
|
|
)))
|
|
|
|
;;;
|
|
;;; 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)
|
|
(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"
|
|
;; FIXME: Until we get one VM, a call to an RTL primitive from the
|
|
;; stack VM will result in the primitive being on the stack twice.
|
|
(expect-fail "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
|