summaryrefslogtreecommitdiff
path: root/test-suite
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite')
-rw-r--r--test-suite/Makefile.am2
-rw-r--r--test-suite/standalone/test-num2integral.c21
-rw-r--r--test-suite/tests/00-socket.test (renamed from test-suite/tests/socket.test)7
-rw-r--r--test-suite/tests/asm-to-bytecode.test7
-rw-r--r--test-suite/tests/cse.test125
-rw-r--r--test-suite/tests/elisp-compiler.test136
-rw-r--r--test-suite/tests/eval.test86
-rw-r--r--test-suite/tests/foreign.test4
-rw-r--r--test-suite/tests/peval.test487
-rw-r--r--test-suite/tests/procprop.test8
-rw-r--r--test-suite/tests/r6rs-records-syntactic.test14
-rw-r--r--test-suite/tests/regexp.test2
-rw-r--r--test-suite/tests/syntax.test68
-rw-r--r--test-suite/tests/tree-il.test96
-rw-r--r--test-suite/tests/vlist.test4
-rw-r--r--test-suite/tests/weaks.test34
16 files changed, 573 insertions, 528 deletions
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 168e79901..c20a97752 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -23,6 +23,7 @@
SUBDIRS = standalone vm
SCM_TESTS = tests/00-initial-env.test \
+ tests/00-socket.test \
tests/alist.test \
tests/and-let-star.test \
tests/arbiters.test \
@@ -113,7 +114,6 @@ SCM_TESTS = tests/00-initial-env.test \
tests/regexp.test \
tests/session.test \
tests/signals.test \
- tests/socket.test \
tests/srcprop.test \
tests/srfi-1.test \
tests/srfi-6.test \
diff --git a/test-suite/standalone/test-num2integral.c b/test-suite/standalone/test-num2integral.c
index 0246a3303..c8dc3a7e4 100644
--- a/test-suite/standalone/test-num2integral.c
+++ b/test-suite/standalone/test-num2integral.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010,
+/* Copyright (C) 1999, 2000, 2001, 2003, 2004, 2006, 2008, 2010, 2011
* 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -25,6 +25,7 @@
#include <stdio.h>
#include <assert.h>
+#include <limits.h>
SCM out_of_range_handler (void *data, SCM key, SCM args);
SCM call_num2long_long_body (void *data);
@@ -56,14 +57,14 @@ static void
test_long_long ()
{
{
- SCM n = scm_from_long_long (SCM_I_LLONG_MIN);
+ SCM n = scm_from_long_long (LLONG_MIN);
long long result = scm_to_long_long(n);
- assert (result == SCM_I_LLONG_MIN);
+ assert (result == LLONG_MIN);
}
/* LLONG_MIN - 1 */
{
- SCM n = scm_difference (scm_from_long_long (SCM_I_LLONG_MIN), scm_from_int (1));
+ SCM n = scm_difference (scm_from_long_long (LLONG_MIN), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -71,8 +72,8 @@ test_long_long ()
/* SCM_I_LLONG_MIN + SCM_I_LLONG_MIN/2 */
{
- SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MIN),
- scm_from_long_long (SCM_I_LLONG_MIN / 2));
+ SCM n = scm_sum (scm_from_long_long (LLONG_MIN),
+ scm_from_long_long (LLONG_MIN / 2));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -80,7 +81,7 @@ test_long_long ()
/* SCM_I_LLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_from_long_long (SCM_I_LLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_long_long (LLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2long_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
@@ -108,9 +109,9 @@ static void
test_ulong_long ()
{
{
- SCM n = scm_from_ulong_long (SCM_I_ULLONG_MAX);
+ SCM n = scm_from_ulong_long (ULLONG_MAX);
unsigned long long result = scm_to_ulong_long(n);
- assert (result == SCM_I_ULLONG_MAX);
+ assert (result == ULLONG_MAX);
}
/* -1 */
@@ -123,7 +124,7 @@ test_ulong_long ()
/* SCM_I_ULLONG_MAX + 1 */
{
- SCM n = scm_sum (scm_from_ulong_long (SCM_I_ULLONG_MAX), scm_from_int (1));
+ SCM n = scm_sum (scm_from_ulong_long (ULLONG_MAX), scm_from_int (1));
SCM caught = scm_internal_catch (SCM_BOOL_T, call_num2ulong_long_body, &n,
out_of_range_handler, NULL);
assert (scm_is_true (caught));
diff --git a/test-suite/tests/socket.test b/test-suite/tests/00-socket.test
index 6deb28542..e74d376e5 100644
--- a/test-suite/tests/socket.test
+++ b/test-suite/tests/00-socket.test
@@ -1,7 +1,7 @@
-;;;; socket.test --- test socket functions -*- scheme -*-
+;;;; 00-socket.test --- test socket functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-;;;; 2011 Free Software Foundation, Inc.
+;;;; 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
@@ -17,6 +17,9 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;; This test runs early, so that we can fork before any threads are
+;; created in other tests.
+
(define-module (test-suite test-socket)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-26)
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index 4ea3dd309..52bc7e1a7 100644
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/test-suite/tests/asm-to-bytecode.test
@@ -136,7 +136,7 @@
((@ (system foreign) sizeof) '*))
(define %objcode-cookie-size
- (string-length "GOOF----LE-8-2.0"))
+ (string-length "GOOF----LE-8"))
(define (test-target triplet endian word-size)
(pass-if (format #f "target `~a' honored" triplet)
@@ -169,7 +169,7 @@
#f)))
(write-objcode (bytecode->objcode b) p)
(let ((cookie (make-bytevector %objcode-cookie-size))
- (expected (format #f "GOOF----~a-~a-~a"
+ (expected (format #f "GOOF----~a-~a"
(cond ((eq? endian (endianness little))
"LE")
((eq? endian (endianness big))
@@ -177,8 +177,7 @@
(else
(error "unknown endianness"
endian)))
- word-size
- (effective-version))))
+ word-size)))
(bytevector-copy! (get-objcode) 0 cookie 0
%objcode-cookie-size)
(string=? (utf8->string cookie) expected)))))))))
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index d01d31874..154cc0614 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -70,7 +70,7 @@
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (primitive eq?) (lexical x _) (lexical y _))))))
+ (primcall eq? (lexical x _) (lexical y _))))))
;; The eq? propagates, and (if TEST #f #t) folds to (not TEST).
(pass-if-cse
@@ -79,8 +79,8 @@
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (primitive not)
- (apply (primitive eq?) (lexical x _) (lexical y _)))))))
+ (primcall not
+ (primcall eq? (lexical x _) (lexical y _)))))))
;; (if TEST (not TEST) #f)
;; => (if TEST #f #f)
@@ -110,13 +110,13 @@
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (if (apply (primitive set-car!)
- (lexical x _)
- (lexical y _))
- (apply (primitive not)
- (apply (primitive set-car!)
- (lexical x _)
- (lexical y _)))
+ (if (primcall set-car!
+ (lexical x _)
+ (lexical y _))
+ (primcall not
+ (primcall set-car!
+ (lexical x _)
+ (lexical y _)))
(const #f))))))
;; Primitives that access mutable memory can propagate, as long as
@@ -130,11 +130,10 @@
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (begin
- (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
- (const #f))))))
+ (seq (primcall string-ref
+ (lexical x _)
+ (lexical y _))
+ (const #f))))))
;; However, expressions with dependencies on effects do not propagate
;; through a lambda.
@@ -146,15 +145,15 @@
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (if (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
+ (if (primcall string-ref
+ (lexical x _)
+ (lexical y _))
(lambda _
(lambda-case
((() #f #f #f () ())
- (if (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
+ (if (primcall string-ref
+ (lexical x _)
+ (lexical y _))
(const #t)
(const #f)))))
(const #f))))))
@@ -169,17 +168,16 @@
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (if (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))
- (begin
- (apply (primitive string-set!)
- (lexical x _)
- (const #\!))
- (apply (primitive not)
- (apply (primitive string-ref)
- (lexical x _)
- (lexical y _))))
+ (if (primcall string-ref
+ (lexical x _)
+ (lexical y _))
+ (seq (primcall string-set!
+ (lexical x _)
+ (const #\!))
+ (primcall not
+ (primcall string-ref
+ (lexical x _)
+ (lexical y _))))
(const #f))))))
;; Predicates are only added to the database if they are in a
@@ -190,7 +188,7 @@
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (primitive eq?) (lexical x _) (lexical y _))))))
+ (primcall eq? (lexical x _) (lexical y _))))))
;; Conditional bailouts do cause primitives to be added to the DB.
(pass-if-cse
@@ -199,12 +197,11 @@
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (begin
- (if (apply (primitive eq?)
- (lexical x _) (lexical y _))
- (void)
- (apply (primitive 'throw) (const 'foo)))
- (const #t))))))
+ (seq (if (primcall eq?
+ (lexical x _) (lexical y _))
+ (void)
+ (primcall throw (const foo)))
+ (const #t))))))
;; A chain of tests in a conditional bailout add data to the DB
;; correctly.
@@ -219,21 +216,20 @@
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
- (begin
+ (seq
(fix (failure) (_)
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (primitive throw) (const foo))))))
- (if (apply (primitive struct?) (lexical x _))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable)
- (lexical x _))
- (toplevel x-vtable))
+ (primcall throw (const foo))))))
+ (if (primcall struct? (lexical x _))
+ (if (primcall eq?
+ (primcall struct-vtable (lexical x _))
+ (toplevel x-vtable))
(void)
- (apply (lexical failure _)))
- (apply (lexical failure _))))
- (apply (primitive struct-ref) (lexical x _) (lexical y _)))))))
+ (call (lexical failure _)))
+ (call (lexical failure _))))
+ (primcall struct-ref (lexical x _) (lexical y _)))))))
;; Strict argument evaluation also adds info to the DB.
(pass-if-cse
@@ -254,24 +250,23 @@
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (primitive throw) (const foo))))))
- (if (apply (primitive struct?) (lexical x _))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable)
- (lexical x _))
- (toplevel x-vtable))
- (apply (primitive struct-ref) (lexical x _) (const 1))
- (apply (lexical failure _)))
- (apply (lexical failure _)))))
- (apply (primitive +) (lexical z _)
- (apply (primitive struct-ref) (lexical x _) (const 2))))))))
+ (primcall throw (const foo))))))
+ (if (primcall struct? (lexical x _))
+ (if (primcall eq?
+ (primcall struct-vtable (lexical x _))
+ (toplevel x-vtable))
+ (primcall struct-ref (lexical x _) (const 1))
+ (call (lexical failure _)))
+ (call (lexical failure _)))))
+ (primcall + (lexical z _)
+ (primcall struct-ref (lexical x _) (const 2))))))))
;; Replacing named expressions with lexicals.
(pass-if-cse
(let ((x (car y)))
(cons x (car y)))
- (let (x) (_) ((apply (primitive car) (toplevel y)))
- (apply (primitive cons) (lexical x _) (lexical x _))))
+ (let (x) (_) ((primcall car (toplevel y)))
+ (primcall cons (lexical x _) (lexical x _))))
;; Dominating expressions only provide predicates when evaluated in
;; test context.
@@ -282,8 +277,8 @@
'two))
;; Actually this one should reduce in other ways, but this is the
;; current reduction:
- (begin
- (apply (primitive car) (toplevel x))
- (if (apply (primitive car) (toplevel x))
+ (seq
+ (primcall car (toplevel x))
+ (if (primcall car (toplevel x))
(const one)
(const two)))))
diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test
index 230dc772d..ddfa80a9a 100644
--- a/test-suite/tests/elisp-compiler.test
+++ b/test-suite/tests/elisp-compiler.test
@@ -47,6 +47,8 @@
; Test control structures.
; ========================
+(compile '(%set-lexical-binding-mode #nil) #:from 'elisp #:to 'value)
+
(with-test-prefix/compile "Sequencing"
(pass-if-equal "progn" 1
@@ -54,6 +56,9 @@
(setq a (1+ a))
a))
+ (pass-if-equal "empty progn" #nil
+ (progn))
+
(pass-if "prog1"
(progn (setq a 0)
(setq b (prog1 a (setq a (1+ a))))
@@ -77,17 +82,8 @@
3)
(equal (if nil 1) nil)))
- (pass-if-equal "failing when" nil-value
- (when nil 1 2 3))
- (pass-if-equal "succeeding when" 42
- (progn (setq a 0)
- (when t (setq a 42) a)))
-
- (pass-if-equal "failing unless" nil-value
- (unless t 1 2 3))
- (pass-if-equal "succeeding unless" 42
- (progn (setq a 0)
- (unless nil (setq a 42) a)))
+ (pass-if-equal "if with no else" #nil
+ (if nil t))
(pass-if-equal "empty cond" nil-value
(cond))
@@ -127,27 +123,7 @@
(while (<= i 5)
(setq prod (* i prod))
(setq i (1+ i)))
- prod))
-
- (pass-if "dotimes"
- (progn (setq a 0)
- (setq count 100)
- (setq b (dotimes (i count)
- (setq j (1+ i))
- (setq a (+ a j))))
- (setq c (dotimes (i 10 42) nil))
- (and (= a 5050) (equal b nil) (= c 42))))
-
- (pass-if "dolist"
- (let ((mylist '(7 2 5)))
- (setq sum 0)
- (setq a (dolist (i mylist)
- (setq sum (+ sum i))))
- (setq b (dolist (i mylist 5) 0))
- (and (= sum (+ 7 2 5))
- (equal a nil)
- (equal mylist '(7 2 5))
- (equal b 5)))))
+ prod)))
(with-test-prefix/compile "Exceptions"
@@ -169,7 +145,7 @@
(= (catch 'abc (throw 'abc 2) 1) 2)
(= (catch 'abc (catch 'def (throw 'abc (1+ 0)) 2) 3) 1)
(= (catch 'abc (catch 'def (throw 'def 1) 2) 3) 3)
- (= (catch mylist (catch '(1 2) (throw mylist 1) 2) 3) 1)))
+ (= (catch mylist (catch (list 1 2) (throw mylist 1) 2) 3) 1)))
(pass-if "unwind-protect"
(progn (setq a 0 b 1 c 1)
@@ -246,6 +222,8 @@
(b a))
b)))
+ (pass-if-equal "empty let" #nil (let ()))
+
(pass-if "let*"
(progn (setq a 0)
(and (let* ((a 1)
@@ -257,6 +235,9 @@
(= a 0)
(not (boundp 'b)))))
+ (pass-if-equal "empty let*" #nil
+ (let* ()))
+
(pass-if "local scope"
(progn (setq a 0)
(setq b (let (a)
@@ -303,9 +284,11 @@
(lexical-let ((a 2))
(and (= a 2) (equal (dynvals) '(1 . 1))
(let ((a 3) (b a))
+ (declare (lexical a))
(and (= a 3) (= b 2)
(equal (dynvals) '(1 . 2))))
(let* ((a 4) (b a))
+ (declare (lexical a))
(and (= a 4) (= b 4)
(equal (dynvals) '(1 . 4))))
(= a 2)))
@@ -316,8 +299,11 @@
(defun dyna () a)
(lexical-let ((a 2) (b 42))
(and (= a 2) (= (dyna) 1)
- ((lambda (a) (and (= a 3) (= b 42) (= (dyna) 3))) 3)
+ ((lambda (a)
+ (declare (lexical a))
+ (and (= a 3) (= b 42) (= (dyna) 1))) 3)
((lambda () (let ((a 3))
+ (declare (lexical a))
(and (= a 3) (= (dyna) 1)))))
(= a 2) (= (dyna) 1)))
(= a 1)))
@@ -336,34 +322,13 @@
(= (funcall c1) 4)
(= (funcall c2) 3)))
- (pass-if "always lexical option (all)"
- (progn (setq a 0)
- (defun dyna () a)
- (let ((a 1))
- (and (= a 1) (= (dyna) 0))))
- #:opts '(#:always-lexical all))
- (pass-if "always lexical option (list)"
- (progn (setq a 0 b 0)
- (defun dyna () a)
- (defun dynb () b)
- (let ((a 1)
- (b 1))
- (and (= a 1) (= (dyna) 0)
- (= b 1) (= (dynb) 1))))
- #:opts '(#:always-lexical (a)))
- (pass-if "with-always-lexical"
- (progn (setq a 0)
- (defun dyna () a)
- (with-always-lexical (a)
- (let ((a 1))
- (and (= a 1) (= (dyna) 0))))))
-
(pass-if "lexical lambda args"
(progn (setq a 1 b 1)
(defun dyna () a)
(defun dynb () b)
- (with-always-lexical (a c)
+ (lexical-let (a c)
((lambda (a b &optional c)
+ (declare (lexical a c))
(and (= a 3) (= (dyna) 1)
(= b 2) (= (dynb) 2)
(= c 1)))
@@ -373,9 +338,10 @@
; is tail-optimized by doing a deep recursion that would otherwise overflow
; the stack.
(pass-if "lexical lambda tail-recursion"
- (with-always-lexical (i)
+ (lexical-let (i)
(setq to 1000000)
(defun iteration-1 (i)
+ (declare (lexical i))
(if (< i to)
(iteration-1 (1+ i))))
(iteration-1 0)
@@ -422,14 +388,17 @@
((lambda (a b c) c) 1 2 3))
(pass-if-equal "optional argument" 3
- ((function (lambda (a &optional b c) c)) 1 2 3))
+ ((lambda (a &optional b c) c) 1 2 3))
(pass-if-equal "optional missing" nil-value
((lambda (&optional a) a)))
(pass-if-equal "rest argument" '(3 4 5)
((lambda (a b &rest c) c) 1 2 3 4 5))
- (pass-if-equal "rest missing" nil-value
- ((lambda (a b &rest c) c) 1 2)))
+ (pass-if "rest missing"
+ (null ((lambda (a b &rest c) c) 1 2)))
+
+ (pass-if-equal "empty lambda" #nil
+ ((lambda ()))))
(with-test-prefix/compile "Function Definitions"
@@ -453,18 +422,16 @@
(not (fboundp 'a))
(= a 1))))
- (pass-if "flet and flet*"
+ (pass-if "flet"
(progn (defun foobar () 42)
(defun test () (foobar))
(and (= (test) 42)
- (flet ((foobar (lambda () 0))
- (myfoo (symbol-function 'foobar)))
+ (flet ((foobar () 0)
+ (myfoo ()
+ (funcall (symbol-function 'foobar))))
(and (= (myfoo) 42)
(= (test) 42)))
- (flet* ((foobar (lambda () 0))
- (myfoo (symbol-function 'foobar)))
- (= (myfoo) 42))
- (flet (foobar)
+ (flet ((foobar () nil))
(defun foobar () 0)
(= (test) 42))
(= (test) 42)))))
@@ -563,8 +530,8 @@
(setq some-string "abc")
(and (eq 2 2) (not (eq 1 2))
(eq 'abc 'abc) (not (eq 'abc 'def))
- (eq some-string some-string) (not (eq some-string "abc"))
- (eq some-list some-list) (not (eq some-list '(1 2)))))))
+ (eq some-string some-string) (not (eq some-string (string 97 98 99)))
+ (eq some-list some-list) (not (eq some-list (list 1 2)))))))
(with-test-prefix/compile "Number Built-Ins"
@@ -607,11 +574,11 @@
(with-test-prefix/compile "List Built-Ins"
- (pass-if "consp and atomp"
+ (pass-if "consp and atom"
(and (consp '(1 2 3)) (consp '(1 2 . 3)) (consp '(a . b))
(not (consp '())) (not (consp 1)) (not (consp "abc"))
- (atomp 'a) (atomp '()) (atomp -1.5) (atomp "abc")
- (not (atomp '(1 . 2))) (not (atomp '(1)))))
+ (atom 'a) (atom '()) (atom -1.5) (atom "abc")
+ (not (atom '(1 . 2))) (not (atom '(1)))))
(pass-if "listp and nlistp"
(and (listp '(1 2 3)) (listp '(1)) (listp '()) (listp '(1 . 2))
(not (listp 'a)) (not (listp 42)) (nlistp 42)
@@ -628,15 +595,6 @@
(and (equal (car-safe '(1 2)) 1) (equal (cdr-safe '(1 2)) '(2))
(equal (car-safe 5) nil) (equal (cdr-safe 5) nil)))
- (pass-if "pop"
- (progn (setq mylist '(a b c))
- (setq value (pop mylist))
- (and (equal value 'a)
- (equal mylist '(b c)))))
- (pass-if-equal "push" '(a b c)
- (progn (setq mylist '(b c))
- (push 'a mylist)))
-
(pass-if "nth and nthcdr"
(and (equal (nth -5 '(1 2 3)) 1) (equal (nth 3 '(1 2 3)) nil)
(equal (nth 0 '(1 2 3)) 1) (equal (nth 2 '(1 2 3)) 3)
@@ -662,20 +620,6 @@
(pass-if "reverse"
(and (equal (reverse '(5 4 3 2 1)) '(1 2 3 4 5))
(equal (reverse '()) '())))
- (pass-if "copy-tree"
- (progn (setq mylist '(1 2 (3 4)))
- (and (not (eq mylist (copy-tree mylist)))
- (equal mylist (copy-tree mylist)))))
-
- (pass-if "number-sequence"
- (and (equal (number-sequence 5) '(5))
- (equal (number-sequence 5 9) '(5 6 7 8 9))
- (equal (number-sequence 5 9 3) '(5 8))
- (equal (number-sequence 5 1 -2) '(5 3 1))
- (equal (number-sequence 5 8 -1) '())
- (equal (number-sequence 5 1) '())
- (equal (number-sequence 5 5 0) '(5))))
-
(pass-if "setcar and setcdr"
(progn (setq pair '(1 . 2))
(setq copy pair)
diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test
index a5fbfece2..f8218ad61 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -334,50 +334,64 @@
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
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index 60d8630fc..7c5ecd62f 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -327,6 +327,10 @@
(= (sizeof (list int8 double))
(+ (alignof double) (sizeof double))))
+ (pass-if "sizeof { double, int8 }"
+ (= (sizeof (list double int8))
+ (+ (alignof double) (sizeof double))))
+
(pass-if "sizeof { short, int, long, pointer }"
(let ((layout (list short int long '*)))
(>= (sizeof layout)
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index aefb2e04e..5efcc087d 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -35,9 +35,6 @@
(syntax-rules (resolve-primitives)
((_ in pat)
(pass-if-peval in pat
- (compile 'in #:from 'scheme #:to 'tree-il)))
- ((_ resolve-primitives in pat)
- (pass-if-peval in pat
(expand-primitives!
(resolve-primitives!
(compile 'in #:from 'scheme #:to 'tree-il)
@@ -74,7 +71,7 @@
(f)))
(const 3))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, let-values (requires primitive expansion for
;; `call-with-values'.)
(let ((x 0))
@@ -84,19 +81,19 @@
(+ a b))))
(const 3))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values.
(let ((x 1) (y 2))
(values x y))
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values truncated.
(let ((x (values 1 'a)) (y 2))
(values x y))
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; First order, multiple values truncated.
(or (values 1 2) 3)
(const 1))
@@ -104,16 +101,16 @@
(pass-if-peval
;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
- (apply (primitive list)
- (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+ (primcall list
+ (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
;; First order, coalesced, immutability preserved.
(cons 0 (cons 1 (cons 2 '(3 4 5))))
- (apply (primitive cons) (const 0)
- (apply (primitive cons) (const 1)
- (apply (primitive cons) (const 2)
- (const (3 4 5))))))
+ (primcall cons (const 0)
+ (primcall cons (const 1)
+ (primcall cons (const 2)
+ (const (3 4 5))))))
;; These two tests doesn't work any more because we changed the way we
;; deal with constants -- now the algorithm will see a construction as
@@ -138,10 +135,10 @@
(if (zero? i)
r
(loop (1- i) (cons (cons i i) r))))
- (apply (primitive list)
- (apply (primitive cons) (const 1) (const 1))
- (apply (primitive cons) (const 2) (const 2))
- (apply (primitive cons) (const 3) (const 3))))
+ (primcall list
+ (primcall cons (const 1) (const 1))
+ (primcall cons (const 2) (const 2))
+ (primcall cons (const 3) (const 3))))
;;
;; See above.
#;
@@ -162,15 +159,15 @@
r
(loop (1- i) (cons (cons i i) r))))
(let (r) (_)
- ((apply (primitive list)
- (apply (primitive cons) (const 3) (const 3))))
+ ((primcall list
+ (primcall cons (const 3) (const 3))))
(let (r) (_)
- ((apply (primitive cons)
- (apply (primitive cons) (const 2) (const 2))
- (lexical r _)))
- (apply (primitive cons)
- (apply (primitive cons) (const 1) (const 1))
- (lexical r _)))))
+ ((primcall cons
+ (primcall cons (const 2) (const 2))
+ (lexical r _)))
+ (primcall cons
+ (primcall cons (const 1) (const 1))
+ (lexical r _)))))
;; See above.
(pass-if-peval
@@ -180,21 +177,21 @@
(car r)
(loop (1- i) (cons i r))))
(let (r) (_)
- ((apply (primitive list) (const 4)))
+ ((primcall list (const 4)))
(let (r) (_)
- ((apply (primitive cons)
- (const 3)
- (lexical r _)))
+ ((primcall cons
+ (const 3)
+ (lexical r _)))
(let (r) (_)
- ((apply (primitive cons)
- (const 2)
- (lexical r _)))
+ ((primcall cons
+ (const 2)
+ (lexical r _)))
(let (r) (_)
- ((apply (primitive cons)
- (const 1)
- (lexical r _)))
- (apply (primitive car)
- (lexical r _)))))))
+ ((primcall cons
+ (const 1)
+ (lexical r _)))
+ (primcall car
+ (lexical r _)))))))
;; Static sums.
(pass-if-peval
@@ -204,7 +201,7 @@
(loop (cdr l) (+ sum (car l)))))
(const 10))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(let ((string->chars
(lambda (s)
(define (char-at n)
@@ -217,7 +214,7 @@
(loop (1+ i)))
'())))))
(string->chars "yo"))
- (apply (primitive list) (const #\y) (const #\o)))
+ (primcall list (const #\y) (const #\o)))
(pass-if-peval
;; Primitives in module-refs are resolved (the expansion of `pmatch'
@@ -228,14 +225,13 @@
(pmatch '(a b c d)
((a b . _)
#t)))
- (begin
- (apply . _)
- (const #t)))
+ (seq (call . _)
+ (const #t)))
(pass-if-peval
;; Mutability preserved.
((lambda (x y z) (list x y z)) 1 2 3)
- (apply (primitive list) (const 1) (const 2) (const 3)))
+ (primcall list (const 1) (const 2) (const 3)))
(pass-if-peval
;; Don't propagate effect-free expressions that operate on mutable
@@ -244,10 +240,10 @@
(y (car x)))
(set-car! x 0)
y)
- (let (x) (_) ((apply (primitive list) (const 1)))
- (let (y) (_) ((apply (primitive car) (lexical x _)))
- (begin
- (apply (toplevel set-car!) (lexical x _) (const 0))
+ (let (x) (_) ((primcall list (const 1)))
+ (let (y) (_) ((primcall car (lexical x _)))
+ (seq
+ (primcall set-car! (lexical x _) (const 0))
(lexical y _)))))
(pass-if-peval
@@ -256,9 +252,9 @@
(let ((y (car x)))
(set-car! x 0)
y)
- (let (y) (_) ((apply (primitive car) (toplevel x)))
- (begin
- (apply (toplevel set-car!) (toplevel x) (const 0))
+ (let (y) (_) ((primcall car (toplevel x)))
+ (seq
+ (primcall set-car! (toplevel x) (const 0))
(lexical y _))))
(pass-if-peval
@@ -268,8 +264,8 @@
((lambda _
(lambda-case
(((x) _ _ _ _ _)
- (apply (lexical x _) (lexical x _))))))
- (apply (lexical x _) (lexical x _))))
+ (call (lexical x _) (lexical x _))))))
+ (call (lexical x _) (lexical x _))))
(pass-if-peval
;; First order, aliased primitive.
@@ -281,28 +277,28 @@
(begin
(define (+ x y) (pk x y))
(+ 1 2))
- (begin
+ (seq
(define +
(lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
- (apply (toplevel pk) (lexical x _) (lexical y _))))))
- (apply (toplevel +) (const 1) (const 2))))
+ (call (toplevel pk) (lexical x _) (lexical y _))))))
+ (call (toplevel +) (const 1) (const 2))))
(pass-if-peval
;; First-order, effects preserved.
(let ((x 2))
(do-something!)
x)
- (begin
- (apply (toplevel do-something!))
+ (seq
+ (call (toplevel do-something!))
(const 2)))
(pass-if-peval
;; First order, residual bindings removed.
(let ((x 2) (y 3))
(* (+ x y) z))
- (apply (primitive *) (const 5) (toplevel z)))
+ (primcall * (const 5) (toplevel z)))
(pass-if-peval
;; First order, with lambda.
@@ -313,7 +309,7 @@
(lambda (_)
(lambda-case
(((x) #f #f #f () (_))
- (apply (primitive +) (lexical x _) (const 9)))))))
+ (primcall + (lexical x _) (const 9)))))))
(pass-if-peval
;; First order, with lambda inlined & specialized twice.
@@ -323,22 +319,22 @@
(y 3))
(+ (* x (f x y))
(f something x)))
- (apply (primitive +)
- (apply (primitive *)
- (const 2)
- (apply (primitive +) ; (f 2 3)
- (apply (primitive *)
- (const 2)
- (toplevel top))
- (const 3)))
- (let (x) (_) ((toplevel something)) ; (f something 2)
- ;; `something' is not const, so preserve order of
- ;; effects with a lexical binding.
- (apply (primitive +)
- (apply (primitive *)
- (lexical x _)
- (toplevel top))
- (const 2)))))
+ (primcall +
+ (primcall *
+ (const 2)
+ (primcall + ; (f 2 3)
+ (primcall *
+ (const 2)
+ (toplevel top))
+ (const 3)))
+ (let (x) (_) ((toplevel something)) ; (f something 2)
+ ;; `something' is not const, so preserve order of
+ ;; effects with a lexical binding.
+ (primcall +
+ (primcall *
+ (lexical x _)
+ (toplevel top))
+ (const 2)))))
(pass-if-peval
;; First order, with lambda inlined & specialized 3 times.
@@ -348,15 +344,22 @@
(f -1 y)
(f 2 y)
(f z y)))
- (apply (primitive +)
- (const -1) ; (f -1 0)
- (const 0) ; (f 1 0)
- (begin (toplevel y) (const -1)) ; (f -1 y)
- (toplevel y) ; (f 2 y)
- (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
- (if (apply (primitive >) (lexical x _) (const 0))
- (lexical y _)
- (lexical x _)))))
+ (primcall
+ +
+ (const -1) ; (f -1 0)
+ (primcall
+ +
+ (const 0) ; (f 1 0)
+ (primcall
+ +
+ (seq (toplevel y) (const -1)) ; (f -1 y)
+ (primcall
+ +
+ (toplevel y) ; (f 2 y)
+ (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
+ (if (primcall > (lexical x _) (const 0))
+ (lexical y _)
+ (lexical x _))))))))
(pass-if-peval
;; First order, conditional.
@@ -368,7 +371,7 @@
(lambda ()
(lambda-case
(((x) #f #f #f () (_))
- (apply (toplevel display) (lexical x _))))))
+ (call (toplevel display) (lexical x _))))))
(pass-if-peval
;; First order, recursive procedure.
@@ -387,8 +390,8 @@
(foo)
x)
(let (x) (_) ((toplevel top))
- (begin
- (apply (toplevel foo))
+ (seq
+ (call (toplevel foo))
(lexical x _))))
(pass-if-peval
@@ -427,8 +430,8 @@
(lambda (x)
(+ x 1))
'(2 3))
- (let (y) (_) ((apply (toplevel foo)))
- (apply (primitive +) (lexical y _) (const 7))))
+ (let (y) (_) ((call (toplevel foo)))
+ (primcall + (lexical y _) (const 7))))
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
@@ -450,7 +453,7 @@
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(let ((fold (lambda (f g) (f (g top)))))
(fold 1+ (lambda (x) x)))
- (apply (primitive 1+) (toplevel top)))
+ (primcall 1+ (toplevel top)))
(pass-if-peval
;; Procedure not inlined when residual code contains recursive calls.
@@ -461,7 +464,7 @@
(f (car x3) (fold f (cdr x3) b null? car cdr))))))
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
(letrec (fold) (_) (_)
- (apply (lexical fold _)
+ (call (lexical fold _)
(primitive *)
(toplevel x)
(const 1)
@@ -473,7 +476,7 @@
(lambda ()
(lambda-case
(((x2) #f #f #f () (_))
- (apply (primitive -) (lexical x2 _) (const 1))))))))
+ (primcall 1- (lexical x2 _))))))))
(pass-if "inlined lambdas are alpha-renamed"
;; In this example, `make-adder' is inlined more than once; thus,
@@ -484,24 +487,27 @@
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(pmatch (unparse-tree-il
- (peval (compile
- '(let ((make-adder
- (lambda (x) (lambda (y) (+ x y)))))
- (cons (make-adder 1) (make-adder 2)))
- #:to 'tree-il)))
- ((apply (primitive cons)
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym1))
- (apply (primitive +)
- (const 1)
- (lexical y ,ref1)))))
- (lambda ()
- (lambda-case
- (((y) #f #f #f () (,gensym2))
- (apply (primitive +)
- (const 2)
- (lexical y ,ref2))))))
+ (peval (expand-primitives!
+ (resolve-primitives!
+ (compile
+ '(let ((make-adder
+ (lambda (x) (lambda (y) (+ x y)))))
+ (cons (make-adder 1) (make-adder 2)))
+ #:to 'tree-il)
+ (current-module)))))
+ ((primcall cons
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym1))
+ (primcall +
+ (const 1)
+ (lexical y ,ref1)))))
+ (lambda ()
+ (lambda-case
+ (((y) #f #f #f () (,gensym2))
+ (primcall +
+ (const 2)
+ (lexical y ,ref2))))))
(and (eq? gensym1 ref1)
(eq? gensym2 ref2)
(not (eq? gensym1 gensym2))))
@@ -521,8 +527,8 @@
(b (lambda () (a)))
(c (lambda (x) x)))
(c 10))
- (begin (apply (toplevel foo!))
- (const 10)))
+ (seq (call (toplevel foo!))
+ (const 10)))
(pass-if-peval
;; Higher order, mutually recursive procedures.
@@ -543,9 +549,9 @@
;; Memv with non-constant list. It could fold but doesn't
;; currently.
(memv 1 (list 3 2 1))
- (apply (primitive memv)
- (const 1)
- (apply (primitive list) (const 3) (const 2) (const 1))))
+ (primcall memv
+ (const 1)
+ (primcall list (const 3) (const 2) (const 1))))
(pass-if-peval
;; Memv with non-constant key, constant list, test context
@@ -553,21 +559,20 @@
((3 2 1) 'a)
(else 'b))
(let (key) (_) ((toplevel foo))
- (if (if (apply (primitive eqv?) (lexical key _) (const 3))
+ (if (if (primcall eqv? (lexical key _) (const 3))
(const #t)
- (if (apply (primitive eqv?) (lexical key _) (const 2))
+ (if (primcall eqv? (lexical key _) (const 2))
(const #t)
- (apply (primitive eqv?) (lexical key _) (const 1))))
+ (primcall eqv? (lexical key _) (const 1))))
(const a)
(const b))))
(pass-if-peval
- ;; Memv with non-constant key, empty list, test context. Currently
- ;; doesn't fold entirely.
+ ;; Memv with non-constant key, empty list, test context.
(case foo
(() 'a)
(else 'b))
- (begin (toplevel foo) (const b)))
+ (seq (toplevel foo) (const 'b)))
;;
;; Below are cases where constant propagation should bail out.
@@ -579,12 +584,12 @@
(lambda (n)
(vector-set! v n n)))
(let (v) (_)
- ((apply (toplevel make-vector) (const 6) (const #f)))
+ ((call (toplevel make-vector) (const 6) (const #f)))
(lambda ()
(lambda-case
(((n) #f #f #f () (_))
- (apply (toplevel vector-set!)
- (lexical v _) (lexical n _) (lexical n _)))))))
+ (primcall vector-set!
+ (lexical v _) (lexical n _) (lexical n _)))))))
(pass-if-peval
;; Mutable lexical is not propagated.
@@ -592,7 +597,7 @@
(lambda ()
v))
(let (v) (_)
- ((apply (primitive vector) (const 1) (const 2) (const 3)))
+ ((primcall vector (const 1) (const 2) (const 3)))
(lambda ()
(lambda-case
((() #f #f #f () ())
@@ -603,12 +608,13 @@
(let* ((x (if (> p q) (frob!) (display 'chbouib)))
(y (* x 2)))
(+ x x y))
- (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
- (apply (toplevel frob!))
- (apply (toplevel display) (const chbouib))))
- (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
- (apply (primitive +)
- (lexical x _) (lexical x _) (lexical y _)))))
+ (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
+ (call (toplevel frob!))
+ (call (toplevel display) (const chbouib))))
+ (let (y) (_) ((primcall * (lexical x _) (const 2)))
+ (primcall +
+ (lexical x _)
+ (primcall + (lexical x _) (lexical y _))))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
@@ -620,16 +626,16 @@
(make-list 10)
(list 1 2 3))
(let (x y z) (_ _ _)
- ((apply (primitive vector) (const 1) (const 2) (const 3))
- (apply (toplevel make-list) (const 10))
- (apply (primitive list) (const 1) (const 2) (const 3)))
- (begin
- (apply (toplevel vector-set!)
- (lexical x _) (const 0) (const 0))
- (apply (toplevel set-car!)
- (lexical y _) (const 0))
- (apply (toplevel set-cdr!)
- (lexical z _) (const ())))))
+ ((primcall vector (const 1) (const 2) (const 3))
+ (call (toplevel make-list) (const 10))
+ (primcall list (const 1) (const 2) (const 3)))
+ (seq
+ (primcall vector-set!
+ (lexical x _) (const 0) (const 0))
+ (seq (primcall set-car!
+ (lexical y _) (const 0))
+ (primcall set-cdr!
+ (lexical z _) (const ()))))))
(pass-if-peval
(let ((foo top-foo) (bar top-bar))
@@ -637,9 +643,9 @@
(f (lambda (g x) (g x x))))
(+ (f g foo) (f g bar))))
(let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
- (apply (primitive +)
- (apply (primitive +) (lexical foo _) (lexical foo _))
- (apply (primitive +) (lexical bar _) (lexical bar _)))))
+ (primcall +
+ (primcall + (lexical foo _) (lexical foo _))
+ (primcall + (lexical bar _) (lexical bar _)))))
(pass-if-peval
;; Fresh objects are not turned into constants, nor are constants
@@ -648,8 +654,8 @@
(x (cons 1 c))
(y (cons 0 x)))
y)
- (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
- (apply (primitive cons) (const 0) (lexical x _))))
+ (let (x) (_) ((primcall cons (const 1) (const (2 3))))
+ (primcall cons (const 0) (lexical x _))))
(pass-if-peval
;; Bindings mutated.
@@ -657,7 +663,7 @@
(set! x 3)
x)
(let (x) (_) ((const 2))
- (begin
+ (seq
(set! (lexical x _) (const 3))
(lexical x _))))
@@ -670,8 +676,8 @@
(frob f) ; may mutate `x'
x)
(letrec (x) (_) ((const 0))
- (begin
- (apply (toplevel frob) (lambda _ _))
+ (seq
+ (call (toplevel frob) (lambda _ _))
(lexical x _))))
(pass-if-peval
@@ -687,9 +693,9 @@
(let ((x (make-foo)))
(frob! x) ; may mutate `x'
x)
- (let (x) (_) ((apply (toplevel make-foo)))
- (begin
- (apply (toplevel frob!) (lexical x _))
+ (let (x) (_) ((call (toplevel make-foo)))
+ (seq
+ (call (toplevel frob!) (lexical x _))
(lexical x _))))
(pass-if-peval
@@ -700,10 +706,10 @@
(lambda-case
(((x) #f #f #f () (_))
(if _ _
- (apply (lexical loop _)
- (apply (primitive 1-)
- (lexical x _))))))))
- (apply (lexical loop _) (toplevel x))))
+ (call (lexical loop _)
+ (primcall 1-
+ (lexical x _))))))))
+ (call (lexical loop _) (toplevel x))))
(pass-if-peval
;; Recursion on the 2nd argument is fully evaluated.
@@ -712,8 +718,8 @@
(if (> y 0)
(loop x (1- y))
(foo x y))))
- (let (x) (_) ((apply (toplevel top)))
- (apply (toplevel foo) (lexical x _) (const 0))))
+ (let (x) (_) ((call (toplevel top)))
+ (call (toplevel foo) (lexical x _) (const 0))))
(pass-if-peval
;; Inlining aborted when residual code contains recursive calls.
@@ -728,10 +734,10 @@
(letrec (loop) (_) ((lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
- (if (apply (primitive >)
- (lexical y _) (const 0))
+ (if (primcall >
+ (lexical y _) (const 0))
_ _)))))
- (apply (lexical loop _) (toplevel x) (const 0))))
+ (call (lexical loop _) (toplevel x) (const 0))))
(pass-if-peval
;; Infinite recursion: `peval' gives up and leaves it as is.
@@ -748,7 +754,7 @@
(and (< x top)
(loop (1+ x))))
(letrec (loop) (_) ((lambda . _))
- (apply (lexical loop _) (const 0))))
+ (call (lexical loop _) (const 0))))
(pass-if-peval
;; This test checks that the `start' binding is indeed residualized.
@@ -759,10 +765,10 @@
(here)))
(let (pos) (_) ((const 0))
(let (here) (_) (_)
- (begin
- (set! (lexical pos _) (const 1))
- (apply (lexical here _))))))
-
+ (seq
+ (set! (lexical pos _) (const 1))
+ (call (lexical here _))))))
+
(pass-if-peval
;; FIXME: should this one residualize the binding?
(letrec ((a a))
@@ -798,7 +804,7 @@
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical a _)))))
+ (call (lexical a _)))))
(lambda _
(lambda-case
(((x) #f #f #f () (_))
@@ -806,12 +812,11 @@
(lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical a _))))))
+ (call (lexical a _))))))
(let (d)
(_)
- ((apply (toplevel foo) (lexical b _)))
- (apply (lexical c _)
- (lexical d _)))))
+ ((call (toplevel foo) (lexical b _)))
+ (call (lexical c _) (lexical d _)))))
(pass-if-peval
;; In this case, we can prune the bindings. `a' ends up being copied
@@ -820,20 +825,20 @@
(letrec* ((a (lambda (x) (top x)))
(b (lambda () a)))
(foo (b) (b)))
- (apply (toplevel foo)
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (apply (toplevel top) (lexical x _)))))))
+ (call (toplevel foo)
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((x) #f #f #f () (_))
+ (call (toplevel top) (lexical x _)))))))
(pass-if-peval
;; Constant folding: cons of #nil does not make list
(cons 1 #nil)
- (apply (primitive cons) (const 1) (const '#nil)))
+ (primcall cons (const 1) (const '#nil)))
(pass-if-peval
;; Constant folding: cons
@@ -843,7 +848,7 @@
(pass-if-peval
;; Constant folding: cons
(begin (cons (foo) 2) #f)
- (begin (apply (toplevel foo)) (const #f)))
+ (seq (call (toplevel foo)) (const #f)))
(pass-if-peval
;; Constant folding: cons
@@ -863,12 +868,12 @@
(pass-if-peval
;; Constant folding: car+cons, impure
(car (cons 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
+ (seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+cons, impure
(cdr (cons (bar) 0))
- (begin (apply (toplevel bar)) (const 0)))
+ (seq (call (toplevel bar)) (const 0)))
(pass-if-peval
;; Constant folding: car+list
@@ -878,40 +883,53 @@
(pass-if-peval
;; Constant folding: cdr+list
(cdr (list 1 0))
- (apply (primitive list) (const 0)))
+ (primcall list (const 0)))
(pass-if-peval
;; Constant folding: car+list, impure
(car (list 1 (bar)))
- (begin (apply (toplevel bar)) (const 1)))
+ (seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+list, impure
(cdr (list (bar) 0))
- (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
+ (seq (call (toplevel bar)) (primcall list (const 0))))
+
+ (pass-if-peval
+ ;; Equality primitive: same lexical
+ (let ((x (random))) (eq? x x))
+ (seq (call (toplevel random)) (const #t)))
+
+ (pass-if-peval
+ ;; Equality primitive: merge lexical identities
+ (let* ((x (random)) (y x)) (eq? x y))
+ (seq (call (toplevel random)) (const #t)))
(pass-if-peval
- resolve-primitives
;; Non-constant guards get lexical bindings.
(dynamic-wind foo (lambda () bar) baz)
- (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+ (let (w u) (_ _) ((toplevel foo) (toplevel baz))
+ (dynwind (lexical w _)
+ (call (lexical w _))
+ (toplevel bar)
+ (call (lexical u _))
+ (lexical u _))))
(pass-if-peval
- resolve-primitives
;; Constant guards don't need lexical bindings.
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
(dynwind
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel foo))))
+ (toplevel foo)
(toplevel bar)
+ (toplevel baz)
(lambda ()
(lambda-case
((() #f #f #f () ()) (toplevel baz))))))
(pass-if-peval
- resolve-primitives
;; Prompt is removed if tag is unreferenced
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
@@ -920,7 +938,6 @@
(const 1))
(pass-if-peval
- resolve-primitives
;; Prompt is removed if tag is unreferenced, with explicit stem
(let ((tag (make-prompt-tag "foo")))
(call-with-prompt tag
@@ -930,7 +947,6 @@
;; Handler lambda inlined
(pass-if-peval
- resolve-primitives
(call-with-prompt tag
(lambda () 1)
(lambda (k x) x))
@@ -942,7 +958,6 @@
;; Handler toplevel not inlined
(pass-if-peval
- resolve-primitives
(call-with-prompt tag
(lambda () 1)
handler)
@@ -951,12 +966,11 @@
(const 1)
(lambda-case
((() #f args #f () (_))
- (apply (primitive @apply)
- (lexical handler _)
- (lexical args _)))))))
+ (primcall @apply
+ (lexical handler _)
+ (lexical args _)))))))
(pass-if-peval
- resolve-primitives
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
;; elided.
@@ -969,12 +983,11 @@
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical loop _))))))
- (apply (lexical loop _)))))))
- (apply (lexical lp _))))
+ (call (lexical loop _))))))
+ (call (lexical loop _)))))))
+ (call (lexical lp _))))
(pass-if-peval
- resolve-primitives
(lambda (a . rest)
(apply (lambda (x y) (+ x y))
a rest))
@@ -983,7 +996,7 @@
(((x y) #f #f #f () (_ _))
_))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(car '(1 2))
(const 1))
@@ -992,17 +1005,17 @@
;; residualizing a reference to the leaf identifier. The bailout is
;; driven by the recursive-effort-limit, which is currently 100. We
;; make sure to trip it with this recursive sum thing.
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(let ((x (let sum ((n 0) (out 0))
(if (< n 10000)
(sum (1+ n) (+ out n))
out))))
((lambda (y) (list y)) x))
(let (x) (_) (_)
- (apply (primitive list) (lexical x _))))
+ (primcall list (lexical x _))))
;; Here we test that a common test in a chain of ifs gets lifted.
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(if (and (struct? x) (eq? (struct-vtable x) A))
(foo x)
(if (and (struct? x) (eq? (struct-vtable x) B))
@@ -1013,25 +1026,25 @@
(let (failure) (_) ((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (toplevel qux) (toplevel x))))))
- (if (apply (primitive struct?) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel A))
- (apply (toplevel foo) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel B))
- (apply (toplevel bar) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel C))
- (apply (toplevel baz) (toplevel x))
- (apply (lexical failure _)))))
- (apply (lexical failure _)))))
+ (call (toplevel qux) (toplevel x))))))
+ (if (primcall struct? (toplevel x))
+ (if (primcall eq?
+ (primcall struct-vtable (toplevel x))
+ (toplevel A))
+ (call (toplevel foo) (toplevel x))
+ (if (primcall eq?
+ (primcall struct-vtable (toplevel x))
+ (toplevel B))
+ (call (toplevel bar) (toplevel x))
+ (if (primcall eq?
+ (primcall struct-vtable (toplevel x))
+ (toplevel C))
+ (call (toplevel baz) (toplevel x))
+ (call (lexical failure _)))))
+ (call (lexical failure _)))))
;; Multiple common tests should get lifted as well.
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(if (and (struct? x) (eq? (struct-vtable x) A) B)
(foo x)
(if (and (struct? x) (eq? (struct-vtable x) A) C)
@@ -1042,17 +1055,17 @@
(let (failure) (_) ((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (toplevel qux) (toplevel x))))))
- (if (apply (primitive struct?) (toplevel x))
- (if (apply (primitive eq?)
- (apply (primitive struct-vtable) (toplevel x))
- (toplevel A))
+ (call (toplevel qux) (toplevel x))))))
+ (if (primcall struct? (toplevel x))
+ (if (primcall eq?
+ (primcall struct-vtable (toplevel x))
+ (toplevel A))
(if (toplevel B)
- (apply (toplevel foo) (toplevel x))
+ (call (toplevel foo) (toplevel x))
(if (toplevel C)
- (apply (toplevel bar) (toplevel x))
+ (call (toplevel bar) (toplevel x))
(if (toplevel D)
- (apply (toplevel baz) (toplevel x))
- (apply (lexical failure _)))))
- (apply (lexical failure _)))
- (apply (lexical failure _))))))
+ (call (toplevel baz) (toplevel x))
+ (call (lexical failure _)))))
+ (call (lexical failure _)))
+ (call (lexical failure _))))))
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index ceb6e562b..9407791f7 100644
--- a/test-suite/tests/procprop.test
+++ b/test-suite/tests/procprop.test
@@ -72,10 +72,4 @@
(pass-if "opt, eval"
(equal? (procedure-minimum-arity (eval '(lambda* (a b #:optional c) #t)
(current-module)))
- '(2 1 #f)))
-
- (if (include-deprecated-features)
- (pass-if-exception "set-procedure-properties! arity"
- '(misc-error . "arity is a read-only property")
- (set-procedure-properties! (lambda x x) '((arity . 3))))
- #t))
+ '(2 1 #f))))
diff --git a/test-suite/tests/r6rs-records-syntactic.test b/test-suite/tests/r6rs-records-syntactic.test
index 9f9d37368..edc88aa72 100644
--- a/test-suite/tests/r6rs-records-syntactic.test
+++ b/test-suite/tests/r6rs-records-syntactic.test
@@ -30,12 +30,14 @@
(define-record-type simple-rtd)
(define-record-type
(specified-rtd specified-rtd-constructor specified-rtd-predicate))
-(define-record-type parent-rtd (fields x y))
+;; Can't be named as `parent-rtd', as that shadows the `parent-rtd'
+;; literal.
+(define-record-type *parent-rtd (fields x y))
(define-record-type child-parent-rtd-rtd
- (parent-rtd (record-type-descriptor parent-rtd)
- (record-constructor-descriptor parent-rtd))
+ (parent-rtd (record-type-descriptor *parent-rtd)
+ (record-constructor-descriptor *parent-rtd))
(fields z))
-(define-record-type child-parent-rtd (parent parent-rtd) (fields z))
+(define-record-type child-parent-rtd (parent *parent-rtd) (fields z))
(define-record-type mutable-fields-rtd
(fields (mutable mutable-bar)
(mutable mutable-baz mutable-baz-accessor mutable-baz-mutator)))
@@ -69,10 +71,10 @@
(defined? 'specified-rtd-constructor)))
(pass-if "parent-rtd clause includes specified parent"
- (eq? (record-type-parent child-parent-rtd-rtd) parent-rtd))
+ (eq? (record-type-parent child-parent-rtd-rtd) *parent-rtd))
(pass-if "parent clause includes specified parent"
- (eq? (record-type-parent child-parent-rtd) parent-rtd))
+ (eq? (record-type-parent child-parent-rtd) *parent-rtd))
(pass-if "protocol clause includes specified protocol"
(let ((protocol-record (make-protocol-rtd 1 2)))
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index 8217a4156..c2b65a64c 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -145,6 +145,8 @@
(with-latin1-locale body ...)
(begin body ...)))))
+(define char-code-limit 256)
+
;; Since `regexp-quote' uses string ports, and since it is used below
;; with non-ASCII characters, these ports must be Unicode-capable.
(define-syntax with-unicode
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index cdaee716b..e55cba11e 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -842,7 +842,73 @@
(pass-if-syntax-error "(define)"
exception:generic-syncase-error
(eval '(define)
- (interaction-environment)))))
+ (interaction-environment))))
+
+ (pass-if "module scoping"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-1)
+ #:export (define-10))
+ (define-syntax-rule (define-10 name)
+ (begin
+ (define t 10)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-2)
+ #:use-module (top-level-define/module-scoping-1))
+ (define-10 foo)
+ (foo))
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, same symbolic name"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-3))
+ (define a 10)
+ (define-module (top-level-define/module-scoping-4)
+ #:use-module (top-level-define/module-scoping-3))
+ (define a (@@ (top-level-define/module-scoping-3) a))
+ a)
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, introduced names"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-5)
+ #:export (define-constant))
+ (define-syntax-rule (define-constant name val)
+ (begin
+ (define t val)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-6)
+ #:use-module (top-level-define/module-scoping-5))
+ (define-constant foo 10)
+ (define-constant bar 20)
+ (foo))
+ (current-module))
+ 10))
+
+ (pass-if "module scoping, duplicate introduced name"
+ (equal?
+ (eval
+ '(begin
+ (define-module (top-level-define/module-scoping-7)
+ #:export (define-constant))
+ (define-syntax-rule (define-constant name val)
+ (begin
+ (define t val)
+ (define (name) t)))
+ (define-module (top-level-define/module-scoping-8)
+ #:use-module (top-level-define/module-scoping-7))
+ (define-constant foo 10)
+ (define-constant foo 20)
+ (foo))
+ (current-module))
+ 20)))
(with-test-prefix "internal define"
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 4ffdce09e..5d12f0c48 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -84,15 +84,15 @@
(begin (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))
(assert-tree-il->glil
- (apply (primitive +) (void) (const 1))
+ (primcall + (void) (const 1))
(program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
- (apply (toplevel foo) (const 1))
+ (call (toplevel foo) (const 1))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1)))
(assert-tree-il->glil
- (begin (apply (toplevel foo) (const 1)) (void))
+ (begin (call (toplevel foo) (const 1)) (void))
(program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2)
(label ,l3) (mv-bind 0 #f)
@@ -100,7 +100,7 @@
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (apply (toplevel foo) (apply (toplevel bar)))
+ (call (toplevel foo) (call (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(call tail-call 1))))
@@ -119,7 +119,7 @@
(eq? l1 l3) (eq? l2 l4))
(assert-tree-il->glil
- (apply (primitive null?) (if (toplevel foo) (const 1) (const 2)))
+ (primcall null? (if (toplevel foo) (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
(const 1) (branch br ,l2)
(label ,l3) (const 2) (label ,l4)
@@ -136,7 +136,7 @@
(program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (primitive +))
+ (primcall null? (primitive +))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
(call return 1))))
@@ -156,7 +156,7 @@
(unbind)))
(assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
+ (let (x) (y) ((const 1)) (primcall null? (lexical x y)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call null? 1) (call return 1)
@@ -166,7 +166,7 @@
(assert-tree-il->glil
;; unreferenced sets may be optimized away -- make sure they are ref'd
(let (x) (y) ((const 1))
- (set! (lexical x y) (apply (primitive 1+) (lexical x y))))
+ (set! (lexical x y) (primcall 1+ (lexical x y))))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
@@ -175,7 +175,7 @@
(assert-tree-il->glil
(let (x) (y) ((const 1))
- (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
+ (begin (set! (lexical x y) (primcall 1+ (lexical x y)))
(lexical x y)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
@@ -185,8 +185,8 @@
(assert-tree-il->glil
(let (x) (y) ((const 1))
- (apply (primitive null?)
- (set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
+ (primcall null?
+ (set! (lexical x y) (primcall 1+ (lexical x y)))))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #t 0)) (lexical #t #t box 0)
(lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void)
@@ -207,7 +207,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (@ (foo) bar))
+ (primcall null? (@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _)
(module public ref (foo) bar)
(call null? 1) (call return 1)))
@@ -225,7 +225,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (@@ (foo) bar))
+ (primcall null? (@@ (foo) bar))
(program () (std-prelude 0 0 #f) (label _)
(module private ref (foo) bar)
(call null? 1) (call return 1))))
@@ -244,7 +244,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (set! (@ (foo) bar) (const 2)))
+ (primcall null? (set! (@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (module public set (foo) bar)
(void) (call null? 1) (call return 1)))
@@ -262,7 +262,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
+ (primcall null? (set! (@@ (foo) bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (module private set (foo) bar)
(void) (call null? 1) (call return 1))))
@@ -281,7 +281,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (toplevel bar))
+ (primcall null? (toplevel bar))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar)
(call null? 1) (call return 1))))
@@ -300,7 +300,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (set! (toplevel bar) (const 2)))
+ (primcall null? (set! (toplevel bar) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel set bar)
(void) (call null? 1) (call return 1))))
@@ -319,7 +319,7 @@
(const #f) (call return 1)))
(assert-tree-il->glil
- (apply (primitive null?) (define bar (const 2)))
+ (primcall null? (define bar (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (toplevel define bar)
(void) (call null? 1) (call return 1))))
@@ -337,7 +337,7 @@
(assert-tree-il->glil
;; This gets simplified by `peval'.
- (apply (primitive null?) (const 2))
+ (primcall null? (const 2))
(program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1))))
@@ -345,7 +345,7 @@
;; simple bindings -> let
(assert-tree-il->glil without-partial-evaluation
(letrec (x y) (x1 y1) ((const 10) (const 20))
- (apply (toplevel foo) (lexical x x1) (lexical y y1)))
+ (call (toplevel foo) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(const 10) (const 20)
(bind (x #f 0) (y #f 1))
@@ -357,8 +357,8 @@
;; complex bindings -> box and set! within let
(assert-tree-il->glil without-partial-evaluation
- (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+ (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 4 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
@@ -375,8 +375,8 @@
;; complex bindings in letrec* -> box and set! in order
(assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar)))
- (apply (primitive +) (lexical x x1) (lexical y y1)))
+ (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
+ (primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
(void) (void) ;; what are these?
(bind (x #t 0) (y #t 1))
@@ -495,38 +495,38 @@
(assert-tree-il->glil
;; This gets simplified by `peval'.
- (apply (primitive null?) (begin (const #f) (const 2)))
+ (primcall null? (begin (const #f) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const #f) (call return 1))))
(with-test-prefix "values"
(assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2)))
+ (primcall values
+ (primcall values (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (call return 1)))
(assert-tree-il->glil
- (apply (primitive values)
- (apply (primitive values) (const 1) (const 2))
- (const 3))
+ (primcall values
+ (primcall values (const 1) (const 2))
+ (const 3))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (const 3) (call return/values 2)))
(assert-tree-il->glil
- (apply (primitive +)
- (apply (primitive values) (const 1) (const 2)))
+ (primcall +
+ (primcall values (const 1) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 1) (call return 1)))
;; Testing `(values foo)' in push context with RA.
(assert-tree-il->glil without-partial-evaluation
- (apply (primitive cdr)
- (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
- ((lambda ((name . lp))
- (lambda-case ((() #f #f #f () ())
- (apply (toplevel values) (const (one two)))))))
- (apply (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
+ (primcall cdr
+ (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#)
+ ((lambda ((name . lp))
+ (lambda-case ((() #f #f #f () ())
+ (primcall values (const (one two)))))))
+ (call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#))))
(program () (std-prelude 0 0 #f) (label _)
(branch br _) ;; entering the fix, jump to :2
;; :1 body of lp, jump to :3
@@ -574,10 +574,10 @@
(with-test-prefix "apply"
(assert-tree-il->glil
- (apply (primitive @apply) (toplevel foo) (toplevel bar))
+ (primcall @apply (toplevel foo) (toplevel bar))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2)))
(assert-tree-il->glil
- (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
+ (begin (primcall @apply (toplevel foo) (toplevel bar)) (void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -585,7 +585,7 @@
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
+ (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz)))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
@@ -593,10 +593,10 @@
(with-test-prefix "call/cc"
(assert-tree-il->glil
- (apply (primitive @call-with-current-continuation) (toplevel foo))
+ (primcall @call-with-current-continuation (toplevel foo))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1)))
(assert-tree-il->glil
- (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
+ (begin (primcall @call-with-current-continuation (toplevel foo)) (void))
(program () (std-prelude 0 0 #f) (label _)
(call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f)
@@ -604,8 +604,8 @@
(void) (call return 1))
(and (eq? l1 l3) (eq? l2 l4)))
(assert-tree-il->glil
- (apply (toplevel foo)
- (apply (toplevel @call-with-current-continuation) (toplevel bar)))
+ (call (toplevel foo)
+ (call (toplevel @call-with-current-continuation) (toplevel bar)))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
@@ -655,9 +655,9 @@
'(lambda ()
(lambda-case
(((x y) #f #f #f () (x1 y1))
- (apply (toplevel +)
- (lexical x x1)
- (lexical y y1)))
+ (call (toplevel +)
+ (lexical x x1)
+ (lexical y y1)))
#f))))))
(and (equal? (map strip-source leaves)
(list (make-lexical-ref #f 'y 'y1)
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
index d939284c1..d9bbbebce 100644
--- a/test-suite/tests/vlist.test
+++ b/test-suite/tests/vlist.test
@@ -220,11 +220,11 @@
(and (fold (lambda (k v result)
(and result
(equal? (cons k v)
- (vhash-assq k vh))))
+ (vhash-assoc k vh))))
#t
keys
values)
- (not (vhash-assq 'x vh)))))
+ (not (vhash-assoc 'x vh)))))
(pass-if "vhash as vlist"
(let* ((keys '(a b c d e f g h i))
diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test
index d0f6c5ef5..1d53fc422 100644
--- a/test-suite/tests/weaks.test
+++ b/test-suite/tests/weaks.test
@@ -1,5 +1,5 @@
;;;; weaks.test --- tests guile's weaks -*- scheme -*-
-;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2003, 2006, 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
@@ -68,28 +68,28 @@
exception:wrong-type-arg
(list->weak-vector 32)))
- (with-test-prefix "make-weak-key-alist-vector"
+ (with-test-prefix "make-weak-key-hash-table"
(pass-if "create"
- (make-weak-key-alist-vector 17)
+ (make-weak-key-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-weak-key-alist-vector '(bad arg))))
- (with-test-prefix "make-weak-value-alist-vector"
+ (make-weak-key-hash-table '(bad arg))))
+ (with-test-prefix "make-weak-value-hash-table"
(pass-if "create"
- (make-weak-value-alist-vector 17)
+ (make-weak-value-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-weak-value-alist-vector '(bad arg))))
+ (make-weak-value-hash-table '(bad arg))))
- (with-test-prefix "make-doubly-weak-alist-vector"
+ (with-test-prefix "make-doubly-weak-hash-table"
(pass-if "create"
- (make-doubly-weak-alist-vector 17)
+ (make-doubly-weak-hash-table 17)
#t)
(pass-if-exception "bad-args"
exception:wrong-type-arg
- (make-doubly-weak-alist-vector '(bad arg)))))
+ (make-doubly-weak-hash-table '(bad arg)))))
@@ -138,9 +138,9 @@
(or (not value)
(equal? value initial-value)))
- (let ((x (make-weak-key-alist-vector 17))
- (y (make-weak-value-alist-vector 17))
- (z (make-doubly-weak-alist-vector 17))
+ (let ((x (make-weak-key-hash-table 17))
+ (y (make-weak-value-hash-table 17))
+ (z (make-doubly-weak-hash-table 17))
(test-key "foo")
(test-value "bar"))
(with-test-prefix
@@ -232,6 +232,14 @@
(hash-set! t "foo" 1)
(equal? (hash-ref t "foo") 1)))
+ (pass-if "hash-set!, weak key, returns value"
+ (let ((t (make-weak-value-hash-table))
+ (val (string #\f #\o #\o)))
+ (eq? (hashq-set! t "bar" val)
+ (hashv-set! t "bar" val)
+ (hash-set! t "bar" val)
+ val)))
+
(pass-if "assoc can do anything"
;; Until 1.9.12, as hash table's custom ASSOC procedure was
;; called with the GC lock alloc held, which imposed severe