diff options
Diffstat (limited to 'test-suite')
-rw-r--r-- | test-suite/Makefile.am | 2 | ||||
-rw-r--r-- | test-suite/standalone/test-num2integral.c | 21 | ||||
-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.test | 7 | ||||
-rw-r--r-- | test-suite/tests/cse.test | 125 | ||||
-rw-r--r-- | test-suite/tests/elisp-compiler.test | 136 | ||||
-rw-r--r-- | test-suite/tests/eval.test | 86 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 4 | ||||
-rw-r--r-- | test-suite/tests/peval.test | 487 | ||||
-rw-r--r-- | test-suite/tests/procprop.test | 8 | ||||
-rw-r--r-- | test-suite/tests/r6rs-records-syntactic.test | 14 | ||||
-rw-r--r-- | test-suite/tests/regexp.test | 2 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 68 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 96 | ||||
-rw-r--r-- | test-suite/tests/vlist.test | 4 | ||||
-rw-r--r-- | test-suite/tests/weaks.test | 34 |
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 |