summaryrefslogtreecommitdiff
path: root/test-suite/tests
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests')
-rw-r--r--test-suite/tests/00-socket.test7
-rw-r--r--test-suite/tests/arrays.test254
-rw-r--r--test-suite/tests/asm-to-bytecode.test224
-rw-r--r--test-suite/tests/bytevectors.test25
-rw-r--r--test-suite/tests/chars.test8
-rw-r--r--test-suite/tests/compiler.test8
-rw-r--r--test-suite/tests/control.test29
-rw-r--r--test-suite/tests/coverage.test45
-rw-r--r--test-suite/tests/cross-compilation.test90
-rw-r--r--test-suite/tests/cse.test147
-rw-r--r--test-suite/tests/dwarf.test90
-rw-r--r--test-suite/tests/elisp-compiler.test136
-rw-r--r--test-suite/tests/eval.test95
-rw-r--r--test-suite/tests/foreign.test9
-rw-r--r--test-suite/tests/iconv.test5
-rw-r--r--test-suite/tests/linker.test82
-rw-r--r--test-suite/tests/peg.bench173
-rw-r--r--test-suite/tests/peg.test278
-rw-r--r--test-suite/tests/peval.test755
-rw-r--r--test-suite/tests/ports.test143
-rw-r--r--test-suite/tests/print.test42
-rw-r--r--test-suite/tests/procprop.test12
-rw-r--r--test-suite/tests/r6rs-ports.test25
-rw-r--r--test-suite/tests/r6rs-records-syntactic.test14
-rw-r--r--test-suite/tests/ramap.test56
-rw-r--r--test-suite/tests/rdelim.test422
-rw-r--r--test-suite/tests/reader.test5
-rw-r--r--test-suite/tests/regexp.test18
-rw-r--r--test-suite/tests/rtl-compilation.test220
-rw-r--r--test-suite/tests/rtl.test436
-rw-r--r--test-suite/tests/session.test6
-rw-r--r--test-suite/tests/srfi-105.test5
-rw-r--r--test-suite/tests/strings.test10
-rw-r--r--test-suite/tests/syncase.test58
-rw-r--r--test-suite/tests/syntax.test68
-rw-r--r--test-suite/tests/tree-il.test878
-rw-r--r--test-suite/tests/vlist.test4
-rw-r--r--test-suite/tests/weaks.test34
-rw-r--r--test-suite/tests/web-http.test4
-rw-r--r--test-suite/tests/web-response.test4
40 files changed, 2851 insertions, 2073 deletions
diff --git a/test-suite/tests/00-socket.test b/test-suite/tests/00-socket.test
index 5093575c0..30a02570c 100644
--- a/test-suite/tests/00-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, 2013 Free Software Foundation, Inc.
+;;;; 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -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/arrays.test b/test-suite/tests/arrays.test
index 0b3d57ca2..0da1a1992 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -6,12 +6,12 @@
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
@@ -207,6 +207,154 @@
(array-equal? #s16(1 2 3) #s16(1 2 3))))
;;;
+;;; make-shared-array
+;;;
+
+(define exception:mapping-out-of-range
+ (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
+
+(with-test-prefix "make-shared-array"
+
+ ;; this failed in guile 1.8.0
+ (pass-if "vector unchanged"
+ (let* ((a (make-array #f '(0 7)))
+ (s (make-shared-array a list '(0 7))))
+ (array-equal? a s)))
+
+ (pass-if-exception "vector, high too big" exception:mapping-out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(0 8))))
+
+ (pass-if-exception "vector, low too big" exception:out-of-range
+ (let* ((a (make-array #f '(0 7))))
+ (make-shared-array a list '(-1 7))))
+
+ (pass-if "truncate columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
+ #2((a b) (d e) (g h))))
+
+ (pass-if "pick one column"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i 2))
+ '(0 2))
+ #(c f i)))
+
+ (pass-if "diagonal"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i) (list i i))
+ '(0 2))
+ #(a e i)))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "2 dims from 1 dim"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i j) (list (+ (* i 3) j)))
+ 4 3)
+ #2((a b c) (d e f) (g h i) (j k l))))
+
+ (pass-if "reverse columns"
+ (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
+ (lambda (i j) (list i (- 2 j)))
+ 3 3)
+ #2((c b a) (f e d) (i h g))))
+
+ (pass-if "fixed offset, 0 based becomes 1 based"
+ (let* ((x #2((a b c) (d e f) (g h i)))
+ (y (make-shared-array x
+ (lambda (i j) (list (1- i) (1- j)))
+ '(1 3) '(1 3))))
+ (and (eq? (array-ref x 0 0) 'a)
+ (eq? (array-ref y 1 1) 'a))))
+
+ ;; this failed in guile 1.8.0
+ (pass-if "stride every third element"
+ (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
+ (lambda (i) (list (* i 3)))
+ 4)
+ #1(a d g j)))
+
+ (pass-if "shared of shared"
+ (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
+ (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
+ (s2 (make-shared-array s1 list '(1 2))))
+ (and (eqv? 5 (array-ref s2 1))
+ (eqv? 8 (array-ref s2 2))))))
+
+;;;
+;;; shared-array-root
+;;;
+
+(with-test-prefix "shared-array-root"
+
+ (define amap1 (lambda (i) (list (* 2 i))))
+ (define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
+
+ (pass-if "plain vector"
+ (let* ((a (make-vector 4 0))
+ (b (make-shared-array a amap1 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "plain array rank 2"
+ (let* ((a (make-array 0 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "uniform array rank 2"
+ (let* ((a (make-typed-array 'c64 0 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))
+
+ (pass-if "bit array rank 2"
+ (let* ((a (make-typed-array 'b #f 4 4))
+ (b (make-shared-array a amap2 2 2)))
+ (eq? (shared-array-root a) (shared-array-root b) (array-contents a)))))
+
+;;;
+;;; transpose-array
+;;;
+
+; see strings.test.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+(with-test-prefix "transpose-array"
+
+ (pass-if-exception "non array argument" exception:wrong-type-arg
+ (transpose-array 99))
+
+ (pass-if "rank 0"
+ (let* ((a #0(99))
+ (b (transpose-array a)))
+ (and (array-equal? a b)
+ (eq? (shared-array-root a) (shared-array-root b)))))
+
+ (pass-if "rank 1"
+ (let* ((a #(1 2 3))
+ (b (transpose-array a 0)))
+ (and (array-equal? a b)
+ (eq? (shared-array-root a) (shared-array-root b)))))
+
+ (pass-if "rank 2"
+ (let* ((a #2((1 2 3) (4 5 6)))
+ (b (transpose-array a 1 0))
+ (c (transpose-array a 0 1)))
+ (and (array-equal? b #2((1 4) (2 5) (3 6)))
+ (array-equal? c a)
+ (eq? (shared-array-root a)
+ (shared-array-root b)
+ (shared-array-root c)))))
+
+ ; rank > 2 is needed to check against the inverted axis index logic.
+ (pass-if "rank 3"
+ (let* ((a #3(((0 1 2 3) (4 5 6 7) (8 9 10 11))
+ ((12 13 14 15) (16 17 18 19) (20 21 22 23))))
+ (b (transpose-array a 1 2 0)))
+ (and (array-equal? b #3(((0 4 8) (12 16 20)) ((1 5 9) (13 17 21))
+ ((2 6 10) (14 18 22)) ((3 7 11) (15 19 23))))
+ (eq? (shared-array-root a)
+ (shared-array-root b))))))
+
+;;;
;;; array->list
;;;
@@ -397,8 +545,8 @@
(for-each (lambda (type)
(pass-if (symbol->string type)
(eq? type
- (array-type (make-typed-array type
- *unspecified*
+ (array-type (make-typed-array type
+ *unspecified*
'(5 6))))))
types))))
@@ -500,86 +648,12 @@
(array-set! a 'y 4 8 0)))))
;;;
-;;; make-shared-array
-;;;
-
-(define exception:mapping-out-of-range
- (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array
-
-(with-test-prefix "make-shared-array"
-
- ;; this failed in guile 1.8.0
- (pass-if "vector unchanged"
- (let* ((a (make-array #f '(0 7)))
- (s (make-shared-array a list '(0 7))))
- (array-equal? a s)))
-
- (pass-if-exception "vector, high too big" exception:mapping-out-of-range
- (let* ((a (make-array #f '(0 7))))
- (make-shared-array a list '(0 8))))
-
- (pass-if-exception "vector, low too big" exception:out-of-range
- (let* ((a (make-array #f '(0 7))))
- (make-shared-array a list '(-1 7))))
-
- (pass-if "truncate columns"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i)) list 3 2)
- #2((a b) (d e) (g h))))
-
- (pass-if "pick one column"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i) (list i 2))
- '(0 2))
- #(c f i)))
-
- (pass-if "diagonal"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i) (list i i))
- '(0 2))
- #(a e i)))
-
- ;; this failed in guile 1.8.0
- (pass-if "2 dims from 1 dim"
- (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
- (lambda (i j) (list (+ (* i 3) j)))
- 4 3)
- #2((a b c) (d e f) (g h i) (j k l))))
-
- (pass-if "reverse columns"
- (array-equal? (make-shared-array #2((a b c) (d e f) (g h i))
- (lambda (i j) (list i (- 2 j)))
- 3 3)
- #2((c b a) (f e d) (i h g))))
-
- (pass-if "fixed offset, 0 based becomes 1 based"
- (let* ((x #2((a b c) (d e f) (g h i)))
- (y (make-shared-array x
- (lambda (i j) (list (1- i) (1- j)))
- '(1 3) '(1 3))))
- (and (eq? (array-ref x 0 0) 'a)
- (eq? (array-ref y 1 1) 'a))))
-
- ;; this failed in guile 1.8.0
- (pass-if "stride every third element"
- (array-equal? (make-shared-array #1(a b c d e f g h i j k l)
- (lambda (i) (list (* i 3)))
- 4)
- #1(a d g j)))
-
- (pass-if "shared of shared"
- (let* ((a #2((1 2 3) (4 5 6) (7 8 9)))
- (s1 (make-shared-array a (lambda (i) (list i 1)) 3))
- (s2 (make-shared-array s1 list '(1 2))))
- (and (eqv? 5 (array-ref s2 1))
- (eqv? 8 (array-ref s2 2))))))
-
-;;;
-;;; uniform-vector-ref
+;;; uniform-vector
;;;
-(with-test-prefix "uniform-vector-ref"
+(with-test-prefix "uniform-vector"
- (with-test-prefix "byte"
+ (with-test-prefix "uniform-vector-ref byte"
(let ((a (make-s8vector 1)))
@@ -594,7 +668,23 @@
(pass-if "-128"
(begin
(array-set! a -128 0)
- (= -128 (uniform-vector-ref a 0)))))))
+ (= -128 (uniform-vector-ref a 0))))))
+
+ (with-test-prefix "shared with rank 1 remain uniform vectors"
+
+ (let ((a #f64(1 2 3 4)))
+
+ (pass-if "change offset"
+ (let ((b (make-shared-array a (lambda (i) (list (+ i 1))) 3)))
+ (and (uniform-vector? b)
+ (= 3 (uniform-vector-length b))
+ (array-equal? b #f64(2 3 4)))))
+
+ (pass-if "change stride"
+ (let ((c (make-shared-array a (lambda (i) (list (* i 2))) 2)))
+ (and (uniform-vector? c)
+ (= 2 (uniform-vector-length c))
+ (array-equal? c #f64(1 3))))))))
;;;
;;; syntax
diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
deleted file mode 100644
index 6d2f20e02..000000000
--- a/test-suite/tests/asm-to-bytecode.test
+++ /dev/null
@@ -1,224 +0,0 @@
-;;;; Assembly to bytecode compilation -*- mode: scheme; coding: utf-8; -*-
-;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-(define-module (tests asm-to-bytecode)
- #:use-module (rnrs bytevectors)
- #:use-module ((rnrs io ports) #:select (open-bytevector-output-port))
- #:use-module (test-suite lib)
- #:use-module (system vm instruction)
- #:use-module (system vm objcode)
- #:use-module (system base target)
- #:use-module (language assembly)
- #:use-module (language assembly compile-bytecode))
-
-(define (->u8-list sym val)
- (let ((entry (assq-ref `((uint16 2 ,bytevector-u16-native-set!)
- (uint32 4 ,bytevector-u32-native-set!))
- sym)))
- (or entry (error "unknown sym" sym))
- (let ((bv (make-bytevector (car entry))))
- ((cadr entry) bv 0 val)
- (bytevector->u8-list bv))))
-
-(define (munge-bytecode v)
- (let lp ((i 0) (out '()))
- (if (= i (vector-length v))
- (u8-list->bytevector (reverse out))
- (let ((x (vector-ref v i)))
- (cond
- ((symbol? x)
- (lp (1+ i) (cons (instruction->opcode x) out)))
- ((integer? x)
- (lp (1+ i) (cons x out)))
- ((pair? x)
- (lp (1+ i) (append (reverse (apply ->u8-list x)) out)))
- (else (error "bad test bytecode" x)))))))
-
-(define (comp-test x y)
- (let* ((y (munge-bytecode y))
- (len (bytevector-length y))
- (v #f))
-
- (run-test `(length ,x) #t
- (lambda ()
- (let* ((wrapped `(load-program () ,(byte-length x) #f ,x))
- (bv (compile-bytecode wrapped '())))
- (set! v (make-bytevector (- (bytevector-length bv) 8)))
- (bytevector-copy! bv 8 v 0 (bytevector-length v))
- (= (bytevector-length v) len))))
- (run-test `(compile-equal? ,x ,y) #t
- (lambda ()
- (equal? v y)))))
-
-
-(with-test-prefix "compiler"
- (with-test-prefix "asm-to-bytecode"
-
- (comp-test '(make-int8 3)
- #(make-int8 3))
-
- (comp-test '(load-number "3.14")
- (vector 'load-number 0 0 4 (char->integer #\3) (char->integer #\.)
- (char->integer #\1) (char->integer #\4)))
-
- (comp-test '(load-string "foo")
- (vector 'load-string 0 0 3 (char->integer #\f) (char->integer #\o)
- (char->integer #\o)))
-
- (comp-test '(load-symbol "foo")
- (vector 'load-symbol 0 0 3 (char->integer #\f) (char->integer #\o)
- (char->integer #\o)))
-
- (comp-test '(load-string "æ") ;; a non-ASCII Latin-1 string
- (vector 'load-string 0 0 1 230))
-
- (comp-test '(load-wide-string "λ")
- (apply vector 'load-wide-string 0 0 4
- (if (eq? (native-endianness) (endianness little))
- '(187 3 0 0)
- '(0 0 3 187))))
-
- (comp-test '(load-program () 3 #f (make-int8 3) (return))
- #(load-program
- (uint32 3) ;; len
- (uint32 0) ;; metalen
- make-int8 3
- return))
-
- ;; the nops are to pad meta to an 8-byte alignment. not strictly
- ;; necessary for this test, but representative of the common case.
- (comp-test '(load-program () 8
- (load-program () 3
- #f
- (make-int8 3) (return))
- (make-int8 3) (return)
- (nop) (nop) (nop) (nop) (nop))
- #(load-program
- (uint32 8) ;; len
- (uint32 11) ;; metalen
- make-int8 3
- return
- nop nop nop nop nop
- (uint32 3) ;; len
- (uint32 0) ;; metalen
- make-int8 3
- return))))
-
-
-(define (test-triplet cpu vendor os)
- (let ((triplet (string-append cpu "-" vendor "-" os)))
- (pass-if (format #f "triplet ~a" triplet)
- (with-target triplet
- (lambda ()
- (and (string=? (target-cpu) cpu)
- (string=? (target-vendor) vendor)
- (string=? (target-os) os)))))))
-
-(define (native-cpu)
- (with-target %host-type target-cpu))
-
-(define (native-os)
- (with-target %host-type target-os))
-
-(define (native-word-size)
- ((@ (system foreign) sizeof) '*))
-
-(define %objcode-cookie-size
- (string-length "GOOF----LE-8-2.0"))
-
-(define (test-target triplet endian word-size)
- (pass-if (format #f "target `~a' honored" triplet)
- (call-with-values (lambda ()
- (open-bytevector-output-port))
- (lambda (p get-objcode)
- (with-target triplet
- (lambda ()
- (let ((word-size
- ;; When the target is the native CPU, rather trust
- ;; the native CPU's word size. This is because
- ;; Debian's `sparc64-linux-gnu' port, for instance,
- ;; actually has a 32-bit user-land, for instance (see
- ;; <http://www.debian.org/ports/sparc/#sparc64bit>
- ;; for details.)
- (if (and (string=? (native-cpu) (target-cpu))
- (string=? (native-os) (target-os)))
- (native-word-size)
- word-size))
- (b (compile-bytecode
- '(load-program () 16 #f
- (assert-nargs-ee/locals 1)
- (make-int8 77)
- (toplevel-ref 1)
- (local-ref 0)
- (mul)
- (add)
- (return)
- (nop) (nop) (nop)
- (nop) (nop))
- #f)))
- (write-objcode (bytecode->objcode b) p)
- (let ((cookie (make-bytevector %objcode-cookie-size))
- (expected (format #f "GOOF----~a-~a-~a"
- (cond ((eq? endian (endianness little))
- "LE")
- ((eq? endian (endianness big))
- "BE")
- (else
- (error "unknown endianness"
- endian)))
- word-size
- (effective-version))))
- (bytevector-copy! (get-objcode) 0 cookie 0
- %objcode-cookie-size)
- (string=? (utf8->string cookie) expected)))))))))
-
-(with-test-prefix "cross-compilation"
-
- (test-triplet "i586" "pc" "gnu0.3")
- (test-triplet "x86_64" "unknown" "linux-gnu")
- (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
-
- (test-target "i586-pc-gnu0.3" (endianness little) 4)
- (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
- (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
- (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
-
- (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
- (endianness little) 4)
- (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
- (endianness little) 8)
- (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
- (endianness little) 4)
-
- (pass-if-exception "unknown target"
- exception:miscellaneous-error
- (call-with-values (lambda ()
- (open-bytevector-output-port))
- (lambda (p get-objcode)
- (let* ((b (compile-bytecode '(load-program () 3 #f
- (make-int8 77)
- (return))
- #f))
- (o (bytecode->objcode b)))
- (with-target "fcpu-unknown-gnu1.0"
- (lambda ()
- (write-objcode o p))))))))
-
-;; Local Variables:
-;; eval: (put 'with-target 'scheme-indent-function 1)
-;; End:
diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test
index 524ce86b5..de207218f 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -155,10 +155,6 @@
(let ((b (make-bytevector 0)))
(null? (bytevector->uint-list b (endianness big) 2))))
- (pass-if "bytevector->sint-list [length < word size]"
- (let ((b (make-bytevector 1)))
- (null? (bytevector->sint-list b (endianness big) 2))))
-
(pass-if-exception "bytevector->sint-list [out-of-range]"
exception:out-of-range
(bytevector->sint-list (make-bytevector 6) (endianness little) -1))
@@ -167,10 +163,9 @@
exception:out-of-range
(bytevector->uint-list (make-bytevector 6) (endianness little) 0))
- (pass-if "bytevector->sint-list [off-by-one]"
- (equal? (bytevector->sint-list (make-bytevector 31 #xff)
- (endianness little) 8)
- '(-1 -1 -1)))
+ (pass-if-exception "bytevector->uint-list [word size doesn't divide length]"
+ exception:wrong-type-arg
+ (bytevector->uint-list (make-bytevector 6) (endianness little) 4))
(pass-if "{sint,uint}-list->bytevector"
(let ((b1 (sint-list->bytevector '(513 -253 513 513)
@@ -676,15 +671,23 @@
(pass-if "bitvector < 8"
(let ((bv (uniform-array->bytevector (make-bitvector 4 #t))))
- (= (bytevector-length bv) 1)))
+ (= (bytevector-length bv) 4)))
(pass-if "bitvector == 8"
(let ((bv (uniform-array->bytevector (make-bitvector 8 #t))))
- (= (bytevector-length bv) 1)))
+ (= (bytevector-length bv) 4)))
(pass-if "bitvector > 8"
(let ((bv (uniform-array->bytevector (make-bitvector 9 #t))))
- (= (bytevector-length bv) 2))))
+ (= (bytevector-length bv) 4)))
+
+ (pass-if "bitvector == 32"
+ (let ((bv (uniform-array->bytevector (make-bitvector 32 #t))))
+ (= (bytevector-length bv) 4)))
+
+ (pass-if "bitvector > 32"
+ (let ((bv (uniform-array->bytevector (make-bitvector 33 #t))))
+ (= (bytevector-length bv) 8))))
;;; Local Variables:
;;; eval: (put 'with-test-prefix/c&e 'scheme-indent-function 1)
diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test
index 98854f73a..55cfead23 100644
--- a/test-suite/tests/chars.test
+++ b/test-suite/tests/chars.test
@@ -1,7 +1,7 @@
;;;; chars.test --- Characters. -*- coding: utf-8; mode: scheme; -*-
;;;; Greg J. Badros <gjb@cs.washington.edu>
;;;;
-;;;; Copyright (C) 2000, 2006, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2006, 2009, 2010, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -316,13 +316,11 @@
(pass-if "combining accent is pretty-printed"
(let ((accent (integer->char #x030f))) ; COMBINING DOUBLE GRAVE ACCENT
(string=?
- (with-fluids ((%default-port-encoding "UTF-8"))
- (with-output-to-string (lambda () (write accent))))
+ (with-output-to-string (lambda () (write accent)))
"#\\◌̏")))
(pass-if "combining X is pretty-printed"
(let ((x (integer->char #x0353))) ; COMBINING X BELOW
(string=?
- (with-fluids ((%default-port-encoding "UTF-8"))
- (with-output-to-string (lambda () (write x))))
+ (with-output-to-string (lambda () (write x)))
"#\\◌͓")))))
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 619b16740..70213ca3d 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,8 +19,8 @@
#:use-module (test-suite lib)
#:use-module (test-suite guile-test)
#:use-module (system base compile)
- #:use-module ((system vm program) #:select (make-program
- program-sources source:addr)))
+ #:use-module ((system vm loader) #:select (load-thunk-from-memory))
+ #:use-module ((system vm program) #:select (program-sources source:addr)))
(define read-and-compile
(@@ (system base compile) read-and-compile))
@@ -97,7 +97,7 @@
#f)
(install-reader!)
this-should-be-ignored")))
- (and (eq? ((make-program (read-and-compile input)))
+ (and (eq? ((load-thunk-from-memory (read-and-compile input)))
'ok)
(eq? r (fluid-ref current-reader)))))
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index 0d95dba8e..52ce6b138 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -360,35 +360,18 @@
(pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
(abort-to-prompt 'does-not-exist)))
-(with-test-prefix/c&e "the-vm"
+(with-test-prefix/c&e "unwind"
- (pass-if "unwind changes VMs"
- (let ((new-vm (make-vm))
- (prev-vm (the-vm))
- (proc (lambda (x y)
+ (pass-if "unwind through call-with-vm"
+ (let ((proc (lambda (x y)
(expt x y)))
(call (lambda (p x y)
(p x y))))
(catch 'foo
(lambda ()
- (call-with-vm new-vm (lambda () (throw 'foo (the-vm)))))
- (lambda (key vm)
- (and (eq? key 'foo)
- (eq? vm new-vm)
- (eq? (the-vm) prev-vm))))))
-
- (pass-if "stack overflow reinstates stack reserve"
- ;; In Guile <= 2.0.9, only the first overflow would be gracefully
- ;; handle; subsequent overflows would lead to an abort. See
- ;; <http://lists.gnu.org/archive/html/guile-user/2013-12/msg00017.html>.
- (letrec ((foo (lambda () (+ 1 (foo)))))
- (define (overflows?)
- (catch 'vm-error foo
- (lambda (key proc msg . rest)
- (and (eq? 'vm-run proc)
- (->bool (string-contains msg "overflow"))))))
-
- (and (overflows?) (overflows?) (overflows?)))))
+ (call-with-vm (lambda () (throw 'foo))))
+ (lambda (key)
+ (eq? key 'foo))))))
;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain.
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 336c87a33..33b839ab6 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -33,8 +33,6 @@
(read-enable 'positions)
(compile (read input))))))
-(define %test-vm (make-vm))
-
(define test-procedure
(compile '(lambda (x)
(if (> x 2)
@@ -48,7 +46,7 @@
(let ((proc (code "foo.scm" "(lambda (x y) ;; 0
(+ x y)) ;; 1")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(and (coverage-data? data)
(= 3 result)
@@ -63,7 +61,7 @@
(display x) ;; 3
(+ x y)))) ;; 4")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(and (coverage-data? data)
(let-values (((instr exec)
@@ -78,7 +76,7 @@
(+ (/ x y) ;; 1
(* x y))) ;; 2")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "bar.scm")))
(and (pair? counts)
@@ -101,7 +99,7 @@
((= x 0) #t) ;; 7
((< x 0) 'never))))")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 77)))))
(let ((counts (line-execution-counts data "fooz.scm")))
(and (pair? counts)
@@ -125,7 +123,7 @@
(+ x y)) ;; 4
(+ x y))) ;; 5")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts)
@@ -148,7 +146,7 @@
(not (even? (1- x)))))) ;; 4
even?)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 0)))))
(let ((counts (line-execution-counts data "baz.scm")))
(and (pair? counts)
@@ -156,10 +154,9 @@
(let ((line (car line+count))
(count (cdr line+count)))
(case line
- ((0 1) (= count 1))
- ((2 3 4) (= count 0))
- ((5) (= count 1))
- (else #f))))
+ ((0 1) (= count 1))
+ ((2 3 4 5) (= count 0))
+ (else #f))))
counts))))))
(pass-if "case-lambda"
@@ -167,7 +164,7 @@
((x) (+ x 3)) ;; 1
((x y) (+ x y))) ;; 2")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(+ (proc 1) (proc 2 3))))))
(let ((counts (line-execution-counts data "cl.scm")))
@@ -180,7 +177,7 @@
(let ((proc (code "one-liner.scm"
"(lambda (x y) (+ x y (* x y) (if (> x y) 1 2) (quotient y x)))")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 451 1884)))))
(let ((counts (line-execution-counts data "one-liner.scm")))
(equal? counts '((0 . 1))))))))
@@ -191,7 +188,7 @@
(pass-if "several times"
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (+ (proc 1 2) (proc 2 3))))))
(and (coverage-data? data)
(= 3 result)
@@ -200,7 +197,7 @@
(pass-if "case-lambda"
(let ((proc (code "foo.scm" "(case-lambda ((x) x) ((x y) (+ x y)))")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(+ (proc 1) (proc 2 3))))))
(and (coverage-data? data)
@@ -210,25 +207,25 @@
(pass-if "never"
(let ((proc (code "foo.scm" "(lambda (x y) x)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (+ 1 2)))))
(and (coverage-data? data)
(= 3 result)
- (not (procedure-execution-count data proc))))))
+ (zero? (procedure-execution-count data proc))))))
(pass-if "applicable struct"
(let* ((<box> (make-struct <applicable-struct-vtable> 0 'pw))
(proc (lambda args (length args)))
(b (make-struct <box> 0 proc)))
(let-values (((data result)
- (with-code-coverage %test-vm b)))
+ (with-code-coverage b)))
(and (coverage-data? data)
(= 0 result)
(= (procedure-execution-count data proc) 1)))))
(pass-if "called from C"
;; The `scm_call_N' functions use the VM returned by `the-vm'. This
- ;; test makes sure that they get to use %TEST-VM.
+ ;; test makes sure that their calls are traced.
(let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
(call (false-if-exception ; can we resolve `scm_call_2'?
(pointer->procedure '*
@@ -237,7 +234,7 @@
'(* * *)))))
(if call
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(call (make-pointer (object-address proc))
(make-pointer (object-address 1))
@@ -249,7 +246,7 @@
(pass-if "called from eval"
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda ()
(eval '(test-procedure 123) (current-module))))))
(and (coverage-data? data)
@@ -262,10 +259,10 @@
(pass-if "source files are listed as expected"
(let ((proc (code "chbouib.scm" "(lambda (x y) x)")))
(let-values (((data result)
- (with-code-coverage %test-vm
+ (with-code-coverage
(lambda () (proc 1 2)))))
(let ((files (map basename (instrumented-source-files data))))
(and (member "boot-9.scm" files)
(member "chbouib.scm" files)
- (not (member "foo.scm" files))))))))
+ #t))))))
diff --git a/test-suite/tests/cross-compilation.test b/test-suite/tests/cross-compilation.test
new file mode 100644
index 000000000..5438c2092
--- /dev/null
+++ b/test-suite/tests/cross-compilation.test
@@ -0,0 +1,90 @@
+;;;; Cross compilation -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (tests cross-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system vm elf)
+ #:use-module (system base compile)
+ #:use-module (system base target))
+
+(define (test-triplet cpu vendor os)
+ (let ((triplet (string-append cpu "-" vendor "-" os)))
+ (pass-if (format #f "triplet ~a" triplet)
+ (with-target triplet
+ (lambda ()
+ (and (string=? (target-cpu) cpu)
+ (string=? (target-vendor) vendor)
+ (string=? (target-os) os)))))))
+
+(define (native-cpu)
+ (with-target %host-type target-cpu))
+
+(define (native-os)
+ (with-target %host-type target-os))
+
+(define (native-word-size)
+ ((@ (system foreign) sizeof) '*))
+
+(define (test-target triplet endian word-size)
+ (pass-if (format #f "target `~a' honored" triplet)
+ (with-target triplet
+ (lambda ()
+ (let ((word-size
+ ;; When the target is the native CPU, rather trust
+ ;; the native CPU's word size. This is because
+ ;; Debian's `sparc64-linux-gnu' port, for instance,
+ ;; actually has a 32-bit user-land, for instance (see
+ ;; <http://www.debian.org/ports/sparc/#sparc64bit>
+ ;; for details.)
+ (if (and (string=? (native-cpu) (target-cpu))
+ (string=? (native-os) (target-os)))
+ (native-word-size)
+ word-size))
+ (bv (compile '(hello-world) #:to 'bytecode)))
+ (and=> (parse-elf bv)
+ (lambda (elf)
+ (and (equal? (elf-byte-order elf) endian)
+ (equal? (elf-word-size elf) word-size)))))))))
+
+(with-test-prefix "cross-compilation"
+
+ (test-triplet "i586" "pc" "gnu0.3")
+ (test-triplet "x86_64" "unknown" "linux-gnu")
+ (test-triplet "x86_64" "unknown" "kfreebsd-gnu")
+
+ (test-target "i586-pc-gnu0.3" (endianness little) 4)
+ (test-target "x86_64-pc-linux-gnu" (endianness little) 8)
+ (test-target "powerpc-unknown-linux-gnu" (endianness big) 4)
+ (test-target "sparc64-unknown-freebsd8.2" (endianness big) 8)
+
+ (test-target "mips64el-unknown-linux-gnu" ; n32 or o32 ABI
+ (endianness little) 4)
+ (test-target "mips64el-unknown-linux-gnuabi64" ; n64 ABI (Debian tuplet)
+ (endianness little) 8)
+ (test-target "x86_64-unknown-linux-gnux32" ; x32 ABI (Debian tuplet)
+ (endianness little) 4)
+
+ (pass-if-exception "unknown target" exception:miscellaneous-error
+ (with-target "fcpu-unknown-gnu1.0"
+ (lambda ()
+ (compile '(ohai) #:to 'bytecode)))))
+
+;; Local Variables:
+;; eval: (put 'with-target 'scheme-indent-function 1)
+;; End:
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index e0219e84d..25e662624 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -28,7 +28,6 @@
#:use-module (language tree-il fix-letrec)
#:use-module (language tree-il cse)
#:use-module (language tree-il peval)
- #:use-module (language glil)
#:use-module (srfi srfi-13))
(define-syntax pass-if-cse
@@ -36,12 +35,12 @@
((_ in pat)
(pass-if 'in
(let ((evaled (unparse-tree-il
- (canonicalize!
- (fix-letrec!
+ (canonicalize
+ (fix-letrec
(cse
(peval
- (expand-primitives!
- (resolve-primitives!
+ (expand-primitives
+ (resolve-primitives
(compile 'in #:from 'scheme #:to 'tree-il)
(current-module))))))))))
(pmatch evaled
@@ -70,7 +69,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 +78,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 +109,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 +129,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 +144,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 +167,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 +187,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 +196,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 +215,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 +249,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,23 +276,23 @@
'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))))
(pass-if-cse
(begin (cons 1 2 3) 4)
- (begin
- (apply (primitive cons) (const 1) (const 2) (const 3))
+ (seq
+ (primcall cons (const 1) (const 2) (const 3))
(const 4)))
(pass-if "http://bugs.gnu.org/12883"
;; In 2.0.6, compiling this code would trigger an out-of-bounds
;; vlist access in CSE's traversal of its "database".
- (glil-program?
- (compile '(define (proc v)
+ (procedure?
+ (compile '(lambda (v)
(let ((failure (lambda () (bail-out 'match))))
(if (and (pair? v)
(null? (cdr v)))
@@ -308,5 +302,4 @@
#t
(failure)))
(failure))))
- #:from 'scheme
- #:to 'glil))))
+ #:from 'scheme))))
diff --git a/test-suite/tests/dwarf.test b/test-suite/tests/dwarf.test
new file mode 100644
index 000000000..bf36b65d8
--- /dev/null
+++ b/test-suite/tests/dwarf.test
@@ -0,0 +1,90 @@
+;;;; dwarf.test -*- scheme -*-
+;;;;
+;;;; Copyright 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-dwarf)
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 match)
+ #:use-module (system base compile)
+ #:use-module (system vm debug)
+ #:use-module (system vm program)
+ #:use-module (system vm loader))
+
+(define prog
+ (string-concatenate
+ ;; Every open parenthesis is a possible source location.
+ '("(define (qux f)\n"
+ ;^ 0:0
+ " (+ 32 (f)))\n"
+ ; ^1:2 ^1:8
+ "\n"
+ "(define bar\n"
+ ;^ 3;0
+ " (lambda (a)\n"
+ ; ^ 4:2
+ " 13))\n"
+ "'success\n")
+ ))
+
+(let* ((port (open-input-string prog))
+ (bv (begin
+ (set-port-filename! port "foo.scm")
+ (read-and-compile port #:to 'bytecode))))
+ (pass-if-equal 'success
+ ((load-thunk-from-memory bv)))
+
+ (pass-if-equal 13 (bar 10))
+
+ (let ((source (find-source-for-addr (program-code qux))))
+ (pass-if-equal "foo.scm" (source-file source))
+ (pass-if-equal 0 (source-line source))
+ (pass-if-equal 1 (source-line-for-user source))
+ (pass-if-equal 0 (source-column source)))
+
+ (let ((source (find-source-for-addr (program-code bar))))
+ (pass-if-equal "foo.scm" (source-file source))
+ (pass-if-equal 4 (source-line source))
+ (pass-if-equal 5 (source-line-for-user source))
+ (pass-if-equal 2 (source-column source)))
+
+ (match (find-program-sources (program-code qux))
+ ((s1 s2 s3)
+ (pass-if-equal "foo.scm" (source-file s1))
+ (pass-if-equal 0 (source-line s1))
+ (pass-if-equal 1 (source-line-for-user s1))
+ (pass-if-equal 0 (source-column s1))
+
+ (pass-if-equal "foo.scm" (source-file s2))
+ (pass-if-equal 1 (source-line s2))
+ (pass-if-equal 2 (source-line-for-user s2))
+ (pass-if-equal 8 (source-column s2))
+
+ (pass-if-equal "foo.scm" (source-file s3))
+ (pass-if-equal 1 (source-line s3))
+ (pass-if-equal 2 (source-line-for-user s3))
+ (pass-if-equal 2 (source-column s3)))
+ (sources
+ (error "unexpected sources" sources)))
+
+ (match (find-program-sources (program-code bar))
+ ((source)
+ (pass-if-equal "foo.scm" (source-file source))
+ (pass-if-equal 4 (source-line source))
+ (pass-if-equal 5 (source-line-for-user source))
+ (pass-if-equal 2 (source-column source)))
+ (sources
+ (error "unexpected sources" sources))))
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 6ab3b8ac8..2e0a767ba 100644
--- a/test-suite/tests/eval.test
+++ b/test-suite/tests/eval.test
@@ -1,5 +1,5 @@
;;;; eval.test --- tests guile's evaluator -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2006, 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,7 +18,7 @@
(define-module (test-suite test-eval)
:use-module (test-suite lib)
:use-module ((srfi srfi-1) :select (unfold count))
- :use-module ((system vm vm) :select (make-vm call-with-vm))
+ :use-module ((system vm vm) :select (call-with-vm))
:use-module (ice-9 documentation)
:use-module (ice-9 local-eval))
@@ -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
@@ -423,9 +437,8 @@
;; FIXME: this test does not test what it is intending to test
(pass-if-exception "exception raised"
exception:vm-error
- (let ((vm (make-vm))
- (thunk (let loop () (cons 's (loop)))))
- (call-with-vm vm thunk))))
+ (let ((thunk (let loop () (cons 's (loop)))))
+ (call-with-vm thunk))))
;;;
;;; docstrings
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
index acdb3db05..c53c0447b 100644
--- a/test-suite/tests/foreign.test
+++ b/test-suite/tests/foreign.test
@@ -333,6 +333,11 @@
(gc) (gc) (gc)
(every (cut = <> 9)
(map (lambda (f) (f 2)) procs)))
+ (throw 'unresolved)))
+
+ (pass-if "arity"
+ (if (and qsort (defined? 'procedure->pointer))
+ (equal? '(4 0 #f) (procedure-minimum-arity qsort))
(throw 'unresolved))))
@@ -342,6 +347,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/iconv.test b/test-suite/tests/iconv.test
index 9083cd256..be36336f3 100644
--- a/test-suite/tests/iconv.test
+++ b/test-suite/tests/iconv.test
@@ -94,6 +94,11 @@
(pass-if-exception "misparse latin1 as utf8" exception:decoding-error
(bytevector->string (string->bytevector s "latin1") "utf-8"))
+ (pass-if "misparse latin1 as utf8 with substitutions"
+ (equal? (bytevector->string (string->bytevector s "latin1")
+ "utf-8" 'substitute)
+ "?t?"))
+
(pass-if-exception "misparse latin1 as ascii" exception:decoding-error
(bytevector->string (string->bytevector s "latin1") "ascii"))))
diff --git a/test-suite/tests/linker.test b/test-suite/tests/linker.test
new file mode 100644
index 000000000..dcfac1b81
--- /dev/null
+++ b/test-suite/tests/linker.test
@@ -0,0 +1,82 @@
+;;;; linker.test -*- scheme -*-
+;;;;
+;;;; Copyright 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-linker)
+ #:use-module (test-suite lib)
+ #:use-module (rnrs bytevectors)
+ #:use-module (system base target)
+ #:use-module (system vm elf)
+ #:use-module (system vm linker))
+
+(define (link-elf-with-one-main-section name bytes)
+ (let ((strtab (make-string-table)))
+ (define (make-object index name bv relocs . kwargs)
+ (let ((name-idx (string-table-intern! strtab (symbol->string name))))
+ (make-linker-object (apply make-elf-section
+ #:index index
+ #:name name-idx
+ #:size (bytevector-length bv)
+ kwargs)
+ bv relocs
+ (list (make-linker-symbol name 0)))))
+ (define (make-shstrtab)
+ (string-table-intern! strtab ".shstrtab")
+ (make-object 2 '.shstrtab (link-string-table! strtab) '()
+ #:type SHT_STRTAB #:flags 0))
+ (let* ((word-size (target-word-size))
+ (endianness (target-endianness))
+ (sec (make-object 1 name bytes '()))
+ ;; This needs to be linked last, because linking other
+ ;; sections adds entries to the string table.
+ (shstrtab (make-shstrtab)))
+ (link-elf (list sec shstrtab)
+ #:endianness endianness #:word-size word-size))))
+
+(with-test-prefix "simple"
+ (define foo-bytes #vu8(0 1 2 3 4 5))
+ (define bytes #f)
+ (define elf #f)
+
+ (define (bytevectors-equal? bv-a bv-b start-a start-b size)
+ (or (zero? size)
+ (and (equal? (bytevector-u8-ref bv-a start-a)
+ (bytevector-u8-ref bv-b start-b))
+ (bytevectors-equal? bv-a bv-b (1+ start-a) (1+ start-b)
+ (1- size)))))
+
+ (pass-if "linking succeeds"
+ (begin
+ (set! bytes (link-elf-with-one-main-section '.foo foo-bytes))
+ #t))
+
+ (pass-if "parsing succeeds"
+ (begin
+ (set! elf (parse-elf bytes))
+ (elf? elf)))
+
+ ;; 5 sections: the initial NULL section, .foo, .shstrtab, the initial
+ ;; header with segment table, and the section table.
+ (pass-if-equal 5 (elf-shnum elf))
+
+ (pass-if ".foo section checks out"
+ (let ((sec (assoc-ref (elf-sections-by-name elf) ".foo")))
+ (and sec
+ (= (elf-section-size sec) (bytevector-length foo-bytes))
+ (bytevectors-equal? bytes foo-bytes
+ (elf-section-offset sec) 0
+ (bytevector-length foo-bytes))))))
diff --git a/test-suite/tests/peg.bench b/test-suite/tests/peg.bench
new file mode 100644
index 000000000..7baad5c73
--- /dev/null
+++ b/test-suite/tests/peg.bench
@@ -0,0 +1,173 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PEG benchmark suite (minimal right now).
+;; Parses very long equations several times; outputs the average time
+;; it took and the standard deviation of times.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(use-modules (ice-9 pretty-print))
+(use-modules (srfi srfi-1))
+(use-modules (ice-9 peg))
+(use-modules (ice-9 popen))
+
+;; Generate random equations.
+(define (gen-rand-eq len)
+ (if (= len 0)
+ (random 1000)
+ (let ((len (if (even? len) (+ len 1) len)))
+ (map (lambda (x)
+ (if (odd? x)
+ (gen-rand len 'op)
+ (gen-rand len 'number)))
+ (iota len)))))
+(define (gen-rand len type)
+ (cond ((eq? type 'number)
+ (cond
+ ((= (random 5) 0) (gen-rand-eq (floor (/ len 5))))
+ (#t (random 1000))))
+ (#t (list-ref '(+ - * /) (random 4)))))
+
+;; Generates a random equation string (len is a rough indicator of the
+;; resulting length).
+(define (gen-str len)
+ (with-output-to-string (lambda () (write (gen-rand-eq len)))))
+
+;; Generates a left-associative parser (see tutorial).
+(define (make-left-parser next-func)
+ (lambda (sum first . rest)
+ (if (null? rest)
+ (apply next-func first)
+ (if (string? (cadr first))
+ (list (string->symbol (cadr first))
+ (apply next-func (car first))
+ (apply next-func (car rest)))
+ (car
+ (reduce
+ (lambda (l r)
+ (list (list (cadr r) (car r) (apply next-func (car l)))
+ (string->symbol (cadr l))))
+ 'ignore
+ (append
+ (list (list (apply next-func (caar first))
+ (string->symbol (cadar first))))
+ (cdr first)
+ (list (append rest '("done"))))))))))
+
+;; Functions for parsing equations (see tutorial).
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+(define parse-product (make-left-parser parse-value))
+(define parse-sum (make-left-parser parse-product))
+(define parse-expr parse-sum)
+(define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
+
+;; PEG for parsing equations (see tutorial).
+(define-peg-string-patterns
+ "expr <- sum
+sum <-- (product ('+' / '-'))* product
+product <-- (value ('*' / '/'))* value
+value <-- sp number sp / sp '(' expr ')' sp
+number <-- [0-9]+
+sp < [ \t\n]*")
+
+;; gets the time in seconds (with a fractional part)
+(define (canon-time)
+ (let ((pair (gettimeofday)))
+ (+ (+ (car pair) (* (cdr pair) (expt 10 -6))) 0.0)))
+
+;; Times how long it takes for FUNC to complete when called on ARGS.
+;; **SIDE EFFECT** Writes the time FUNC took to stdout.
+;; Returns the return value of FUNC.
+(define (time-func func . args)
+ (let ((start (canon-time)))
+ (let ((res (apply func args)))
+ (pretty-print `(took ,(- (canon-time) start) seconds))
+ res)))
+;; Times how long it takes for FUNC to complete when called on ARGS.
+;; Returns the time FUNC took to complete.
+(define (time-ret-func func . args)
+ (let ((start (canon-time)))
+ (let ((res (apply func args)))
+ (- (canon-time) start))))
+
+;; test string (randomly generated)
+(define tst1 "(621 - 746 * 945 - 194 * (204 * (965 - 738 + (846)) - 450 / (116 * 293 * 543) + 858 / 693 - (890 * (260) - 855) + 875 - 684 / (749 - (846) + 127) / 670) - 293 - 815 - 628 * 93 - 662 + 561 / 645 + 112 - 71 - (286 - ((324) / 424 + 956) / 190 + ((848) / 132 * 602) + 5 + 765 * 220 - ((801) / 191 - 299) * 708 + 151 * 682) + (943 + 847 - 145 - 816 / 550 - 217 / 9 / 969 * 524 * 447 / 323) * 991 - 283 * 915 / 733 / 478 / (680 + 343 * 186 / 341 * ((571) * 848 - 47) - (492 + 398 * (616)) + 270 - 539 * 34 / 47 / 458) * 417 / 406 / 354 * 678 + 524 + 40 / 282 - 792 * 570 - 305 * 14 + (248 - 678 * 8 - 53 - 215 / 677 - 665 / 216 - 275 - 462 / 502) - 24 - 780 + (967 / (636 / 400 * 823) + 933 - 361 - 620 - 255 / 372 + 394 * 869 / 839 * 727) + (436 + 993 - 668 + 772 - 33 + 64 - 252 * 957 * 320 + 540 / (23 * 74 / (422))) + (516 / (348 * 219 * 986) * 85 * 149 * 957 * 602 / 141 / 80 / 456 / 92 / (443 * 468 * 466)) * 568 / (271 - 42 + 271 + 592 + 71 * (766 + (11) * 946) / 728 / 137 / 111 + 557 / 962) * 179 - 936 / 821 * 101 - 206 / (267 - (11 / 906 * 290) / 722 / 98 - 987 / 989 - 470 * 833 - (720 / 34 - 280) + 638 / 940) - 889 * 84 * 630 + ((214 - 888 + (46)) / 540 + 941 * 724 / 759 * (679 / 527 - 764) * 413 + 831 / 559 - (308 / 796 / 737) / 20))")
+
+;; appends two equations (adds them together)
+(define (eq-append . eqs)
+ (if (null? eqs)
+ "0"
+ (if (null? (cdr eqs))
+ (car eqs)
+ (string-append
+ (car eqs)
+ " + "
+ (apply eq-append (cdr eqs))))))
+
+;; concatenates an equation onto itself n times using eq-append
+(define (string-n str n)
+ (if (<= n 0)
+ "0"
+ (if (= n 1)
+ str
+ (eq-append str (string-n str (- n 1))))))
+
+;; standard deviation (no bias-correction)
+;; (also called population standard deviation)
+(define (stddev . lst)
+ (let ((llen (length lst)))
+ (if (<= llen 0)
+ 0
+ (let* ((avg (/ (reduce + 0 lst) llen))
+ (mapfun (lambda (x) (real-part (expt (- x avg) 2)))))
+ (sqrt (/ (reduce + 0 (map mapfun lst)) llen))))))
+
+;; average
+(define (avg . lst)
+ (if (null? lst)
+ 0
+ (/ (reduce + 0 lst) (length lst))))
+
+(pretty-print "Parsing equations (see PEG in tutorial). Sample size of 10 for each test.")
+(pretty-print
+ (let ((lst
+ (map
+ (lambda (ignore)
+ (reduce-right
+ append
+ 0
+ (map
+ (lambda (x)
+ (let* ((mstr (string-n tst1 x))
+ (strlen (string-length mstr)))
+ (let ((func (lambda () (begin (match-pattern expr mstr)
+ 'done))))
+ `(((string of length ,strlen first pass)
+ ,(time-ret-func func))
+ ((string of length ,strlen second pass)
+ ,(time-ret-func func))))))
+ (filter (lambda (x) (= (modulo x 25) 0)) (iota 100)))))
+ (iota 10))))
+ (let ((compacted
+ (reduce-right
+ (lambda (accum conc)
+ (map (lambda (l r) (append l (cdr r))) accum conc))
+ 0
+ lst)))
+ (map
+ (lambda (els)
+ `(,(car els)
+ (average time in seconds ,(apply avg (cdr els)))
+ (standard deviation ,(apply stddev (cdr els)))))
+ compacted))))
+
+(define (sys-calc str)
+ (let* ((pipe (open-input-pipe (string-append "echo \"" str "\" | bc -l")))
+ (str (read pipe)))
+ (close-pipe pipe)
+ str))
+(define (lisp-calc str)
+ (+ (eval (eq-parse str) (interaction-environment)) 0.0))
+
+;; (pretty-print `(,(sys-calc tst1) ,(lisp-calc tst1)))
diff --git a/test-suite/tests/peg.test b/test-suite/tests/peg.test
new file mode 100644
index 000000000..f516571e8
--- /dev/null
+++ b/test-suite/tests/peg.test
@@ -0,0 +1,278 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;; PEG test suite.
+;; Tests the parsing capabilities of (ice-9 peg). Could use more
+;; tests for edge cases.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-module (test-suite test-peg)
+ :use-module (test-suite lib)
+ :use-module (ice-9 peg)
+ :use-module (ice-9 pretty-print)
+ :use-module (srfi srfi-1))
+
+;; Doubled up for pasting into REPL.
+(use-modules (test-suite lib))
+(use-modules (ice-9 peg))
+(use-modules (ice-9 pretty-print))
+(use-modules (srfi srfi-1))
+
+;; Evaluates an expression at the toplevel. Not the prettiest
+;; solution to runtime issues ever, but m3h. Runs at toplevel so that
+;; symbols are bound globally instead of in the scope of the pass-if
+;; expression.
+(define (eeval exp)
+ (eval exp (interaction-environment)))
+(define make-prec (@@ (ice-9 peg) make-prec))
+
+;; Maps the nonterminals defined in the PEG parser written as a PEG to
+;; the nonterminals defined in the PEG parser written with
+;; S-expressions.
+(define grammar-mapping
+ '((grammar peg-grammar)
+ (pattern peg-pattern)
+ (alternative peg-alternative)
+ (suffix peg-suffix)
+ (primary peg-primary)
+ (literal peg-literal)
+ (charclass peg-charclass)
+ (CCrange charclass-range)
+ (CCsingle charclass-single)
+ (nonterminal peg-nonterminal)
+ (sp peg-sp)))
+
+;; Transforms the nonterminals defined in the PEG parser written as a PEG to the nonterminals defined in the PEG parser written with S-expressions.
+(define (grammar-transform x)
+ (let ((res (assoc x grammar-mapping)))
+ (if res (cadr res) x)))
+
+;; Maps a function onto a tree (recurses until it finds atoms, then calls the function on the atoms).
+(define (tree-map fn lst)
+ (if (list? lst)
+ (if (null? lst)
+ lst
+ (cons (tree-map fn (car lst))
+ (tree-map fn (cdr lst))))
+ (fn lst)))
+
+;; Tests to make sure that we can parse a PEG defining a grammar for
+;; PEGs, then uses that grammar to parse the same PEG again to make
+;; sure we get the same result (i.e. make sure our PEG grammar
+;; expressed as a PEG is equivalent to our PEG grammar expressed with
+;; S-expressions).
+(with-test-prefix "PEG Grammar"
+ (pass-if
+ "defining PEGs with PEG"
+ (and (eeval `(define-peg-string-patterns ,(@@ (ice-9 peg) peg-as-peg))) #t))
+ (pass-if
+ "equivalence of definitions"
+ (equal?
+ (peg:tree (match-pattern (@@ (ice-9 peg) peg-grammar) (@@ (ice-9 peg) peg-as-peg)))
+ (tree-map
+ grammar-transform
+ (peg:tree (match-pattern grammar (@@ (ice-9 peg) peg-as-peg)))))))
+
+;; A grammar for pascal-style comments from Wikipedia.
+(define comment-grammar
+ "Begin <-- '(*'
+End <-- '*)'
+C <- Begin N* End
+N <- C / (!Begin !End Z)
+Z <- .")
+
+;; A short /etc/passwd file.
+(define *etc-passwd*
+ "root:x:0:0:root:/root:/bin/bash
+daemon:x:1:1:daemon:/usr/sbin:/bin/sh
+bin:x:2:2:bin:/bin:/bin/sh
+sys:x:3:3:sys:/dev:/bin/sh
+nobody:x:65534:65534:nobody:/nonexistent:/bin/sh
+messagebus:x:103:107::/var/run/dbus:/bin/false
+")
+
+;; A grammar for parsing /etc/passwd files.
+(define-peg-string-patterns
+ "passwd <-- entry* !.
+entry <-- login CO pass CO uid CO gid CO nameORcomment CO homedir CO shell NL*
+login <-- text
+pass <-- text
+uid <-- [0-9]*
+gid <-- [0-9]*
+nameORcomment <-- text
+homedir <-- path
+shell <-- path
+path <-- (SLASH pathELEMENT)*
+pathELEMENT <-- (!NL !CO !'/' .)*
+text <- (!NL !CO .)*
+CO < ':'
+NL < '\n'
+SLASH < '/'")
+
+;; Tests some actual parsing using PEGs.
+(with-test-prefix "Parsing"
+ (eeval `(define-peg-string-patterns ,comment-grammar))
+ (pass-if
+ ;; Pascal-style comment parsing
+ "simple comment"
+ (equal?
+ (match-pattern C "(*blah*)")
+ (make-prec 0 8 "(*blah*)"
+ '((Begin "(*") "blah" (End "*)")))))
+ (pass-if
+ "simple comment padded"
+ (equal?
+ (match-pattern C "(*blah*)abc")
+ (make-prec 0 8 "(*blah*)abc"
+ '((Begin "(*") "blah" (End "*)")))))
+ (pass-if
+ "nested comment"
+ (equal?
+ (match-pattern C "(*1(*2*)*)")
+ (make-prec 0 10 "(*1(*2*)*)"
+ '((Begin "(*") ("1" ((Begin "(*") "2" (End "*)"))) (End "*)")))))
+ (pass-if
+ "early termination"
+ (not (match-pattern C "(*blah")))
+ (pass-if
+ "never starts"
+ (not (match-pattern C "blah")))
+ ;; /etc/passwd parsing
+ (pass-if
+ "/etc/passwd"
+ (equal?
+ (match-pattern passwd *etc-passwd*)
+ (make-prec 0 220 *etc-passwd*
+ '(passwd (entry (login "root") (pass "x") (uid "0") (gid "0") (nameORcomment "root") (homedir (path (pathELEMENT "root"))) (shell (path (pathELEMENT "bin") (pathELEMENT "bash")))) (entry (login "daemon") (pass "x") (uid "1") (gid "1") (nameORcomment "daemon") (homedir (path (pathELEMENT "usr") (pathELEMENT "sbin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "bin") (pass "x") (uid "2") (gid "2") (nameORcomment "bin") (homedir (path (pathELEMENT "bin"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "sys") (pass "x") (uid "3") (gid "3") (nameORcomment "sys") (homedir (path (pathELEMENT "dev"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "nobody") (pass "x") (uid "65534") (gid "65534") (nameORcomment "nobody") (homedir (path (pathELEMENT "nonexistent"))) (shell (path (pathELEMENT "bin") (pathELEMENT "sh")))) (entry (login "messagebus") (pass "x") (uid "103") (gid "107") nameORcomment (homedir (path (pathELEMENT "var") (pathELEMENT "run") (pathELEMENT "dbus"))) (shell (path (pathELEMENT "bin") (pathELEMENT "false")))))))))
+
+;; Tests the functions for pulling data out of PEG Match Records.
+(with-test-prefix "PEG Match Records"
+ (define-peg-pattern bs all (peg "'b'+"))
+ (pass-if
+ "basic parameter extraction"
+ (equal?
+ (let ((pm (search-for-pattern bs "aabbcc")))
+ `((string ,(peg:string pm))
+ (start ,(peg:start pm))
+ (end ,(peg:end pm))
+ (substring ,(peg:substring pm))
+ (tree ,(peg:tree pm))
+ (record? ,(peg-record? pm))))
+ '((string "aabbcc")
+ (start 2)
+ (end 4)
+ (substring "bb")
+ (tree (bs "bb"))
+ (record? #t)))))
+
+;; PEG for parsing right-associative equations.
+(define-peg-string-patterns
+ "expr <- sum
+sum <-- (product ('+' / '-') sum) / product
+product <-- (value ('*' / '/') product) / value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+;; Functions to actually evaluate the equations parsed with the PEG.
+(define (parse-sum sum left . rest)
+ (if (null? rest)
+ (apply parse-product left)
+ (list (string->symbol (car rest))
+ (apply parse-product left)
+ (apply parse-sum (cadr rest)))))
+
+(define (parse-product product left . rest)
+ (if (null? rest)
+ (apply parse-value left)
+ (list (string->symbol (car rest))
+ (apply parse-value left)
+ (apply parse-product (cadr rest)))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+
+(define parse-expr parse-sum)
+(define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
+
+(with-test-prefix "Parsing right-associative equations"
+ (pass-if
+ "1"
+ (equal? (eq-parse "1") 1))
+ (pass-if
+ "1+2"
+ (equal? (eq-parse "1+2") '(+ 1 2)))
+ (pass-if
+ "1+2+3"
+ (equal? (eq-parse "1+2+3") '(+ 1 (+ 2 3))))
+ (pass-if
+ "1+2*3+4"
+ (equal? (eq-parse "1+2*3+4") '(+ 1 (+ (* 2 3) 4))))
+ (pass-if
+ "1+2/3*(4+5)/6-7-8"
+ (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
+ '(+ 1 (- (/ 2 (* 3 (/ (+ 4 5) 6))) (- 7 8)))))
+ (pass-if
+ "1+1/2*3+(1+1)/2"
+ (equal? (eq-parse "1+1/2*3+(1+1)/2")
+ '(+ 1 (+ (/ 1 (* 2 3)) (/ (+ 1 1) 2))))))
+
+;; PEG for parsing left-associative equations (normal ones).
+(define-peg-string-patterns
+ "expr <- sum
+sum <-- (product ('+' / '-'))* product
+product <-- (value ('*' / '/'))* value
+value <-- number / '(' expr ')'
+number <-- [0-9]+")
+
+;; Functions to actually evaluate the equations parsed with the PEG.
+(define (make-left-parser next-func)
+ (lambda (sum first . rest)
+ (if (null? rest)
+ (apply next-func first)
+ (if (string? (cadr first))
+ (list (string->symbol (cadr first))
+ (apply next-func (car first))
+ (apply next-func (car rest)))
+ (car
+ (reduce
+ (lambda (l r)
+ (list (list (cadr r) (car r) (apply next-func (car l)))
+ (string->symbol (cadr l))))
+ 'ignore
+ (append
+ (list (list (apply next-func (caar first))
+ (string->symbol (cadar first))))
+ (cdr first)
+ (list (append rest '("done"))))))))))
+
+(define (parse-value value first . rest)
+ (if (null? rest)
+ (string->number (cadr first))
+ (apply parse-sum (car rest))))
+(define parse-product (make-left-parser parse-value))
+(define parse-sum (make-left-parser parse-product))
+(define parse-expr parse-sum)
+(define (eq-parse str) (apply parse-expr (peg:tree (match-pattern expr str))))
+
+(with-test-prefix "Parsing left-associative equations"
+ (pass-if
+ "1"
+ (equal? (eq-parse "1") 1))
+ (pass-if
+ "1+2"
+ (equal? (eq-parse "1+2") '(+ 1 2)))
+ (pass-if
+ "1+2+3"
+ (equal? (eq-parse "1+2+3") '(+ (+ 1 2) 3)))
+ (pass-if
+ "1+2*3+4"
+ (equal? (eq-parse "1+2*3+4") '(+ (+ 1 (* 2 3)) 4)))
+ (pass-if
+ "1+2/3*(4+5)/6-7-8"
+ (equal? (eq-parse "1+2/3*(4+5)/6-7-8")
+ '(- (- (+ 1 (/ (* (/ 2 3) (+ 4 5)) 6)) 7) 8)))
+ (pass-if
+ "1+1/2*3+(1+1)/2"
+ (equal? (eq-parse "1+1/2*3+(1+1)/2")
+ '(+ (+ 1 (* (/ 1 2) 3)) (/ (+ 1 1) 2)))))
+
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 5b003d26d..4d8a28050 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -24,7 +24,6 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language glil)
#:use-module (rnrs bytevectors) ;; for the bytevector primitives
#:use-module (srfi srfi-13))
@@ -33,14 +32,11 @@
(@@ (language tree-il optimize) peval))
(define-syntax pass-if-peval
- (syntax-rules (resolve-primitives)
+ (syntax-rules ()
((_ 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!
+ (expand-primitives
+ (resolve-primitives
(compile 'in #:from 'scheme #:to 'tree-il)
(current-module)))))
((_ in pat code)
@@ -75,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))
@@ -85,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))
@@ -105,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
@@ -139,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.
#;
@@ -163,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
@@ -181,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
@@ -205,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)
@@ -218,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'
@@ -229,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
@@ -245,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
@@ -257,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
@@ -269,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.
@@ -282,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.
@@ -314,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.
@@ -324,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.
@@ -349,15 +344,19 @@
(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
+ +
+ (primcall
+ +
+ (primcall
+ +
+ (const -1) ; (f -1 0)
+ (seq (toplevel y) (const -1))) ; (f -1 y)
+ (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.
@@ -369,7 +368,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.
@@ -388,8 +387,8 @@
(foo)
x)
(let (x) (_) ((toplevel top))
- (begin
- (apply (toplevel foo))
+ (seq
+ (call (toplevel foo))
(lexical x _))))
(pass-if-peval
@@ -428,8 +427,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).
@@ -451,7 +450,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.
@@ -462,7 +461,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)
@@ -474,7 +473,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,
@@ -485,24 +484,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))))
@@ -522,8 +524,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.
@@ -544,9 +546,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
@@ -554,21 +556,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.
@@ -580,12 +581,12 @@
(lambda (n)
(vector-set! v n n)))
(let (v) (_)
- ((apply (toplevel make-vector) (const 6) (const #f)))
+ ((primcall 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.
@@ -593,7 +594,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 () ())
@@ -604,12 +605,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 +
+ (primcall + (lexical x _) (lexical x _))
+ (lexical y _)))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
@@ -621,16 +623,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))
@@ -638,9 +640,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
@@ -649,8 +651,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.
@@ -658,7 +660,7 @@
(set! x 3)
x)
(let (x) (_) ((const 2))
- (begin
+ (seq
(set! (lexical x _) (const 3))
(lexical x _))))
@@ -671,8 +673,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
@@ -688,9 +690,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
@@ -701,10 +703,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.
@@ -713,8 +715,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.
@@ -729,10 +731,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.
@@ -749,7 +751,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.
@@ -760,10 +762,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))
@@ -799,7 +801,7 @@
((lambda _
(lambda-case
((() #f #f #f () ())
- (apply (lexical a _)))))
+ (call (lexical a _)))))
(lambda _
(lambda-case
(((x) #f #f #f () (_))
@@ -807,12 +809,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
@@ -821,17 +822,17 @@
(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 resolve-primitives
+ (pass-if-peval
;; The inliner sees through a `let'.
((let ((a 10)) (lambda (b) (* b 2))) 30)
(const 60))
@@ -848,39 +849,39 @@
((lambda (x y . z)
(list x y z))
1 2 3 4)
- (let (z) (_) ((apply (primitive list) (const 3) (const 4)))
- (apply (primitive list) (const 1) (const 2) (lexical z _))))
+ (let (z) (_) ((primcall list (const 3) (const 4)))
+ (primcall list (const 1) (const 2) (lexical z _))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; Unmutated lists can get inlined.
(let ((args (list 2 3)))
(apply (lambda (x y z w)
(list x y z w))
0 1 args))
- (apply (primitive list) (const 0) (const 1) (const 2) (const 3)))
+ (primcall list (const 0) (const 1) (const 2) (const 3)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; However if the list might have been mutated, it doesn't propagate.
(let ((args (list 2 3)))
(foo! args)
(apply (lambda (x y z w)
(list x y z w))
0 1 args))
- (let (args) (_) ((apply (primitive list) (const 2) (const 3)))
- (begin
- (apply (toplevel foo!) (lexical args _))
- (apply (primitive @apply)
- (lambda ()
- (lambda-case
- (((x y z w) #f #f #f () (_ _ _ _))
- (apply (primitive list)
- (lexical x _) (lexical y _)
- (lexical z _) (lexical w _)))))
- (const 0)
- (const 1)
- (lexical args _)))))
-
- (pass-if-peval resolve-primitives
+ (let (args) (_) ((primcall list (const 2) (const 3)))
+ (seq
+ (call (toplevel foo!) (lexical args _))
+ (primcall apply
+ (lambda ()
+ (lambda-case
+ (((x y z w) #f #f #f () (_ _ _ _))
+ (primcall list
+ (lexical x _) (lexical y _)
+ (lexical z _) (lexical w _)))))
+ (const 0)
+ (const 1)
+ (lexical args _)))))
+
+ (pass-if-peval
;; Here the `args' that gets built by the application of the lambda
;; takes more than effort "10" to visit. Test that we fall back to
;; the source expression of the operand, which is still a call to
@@ -893,7 +894,7 @@
bv
(+ offset 4))))
(let ((args (list x y)))
- (@apply
+ (apply
(lambda (bv offset x y)
(bytevector-ieee-single-native-set!
bv
@@ -909,31 +910,31 @@
(lambda ()
(lambda-case
(((bv offset n) #f #f #f () (_ _ _))
- (let (x y) (_ _) ((apply (primitive bytevector-ieee-single-native-ref)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 0)))
- (apply (primitive bytevector-ieee-single-native-ref)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 4))))
- (begin
- (apply (primitive bytevector-ieee-single-native-set!)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 0))
- (lexical x _))
- (apply (primitive bytevector-ieee-single-native-set!)
- (lexical bv _)
- (apply (primitive +)
- (lexical offset _) (const 4))
- (lexical y _))))))))
-
- (pass-if-peval resolve-primitives
+ (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 0)))
+ (primcall bytevector-ieee-single-native-ref
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 4))))
+ (seq
+ (primcall bytevector-ieee-single-native-set!
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 0))
+ (lexical x _))
+ (primcall bytevector-ieee-single-native-set!
+ (lexical bv _)
+ (primcall +
+ (lexical offset _) (const 4))
+ (lexical y _))))))))
+
+ (pass-if-peval
;; Here we ensure that non-constant expressions are not copied.
(lambda ()
(let ((args (list (foo!))))
- (@apply
+ (apply
(lambda (z x)
(list z x))
;; This toplevel ref might raise an unbound variable exception.
@@ -943,18 +944,18 @@
(lambda ()
(lambda-case
((() #f #f #f () ())
- (let (_) (_) ((apply (toplevel foo!)))
+ (let (_) (_) ((call (toplevel foo!)))
(let (z) (_) ((toplevel z))
- (apply (primitive 'list)
- (lexical z _)
- (lexical _ _))))))))
+ (primcall 'list
+ (lexical z _)
+ (lexical _ _))))))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
;; Rest args referenced more than once are not destructured.
(lambda ()
(let ((args (list 'foo)))
(set-car! args 'bar)
- (@apply
+ (apply
(lambda (z x)
(list z x))
z
@@ -963,25 +964,34 @@
(lambda-case
((() #f #f #f () ())
(let (args) (_)
- ((apply (primitive list) (const foo)))
- (begin
- (apply (primitive set-car!) (lexical args _) (const bar))
- (apply (primitive @apply)
- (lambda . _)
- (toplevel z)
- (lexical args _))))))))
-
- (pass-if-peval resolve-primitives
+ ((primcall list (const foo)))
+ (seq
+ (primcall set-car! (lexical args _) (const bar))
+ (primcall apply
+ (lambda . _)
+ (toplevel z)
+ (lexical args _))))))))
+
+ (pass-if-peval
;; Let-values inlining, even with consumers with rest args.
(call-with-values (lambda () (values 1 2))
(lambda args
(apply list args)))
- (apply (primitive list) (const 1) (const 2)))
+ (primcall list (const 1) (const 2)))
+
+ (pass-if-peval
+ ;; When we can't inline let-values but can prove that the producer
+ ;; has just one value, reduce to "let" (which can then fold
+ ;; further).
+ (call-with-values (lambda () (if foo 1 2))
+ (lambda args
+ (apply values args)))
+ (if (toplevel foo) (const 1) (const 2)))
(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
@@ -991,7 +1001,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
@@ -1011,12 +1021,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
@@ -1026,40 +1036,81 @@
(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.
+ ;; Non-constant guards get lexical bindings, invocation of winder and
+ ;; unwinder lifted out. Unfortunately both have the generic variable
+ ;; name "tmp", so we can't distinguish them in this test, and they
+ ;; also collide in generic names with the single-value result from
+ ;; the dynwind; alack.
(dynamic-wind foo (lambda () bar) baz)
- (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
- (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
+ (let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
+ (seq (seq (if (primcall thunk? (lexical tmp _))
+ (call (lexical tmp _))
+ (primcall scm-error . _))
+ (primcall wind (lexical tmp _) (lexical tmp _)))
+ (let (tmp) (_) ((toplevel bar))
+ (seq (seq (primcall unwind)
+ (call (lexical tmp _)))
+ (lexical tmp _))))))
(pass-if-peval
- resolve-primitives
- ;; Constant guards don't need lexical bindings.
+ ;; Constant guards don't need lexical bindings or thunk? checks.
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
- (dynwind
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
- (toplevel bar)
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
+ (seq (seq (toplevel foo)
+ (primcall wind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+ (let (tmp) (_) ((toplevel bar))
+ (seq (seq (primcall unwind)
+ (toplevel baz))
+ (lexical tmp _)))))
+
+ (pass-if-peval
+ ;; Dynwind bodies that return an unknown number of values need a
+ ;; let-values.
+ (dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
+ (seq (seq (toplevel foo)
+ (primcall wind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+ (let-values (call (toplevel bar))
+ (lambda-case
+ ((() #f vals #f () (_))
+ (seq (seq (primcall unwind)
+ (toplevel baz))
+ (primcall apply (primitive values) (lexical vals _))))))))
(pass-if-peval
- resolve-primitives
;; Prompt is removed if tag is unreferenced
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
@@ -1068,7 +1119,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
@@ -1078,33 +1128,31 @@
;; Handler lambda inlined
(pass-if-peval
- resolve-primitives
(call-with-prompt tag
(lambda () 1)
(lambda (k x) x))
- (prompt (toplevel tag)
+ (prompt #t
+ (toplevel tag)
(const 1)
- (lambda-case
- (((k x) #f #f #f () (_ _))
- (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((k x) #f #f #f () (_ _))
+ (lexical x _))))))
;; Handler toplevel not inlined
(pass-if-peval
- resolve-primitives
- (call-with-prompt tag
- (lambda () 1)
- handler)
- (let (handler) (_) ((toplevel handler))
- (prompt (toplevel tag)
- (const 1)
- (lambda-case
- ((() #f args #f () (_))
- (apply (primitive @apply)
- (lexical handler _)
- (lexical args _)))))))
-
- (pass-if-peval
- resolve-primitives
+ (call-with-prompt tag
+ (lambda () 1)
+ handler)
+ (prompt #f
+ (toplevel tag)
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (const 1))))
+ (toplevel handler)))
+
+ (pass-if-peval
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
;; elided, and the continuation tag stays around. (The continue tag
@@ -1113,7 +1161,7 @@
;; twice before aborting. The abort doesn't unroll the recursive
;; reference.)
(while #t #t)
- (let (_) (_) ((apply (primitive make-prompt-tag) . _))
+ (let (_) (_) ((primcall make-prompt-tag . _))
(letrec (lp) (_)
((lambda _
(lambda-case
@@ -1122,12 +1170,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))
@@ -1136,7 +1183,7 @@
(((x y) #f #f #f () (_ _))
_))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(car '(1 2))
(const 1))
@@ -1145,17 +1192,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))
@@ -1166,25 +1213,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)
@@ -1195,46 +1242,62 @@
(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 _)))))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(apply (lambda (x y) (cons x y)) '(1 2))
- (apply (primitive cons) (const 1) (const 2)))
+ (primcall cons (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ (pass-if-peval
(apply (lambda (x y) (cons x y)) (list 1 2))
- (apply (primitive cons) (const 1) (const 2)))
+ (primcall cons (const 1) (const 2)))
- (pass-if-peval resolve-primitives
+ ;; Disable after removal of abort-in-tail-position optimization, in
+ ;; hopes that CPS does a uniformly better job.
+ #;
+ (pass-if-peval
(let ((t (make-prompt-tag)))
(call-with-prompt t
(lambda () (abort-to-prompt t 1 2 3))
(lambda (k x y z) (list x y z))))
- (apply (primitive 'list) (const 1) (const 2) (const 3)))
-
- (pass-if-peval resolve-primitives
- ;; Should not inline tail list to apply if it is mutable.
- ;; <http://debbugs.gnu.org/15533>
- (let ((l '()))
- (if (pair? arg)
- (set! l arg))
- (apply f l))
- (let (l) (_) ((const ()))
- (begin
- (if (apply (primitive pair?) (toplevel arg))
- (set! (lexical l _) (toplevel arg))
- (void))
- (apply (primitive @apply) (toplevel f) (lexical l _))))))
+ (primcall list (const 1) (const 2) (const 3)))
+
+ (pass-if-peval
+ (call-with-values foo (lambda (x) (bar x)))
+ (let (x) (_) ((call (toplevel foo)))
+ (call (toplevel bar) (lexical x _))))
+
+ (pass-if-peval
+ ((lambda (foo)
+ (define* (bar a #:optional (b (1+ a)))
+ (list a b))
+ (bar 1))
+ 1)
+ (primcall list (const 1) (const 2)))
+
+ (pass-if-peval
+ ;; Should not inline tail list to apply if it is mutable.
+ ;; <http://debbugs.gnu.org/15533>
+ (let ((l '()))
+ (if (pair? arg)
+ (set! l arg))
+ (apply f l))
+ (let (l) (_) ((const ()))
+ (seq
+ (if (primcall pair? (toplevel arg))
+ (set! (lexical l _) (toplevel arg))
+ (void))
+ (primcall apply (toplevel f) (lexical l _))))))
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index c2f4480f8..bad4118bc 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -698,32 +698,15 @@
(pass-if "output check"
(string=? text result)))
- (pass-if "encoding failure leads to exception"
- ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'.
- ;; See the discussion at <http://bugs.gnu.org/11197>, for details.
- (catch 'encoding-error
- (lambda ()
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (let ((p (open-input-string "λ"))) ; raise an exception
- #f)))
- (lambda (key . rest)
- #t)
- (lambda (key . rest)
- ;; At this point, the port-table mutex used to be still held,
- ;; hence the deadlock. This situation would occur when trying
- ;; to print a backtrace, for instance.
- (input-port? (open-input-string "foo")))))
-
- (pass-if "%default-port-encoding is honored"
- (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3")))
- (equal? (map (lambda (e)
- (with-fluids ((%default-port-encoding e))
- (call-with-output-string
- (lambda (p)
- (and (string=? e (port-encoding p))
- (display (port-encoding p) p))))))
- encodings)
- encodings)))
+ (pass-if "%default-port-encoding is ignored"
+ (let ((str "ĉu bone?"))
+ ;; Latin-1 cannot represent ‘ĉ’.
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-conversion-strategy! p 'substitute)
+ (display str p)))
+ "ĉu bone?"))))
(pass-if "%default-port-conversion-strategy is honored"
(let ((strategies '(error substitute escape)))
@@ -740,77 +723,58 @@
(map symbol->string strategies))))
(pass-if "suitable encoding [latin-1]"
- (let ((str "hello, world"))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (equal? str
- (with-output-to-string
- (lambda ()
- (display str)))))))
+ (let ((str "hello, world")
+ (encoding "ISO-8859-1"))
+ (equal? str
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p encoding)
+ (display str p))))))
(pass-if "suitable encoding [latin-3]"
- (let ((str "ĉu bone?"))
- (with-fluids ((%default-port-encoding "ISO-8859-3"))
- (equal? str
- (with-output-to-string
- (lambda ()
- (display str)))))))
+ (let ((str "ĉu bone?")
+ (encoding "ISO-8859-3"))
+ (equal? str
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p encoding)
+ (display str p))))))
(pass-if "wrong encoding, error"
(let ((str "ĉu bone?"))
(catch 'encoding-error
(lambda ()
- ;; Latin-1 cannot represent ‘ĉ’.
- (with-fluids ((%default-port-encoding "ISO-8859-1")
- (%default-port-conversion-strategy 'error))
- (with-output-to-string
- (lambda ()
- (display str))))
- #f) ; so the test really fails here
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (call-with-output-string
+ (lambda (p)
+ ;; Latin-1 cannot represent ‘ĉ’.
+ (set-port-encoding! p "ISO-8859-1")
+ (display str p))))
+ #f) ; so the test really fails here
(lambda (key subr message errno port chr)
(and (eqv? chr #\ĉ)
(string? (strerror errno)))))))
(pass-if "wrong encoding, substitute"
(let ((str "ĉu bone?"))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (string=? (with-output-to-string
- (lambda ()
- (set-port-conversion-strategy! (current-output-port)
- 'substitute)
- (display str)))
- "?u bone?"))))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p "ISO-8859-1")
+ (set-port-conversion-strategy! p 'substitute)
+ (display str p)))
+ "?u bone?")))
(pass-if "wrong encoding, escape"
(let ((str "ĉu bone?"))
- (with-fluids ((%default-port-encoding "ISO-8859-1"))
- (string=? (with-output-to-string
- (lambda ()
- (set-port-conversion-strategy! (current-output-port)
- 'escape)
- (display str)))
- "\\u0109u bone?"))))
-
- (pass-if "peek-char [latin-1]"
- (let ((p (with-fluids ((%default-port-encoding #f))
- (open-input-string "hello, world"))))
- (and (char=? (peek-char p) #\h)
- (char=? (peek-char p) #\h)
- (char=? (peek-char p) #\h)
- (= (port-line p) 0)
- (= (port-column p) 0))))
-
- (pass-if "peek-char [utf-8]"
- (let ((p (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "안녕하세요"))))
- (and (char=? (peek-char p) #\안)
- (char=? (peek-char p) #\안)
- (char=? (peek-char p) #\안)
- (= (port-line p) 0)
- (= (port-column p) 0))))
-
- (pass-if "peek-char [utf-16]"
- (let ((p (with-fluids ((%default-port-encoding "UTF-16BE"))
- (open-input-string "안녕하세요"))))
+ (string=? (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p "ISO-8859-1")
+ (set-port-conversion-strategy! p 'escape)
+ (display str p)))
+ "\\u0109u bone?")))
+
+ (pass-if "peek-char"
+ (let ((p (open-input-string "안녕하세요")))
(and (char=? (peek-char p) #\안)
(char=? (peek-char p) #\안)
(char=? (peek-char p) #\안)
@@ -1207,10 +1171,15 @@
(set-port-encoding! p "does-not-exist")
(read p)))
- (pass-if-exception "%default-port-encoding, wrong encoding"
- exception:miscellaneous-error
- (read (with-fluids ((%default-port-encoding "does-not-exist"))
- (open-input-string "")))))
+ (let ((filename (test-file)))
+ (with-output-to-file filename (lambda () (write 'test)))
+
+ (pass-if-exception "%default-port-encoding, wrong encoding"
+ exception:miscellaneous-error
+ (read (with-fluids ((%default-port-encoding "does-not-exist"))
+ (open-input-file filename))))
+
+ (delete-file filename)))
;;;
;;; port-for-each
@@ -1786,8 +1755,8 @@
(pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
"a\uFEFFb"
(bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
- #x00 #x00 #xFE #xFF
- #x00 #x00 #x00 #x62)))
+ #x00 #x00 #xFE #xFF
+ #x00 #x00 #x00 #x62)))
(pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
"a"
diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test
index 01bc9945d..6ef0e9fc7 100644
--- a/test-suite/tests/print.test
+++ b/test-suite/tests/print.test
@@ -1,6 +1,6 @@
;;;; -*- coding: utf-8; mode: scheme; -*-
;;;;
-;;;; Copyright (C) 2010, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2013, 2014 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
@@ -118,31 +118,31 @@
(define exp '(a b #(c d e) f . g))
(define (tprint x width encoding)
- (with-fluids ((%default-port-encoding encoding))
- (with-output-to-string
- (lambda ()
- (truncated-print x #:width width)))))
+ (call-with-output-string
+ (lambda (p)
+ (set-port-encoding! p encoding)
+ (truncated-print x p #:width width))))
- (pass-if (equal? (tprint exp 10 "ISO-8859-1")
- "(a b . #)"))
+ (pass-if-equal "(a b . #)"
+ (tprint exp 10 "ISO-8859-1"))
- (pass-if (equal? (tprint exp 15 "ISO-8859-1")
- "(a b # f . g)"))
+ (pass-if-equal "(a b # f . g)"
+ (tprint exp 15 "ISO-8859-1"))
- (pass-if (equal? (tprint exp 18 "ISO-8859-1")
- "(a b #(c ...) . #)"))
+ (pass-if-equal "(a b #(c ...) . #)"
+ (tprint exp 18 "ISO-8859-1"))
- (pass-if (equal? (tprint exp 20 "ISO-8859-1")
- "(a b #(c d e) f . g)"))
+ (pass-if-equal "(a b #(c d e) f . g)"
+ (tprint exp 20 "ISO-8859-1"))
- (pass-if (equal? (tprint "The quick brown fox" 20 "ISO-8859-1")
- "\"The quick brown...\""))
+ (pass-if-equal "\"The quick brown...\""
+ (tprint "The quick brown fox" 20 "ISO-8859-1"))
- (pass-if (equal? (tprint "The quick brown fox" 20 "UTF-8")
- "\"The quick brown f…\""))
+ (pass-if-equal "\"The quick brown f…\""
+ (tprint "The quick brown fox" 20 "UTF-8"))
- (pass-if (equal? (tprint (current-module) 20 "ISO-8859-1")
- "#<directory (tes...>"))
+ (pass-if-equal "#<directory (tes...>"
+ (tprint (current-module) 20 "ISO-8859-1"))
- (pass-if (equal? (tprint (current-module) 20 "UTF-8")
- "#<directory (test-…>")))
+ (pass-if-equal "#<directory (test-…>"
+ (tprint (current-module) 20 "UTF-8")))
diff --git a/test-suite/tests/procprop.test b/test-suite/tests/procprop.test
index ceb6e562b..eee54e61e 100644
--- a/test-suite/tests/procprop.test
+++ b/test-suite/tests/procprop.test
@@ -1,7 +1,7 @@
;;;; procprop.test --- Procedure properties -*- mode: scheme; coding: utf-8; -*-
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -49,7 +49,7 @@
(pass-if "apply"
(equal? (procedure-minimum-arity apply)
- '(1 0 #t)))
+ '(2 0 #t)))
(pass-if "cons*"
(equal? (procedure-minimum-arity cons*)
@@ -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-ports.test b/test-suite/tests/r6rs-ports.test
index 213c8b7b1..339679f08 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -1,6 +1,7 @@
;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013,
+;;;; 2014 Free Software Foundation, Inc.
;;;; Ludovic Courtès
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -98,8 +99,7 @@
(eof-object? (get-u8 port)))))
(pass-if "lookahead-u8 non-ASCII"
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "λ"))))
+ (let ((port (open-input-string "λ")))
(and (= 206 (lookahead-u8 port))
(= 206 (lookahead-u8 port))
(= 206 (get-u8 port))
@@ -272,21 +272,21 @@
(let* ((str "hello, world")
(bv (string->utf16 str)))
(equal? str
- (with-fluids ((%default-port-encoding "UTF-16BE"))
- (call-with-output-string
- (lambda (port)
- (put-bytevector port bv)))))))
+ (call-with-output-string
+ (lambda (port)
+ (set-port-encoding! port "UTF-16BE")
+ (put-bytevector port bv))))))
(pass-if "put-bytevector with wrong-encoding string port"
(let* ((str "hello, world")
(bv (string->utf16 str)))
(catch 'decoding-error
(lambda ()
- (with-fluids ((%default-port-encoding "UTF-32")
- (%default-port-conversion-strategy 'error))
+ (with-fluids ((%default-port-conversion-strategy 'error))
(call-with-output-string
- (lambda (port)
- (put-bytevector port bv)))
+ (lambda (port)
+ (set-port-encoding! port "UTF-32")
+ (put-bytevector port bv)))
#f)) ; fail if we reach this point
(lambda (key subr message errno port)
(string? (strerror errno)))))))
@@ -810,9 +810,6 @@ not `set-port-position!'"
(put-string tp "The letter λ cannot be represented in Latin-1.")
#f))))
- (pass-if "port-transcoder [binary port]"
- (not (port-transcoder (open-bytevector-input-port #vu8()))))
-
(pass-if "port-transcoder [transcoded port]"
(let* ((p (transcoded-port (open-bytevector-input-port (string->utf8 "foo"))
(make-transcoder (utf-8-codec))))
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/ramap.test b/test-suite/tests/ramap.test
index 7c3142dbd..00de626a4 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -34,10 +34,22 @@
(with-test-prefix "array-index-map!"
(pass-if (let ((nlst '()))
- (array-index-map! (make-array #f '(1 1))
- (lambda (n)
- (set! nlst (cons n nlst))))
- (equal? nlst '(1)))))
+ (array-index-map! (make-array #f '(1 1))
+ (lambda (n)
+ (set! nlst (cons n nlst))))
+ (equal? nlst '(1)))))
+
+;;;
+;;; array-copy!
+;;;
+
+(with-test-prefix "array-copy!"
+
+ (pass-if "empty arrays"
+ (let* ((b (make-array 0 2 2))
+ (c (make-shared-array b (lambda (i j) (list i j)) 0 2)))
+ (array-copy! #2:0:2() c)
+ (array-equal? #2:0:2() c))))
;;;
;;; array-map!
@@ -94,7 +106,7 @@
(pass-if-exception "closure 0" exception:wrong-num-args
(array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5)))
+ (make-array #f 5)))
(pass-if "closure 1"
(let ((a (make-array #f 5)))
@@ -103,16 +115,16 @@
(pass-if-exception "closure 2" exception:wrong-num-args
(array-map! (make-array #f 5) (lambda (x y) #f)
- (make-array #f 5)))
+ (make-array #f 5)))
(pass-if "subr_1"
(let ((a (make-array #f 5)))
- (array-map! a length (make-array '(x y z) 5))
- (equal? a (make-array 3 5))))
+ (array-map! a length (make-array '(x y z) 5))
+ (equal? a (make-array 3 5))))
(pass-if-exception "subr_2" exception:wrong-num-args
(array-map! (make-array #f 5) logtest
- (make-array 999 5)))
+ (make-array 999 5)))
(pass-if "subr_2o"
(let ((a (make-array #f 5)))
@@ -144,17 +156,17 @@
(pass-if-exception "closure 0" exception:wrong-num-args
(array-map! (make-array #f 5) (lambda () #f)
- (make-array #f 5) (make-array #f 5)))
+ (make-array #f 5) (make-array #f 5)))
(pass-if-exception "closure 1" exception:wrong-num-args
(array-map! (make-array #f 5) (lambda (x) #f)
- (make-array #f 5) (make-array #f 5)))
+ (make-array #f 5) (make-array #f 5)))
(pass-if "closure 2"
(let ((a (make-array #f 5)))
- (array-map! a (lambda (x y) 'foo)
- (make-array #f 5) (make-array #f 5))
- (equal? a (make-array 'foo 5))))
+ (array-map! a (lambda (x y) 'foo)
+ (make-array #f 5) (make-array #f 5))
+ (equal? a (make-array 'foo 5))))
(pass-if-exception "subr_1" exception:wrong-num-args
(array-map! (make-array #f 5) length
@@ -192,31 +204,31 @@
(let ((a (make-array #f 4)))
(array-map! a + #(1 2 3 4) #(5 6 7 8))
(equal? a #(6 8 10 12))))
-
+
(pass-if "noncompact arrays 1"
(let ((a #2((0 1) (2 3)))
- (c #(0 0)))
+ (c (make-array 0 2)))
(begin
(array-map! c + (array-row a 1) (array-row a 1))
(array-equal? c #(4 6)))))
-
+
(pass-if "noncompact arrays 2"
(let ((a #2((0 1) (2 3)))
- (c #(0 0)))
+ (c (make-array 0 2)))
(begin
(array-map! c + (array-col a 1) (array-col a 1))
(array-equal? c #(2 6)))))
-
+
(pass-if "noncompact arrays 3"
(let ((a #2((0 1) (2 3)))
- (c #(0 0)))
+ (c (make-array 0 2)))
(begin
(array-map! c + (array-col a 1) (array-row a 1))
(array-equal? c #(3 6)))))
-
+
(pass-if "noncompact arrays 4"
(let ((a #2((0 1) (2 3)))
- (c #(0 0)))
+ (c (make-array 0 2)))
(begin
(array-map! c + (array-col a 1) (array-row a 1))
(array-equal? c #(3 6)))))))
diff --git a/test-suite/tests/rdelim.test b/test-suite/tests/rdelim.test
index 5cfe6460d..437a0ee40 100644
--- a/test-suite/tests/rdelim.test
+++ b/test-suite/tests/rdelim.test
@@ -22,227 +22,225 @@
#:use-module ((rnrs io ports) #:select (open-bytevector-input-port))
#:use-module (test-suite lib))
-(with-fluids ((%default-port-encoding "UTF-8"))
-
- (with-test-prefix "read-line"
-
- (pass-if "one line"
- (let* ((s "hello, world")
- (p (open-input-string s)))
- (and (string=? s (read-line p))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, trim"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? (string-tokenize s)
- (list (read-line p) (read-line p)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, concat"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '("foo\n" "bar\n")
- (list (read-line p 'concat)
- (read-line p 'concat)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, peek"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '("foo" #\newline "bar" #\newline)
- (list (read-line p 'peek) (read-char p)
- (read-line p 'peek) (read-char p)))
- (eof-object? (read-line p)))))
-
- (pass-if "two lines, split"
- (let* ((s "foo\nbar\n")
- (p (open-input-string s)))
- (and (equal? '(("foo" . #\newline)
- ("bar" . #\newline))
- (list (read-line p 'split)
- (read-line p 'split)))
- (eof-object? (read-line p)))))
-
- (pass-if "two Greek lines, trim"
- (let* ((s "λαμβδα\nμυ\n")
- (p (open-input-string s)))
- (and (equal? (string-tokenize s)
- (list (read-line p) (read-line p)))
- (eof-object? (read-line p)))))
-
- (pass-if "decoding error"
- (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'error)
- (catch 'decoding-error
- (lambda ()
- (read-line p)
- #f)
- (lambda (key subr message err port)
- (and (eq? port p)
-
- ;; PORT should now point past the error.
- (string=? (read-line p) "BCD")
- (eof-object? (read-line p)))))))
-
- (pass-if "decoding error, substitute"
- (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
- (set-port-encoding! p "UTF-8")
- (set-port-conversion-strategy! p 'substitute)
- (and (string=? (read-line p) "A?BCD")
- (eof-object? (read-line p))))))
+(with-test-prefix "read-line"
+
+ (pass-if "one line"
+ (let* ((s "hello, world")
+ (p (open-input-string s)))
+ (and (string=? s (read-line p))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, trim"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? (string-tokenize s)
+ (list (read-line p) (read-line p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, concat"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '("foo\n" "bar\n")
+ (list (read-line p 'concat)
+ (read-line p 'concat)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, peek"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '("foo" #\newline "bar" #\newline)
+ (list (read-line p 'peek) (read-char p)
+ (read-line p 'peek) (read-char p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two lines, split"
+ (let* ((s "foo\nbar\n")
+ (p (open-input-string s)))
+ (and (equal? '(("foo" . #\newline)
+ ("bar" . #\newline))
+ (list (read-line p 'split)
+ (read-line p 'split)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "two Greek lines, trim"
+ (let* ((s "λαμβδα\nμυ\n")
+ (p (open-input-string s)))
+ (and (equal? (string-tokenize s)
+ (list (read-line p) (read-line p)))
+ (eof-object? (read-line p)))))
+
+ (pass-if "decoding error"
+ (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
+ (set-port-encoding! p "UTF-8")
+ (set-port-conversion-strategy! p 'error)
+ (catch 'decoding-error
+ (lambda ()
+ (read-line p)
+ #f)
+ (lambda (key subr message err port)
+ (and (eq? port p)
+
+ ;; PORT should now point past the error.
+ (string=? (read-line p) "BCD")
+ (eof-object? (read-line p)))))))
+
+ (pass-if "decoding error, substitute"
+ (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68))))
+ (set-port-encoding! p "UTF-8")
+ (set-port-conversion-strategy! p 'substitute)
+ (and (string=? (read-line p) "A?BCD")
+ (eof-object? (read-line p))))))
- (with-test-prefix "read-delimited"
+(with-test-prefix "read-delimited"
- (pass-if "delimiter hit"
- (let ((p (open-input-string "hello, world!")))
- (and (string=? "hello" (read-delimited ",.;" p))
- (string=? " world!" (read-delimited ",.;" p))
- (eof-object? (read-delimited ",.;" p)))))
+ (pass-if "delimiter hit"
+ (let ((p (open-input-string "hello, world!")))
+ (and (string=? "hello" (read-delimited ",.;" p))
+ (string=? " world!" (read-delimited ",.;" p))
+ (eof-object? (read-delimited ",.;" p)))))
- (pass-if "delimiter hit, split"
- (equal? '("hello" . #\,)
- (read-delimited ",.;"
- (open-input-string "hello, world!")
- 'split)))
+ (pass-if "delimiter hit, split"
+ (equal? '("hello" . #\,)
+ (read-delimited ",.;"
+ (open-input-string "hello, world!")
+ 'split)))
- (pass-if "delimiter hit, concat"
- (equal? '"hello,"
- (read-delimited ",.;" (open-input-string "hello, world!")
- 'concat)))
+ (pass-if "delimiter hit, concat"
+ (equal? '"hello,"
+ (read-delimited ",.;" (open-input-string "hello, world!")
+ 'concat)))
- (pass-if "delimiter hit, peek"
- (let ((p (open-input-string "hello, world!")))
- (and (string=? "hello" (read-delimited ",.;" p 'peek))
- (char=? #\, (peek-char p)))))
+ (pass-if "delimiter hit, peek"
+ (let ((p (open-input-string "hello, world!")))
+ (and (string=? "hello" (read-delimited ",.;" p 'peek))
+ (char=? #\, (peek-char p)))))
- (pass-if "eof"
- (eof-object? (read-delimited "}{" (open-input-string "")))))
+ (pass-if "eof"
+ (eof-object? (read-delimited "}{" (open-input-string "")))))
- (with-test-prefix "read-delimited!"
-
- (pass-if "delimiter hit"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p))
- (string=? (substring s 0 5) "hello")
- (= 7 (read-delimited! ",.;" s p))
- (string=? (substring s 0 7) " world!")
- (eof-object? (read-delimited! ",.;" s p)))))
-
- (pass-if "delimiter hit, start+end"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p 'trim 10 30))
- (string=? (substring s 10 15) "hello"))))
-
- (pass-if "delimiter hit, split"
- (let ((s (make-string 123)))
- (and (equal? '(5 . #\,)
- (read-delimited! ",.;" s
- (open-input-string "hello, world!")
- 'split))
- (string=? (substring s 0 5) "hello"))))
-
- (pass-if "delimiter hit, concat"
- (let ((s (make-string 123)))
- (and (= 6 (read-delimited! ",.;" s
- (open-input-string "hello, world!")
- 'concat))
- (string=? (substring s 0 6) "hello,"))))
-
- (pass-if "delimiter hit, peek"
- (let ((s (make-string 123))
- (p (open-input-string "hello, world!")))
- (and (= 5 (read-delimited! ",.;" s p 'peek))
- (string=? (substring s 0 5) "hello")
- (char=? #\, (peek-char p)))))
-
- (pass-if "string too small"
- (let ((s (make-string 7)))
- (and (= 7 (read-delimited! "}{" s
- (open-input-string "hello, world!")))
- (string=? s "hello, "))))
-
- (pass-if "string too small, start+end"
- (let ((s (make-string 123)))
- (and (= 7 (read-delimited! "}{" s
- (open-input-string "hello, world!")
- 'trim
- 70 77))
- (string=? (substring s 70 77) "hello, "))))
-
- (pass-if "string too small, split"
- (let ((s (make-string 7)))
- (and (equal? '(7 . #f)
- (read-delimited! "}{" s
- (open-input-string "hello, world!")
- 'split))
- (string=? s "hello, "))))
-
- (pass-if "eof"
- (eof-object? (read-delimited! ":" (make-string 7)
- (open-input-string ""))))
-
- (pass-if "eof, split"
- (eof-object? (read-delimited! ":" (make-string 7)
- (open-input-string "")))))
-
- (with-test-prefix "read-string"
-
- (pass-if "short string"
- (let* ((s "hello, world!")
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if "100 chars"
- (let* ((s (make-string 100 #\space))
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) ""))))
-
- (pass-if "longer than 100 chars"
- (let* ((s (string-concatenate (make-list 20 "hello, world!")))
- (p (open-input-string s)))
- (and (string=? (read-string p) s)
- (string=? (read-string p) "")))))
-
- (with-test-prefix "read-string!"
-
- (pass-if "buf smaller"
- (let* ((s "hello, world!")
- (len (1- (string-length s)))
- (buf (make-string len #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? buf (substring s 0 len))
- (= (read-string! buf p) 1)
- (string=? (substring buf 0 1) (substring s len)))))
-
- (pass-if "buf right size"
- (let* ((s "hello, world!")
- (len (string-length s))
- (buf (make-string len #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? buf (substring s 0 len))
- (= (read-string! buf p) 0)
- (string=? buf (substring s 0 len)))))
-
- (pass-if "buf bigger"
- (let* ((s "hello, world!")
- (len (string-length s))
- (buf (make-string (1+ len) #\.))
- (p (open-input-string s)))
- (and (= (read-string! buf p) len)
- (string=? (substring buf 0 len) s)
- (= (read-string! buf p) 0)
- (string=? (substring buf 0 len) s)
- (string=? (substring buf len) "."))))))
+(with-test-prefix "read-delimited!"
+
+ (pass-if "delimiter hit"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p))
+ (string=? (substring s 0 5) "hello")
+ (= 7 (read-delimited! ",.;" s p))
+ (string=? (substring s 0 7) " world!")
+ (eof-object? (read-delimited! ",.;" s p)))))
+
+ (pass-if "delimiter hit, start+end"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p 'trim 10 30))
+ (string=? (substring s 10 15) "hello"))))
+
+ (pass-if "delimiter hit, split"
+ (let ((s (make-string 123)))
+ (and (equal? '(5 . #\,)
+ (read-delimited! ",.;" s
+ (open-input-string "hello, world!")
+ 'split))
+ (string=? (substring s 0 5) "hello"))))
+
+ (pass-if "delimiter hit, concat"
+ (let ((s (make-string 123)))
+ (and (= 6 (read-delimited! ",.;" s
+ (open-input-string "hello, world!")
+ 'concat))
+ (string=? (substring s 0 6) "hello,"))))
+
+ (pass-if "delimiter hit, peek"
+ (let ((s (make-string 123))
+ (p (open-input-string "hello, world!")))
+ (and (= 5 (read-delimited! ",.;" s p 'peek))
+ (string=? (substring s 0 5) "hello")
+ (char=? #\, (peek-char p)))))
+
+ (pass-if "string too small"
+ (let ((s (make-string 7)))
+ (and (= 7 (read-delimited! "}{" s
+ (open-input-string "hello, world!")))
+ (string=? s "hello, "))))
+
+ (pass-if "string too small, start+end"
+ (let ((s (make-string 123)))
+ (and (= 7 (read-delimited! "}{" s
+ (open-input-string "hello, world!")
+ 'trim
+ 70 77))
+ (string=? (substring s 70 77) "hello, "))))
+
+ (pass-if "string too small, split"
+ (let ((s (make-string 7)))
+ (and (equal? '(7 . #f)
+ (read-delimited! "}{" s
+ (open-input-string "hello, world!")
+ 'split))
+ (string=? s "hello, "))))
+
+ (pass-if "eof"
+ (eof-object? (read-delimited! ":" (make-string 7)
+ (open-input-string ""))))
+
+ (pass-if "eof, split"
+ (eof-object? (read-delimited! ":" (make-string 7)
+ (open-input-string "")))))
+
+(with-test-prefix "read-string"
+
+ (pass-if "short string"
+ (let* ((s "hello, world!")
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) ""))))
+
+ (pass-if "100 chars"
+ (let* ((s (make-string 100 #\space))
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) ""))))
+
+ (pass-if "longer than 100 chars"
+ (let* ((s (string-concatenate (make-list 20 "hello, world!")))
+ (p (open-input-string s)))
+ (and (string=? (read-string p) s)
+ (string=? (read-string p) "")))))
+
+(with-test-prefix "read-string!"
+
+ (pass-if "buf smaller"
+ (let* ((s "hello, world!")
+ (len (1- (string-length s)))
+ (buf (make-string len #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? buf (substring s 0 len))
+ (= (read-string! buf p) 1)
+ (string=? (substring buf 0 1) (substring s len)))))
+
+ (pass-if "buf right size"
+ (let* ((s "hello, world!")
+ (len (string-length s))
+ (buf (make-string len #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? buf (substring s 0 len))
+ (= (read-string! buf p) 0)
+ (string=? buf (substring s 0 len)))))
+
+ (pass-if "buf bigger"
+ (let* ((s "hello, world!")
+ (len (string-length s))
+ (buf (make-string (1+ len) #\.))
+ (p (open-input-string s)))
+ (and (= (read-string! buf p) len)
+ (string=? (substring buf 0 len) s)
+ (= (read-string! buf p) 0)
+ (string=? (substring buf 0 len) s)
+ (string=? (substring buf len) ".")))))
;;; Local Variables:
;;; eval: (put 'with-test-prefix 'scheme-indent-function 1)
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 18c0293b8..d9cb1c883 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -1,7 +1,7 @@
;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*-
;;;;
;;;; Copyright (C) 1999, 2001, 2002, 2003, 2007, 2008, 2009, 2010, 2011,
-;;;; 2014 Free Software Foundation, Inc.
+;;;; 2013, 2014 Free Software Foundation, Inc.
;;;; Jim Blandy <jimb@red-bean.com>
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -48,8 +48,7 @@
(define (read-string s)
- (with-fluids ((%default-port-encoding #f))
- (with-input-from-string s (lambda () (read)))))
+ (with-input-from-string s (lambda () (read))))
(define (with-read-options opts thunk)
(let ((saved-options (read-options)))
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index b5c59f030..d25a3d42d 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -153,13 +153,7 @@
(with-latin1-locale body ...)
(begin body ...)))))
-;; 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
- (syntax-rules ()
- ((_ exp)
- (with-fluids ((%default-port-encoding "UTF-8"))
- exp))))
+(define char-code-limit 256)
(with-test-prefix "regexp-quote"
@@ -189,7 +183,7 @@
(s (string c)))
(pass-if (list "char" i (format #f "~s ~s" c s))
(with-ascii-or-latin1-locale i
- (let* ((q (with-unicode (regexp-quote s)))
+ (let* ((q (regexp-quote s))
(m (regexp-exec (make-regexp q flag) s)))
(and (= 0 (match:start m))
(= 1 (match:end m))))))))
@@ -202,7 +196,7 @@
((>= i 256))
(let* ((c (integer->char i))
(s (string #\a c))
- (q (with-unicode (regexp-quote s))))
+ (q (regexp-quote s)))
(pass-if (list "string \"aX\"" i (format #f "~s ~s ~s" c s q))
(with-ascii-or-latin1-locale i
(let* ((m (regexp-exec (make-regexp q flag) s)))
@@ -211,9 +205,9 @@
(pass-if "string of all chars"
(with-latin1-locale
- (let ((m (regexp-exec (make-regexp (with-unicode
- (regexp-quote allchars))
- flag) allchars)))
+ (let ((m (regexp-exec (make-regexp (regexp-quote allchars)
+ flag)
+ allchars)))
(and (= 0 (match:start m))
(= (string-length allchars) (match:end m)))))))))
lst)))
diff --git a/test-suite/tests/rtl-compilation.test b/test-suite/tests/rtl-compilation.test
new file mode 100644
index 000000000..a9eaa0cf9
--- /dev/null
+++ b/test-suite/tests/rtl-compilation.test
@@ -0,0 +1,220 @@
+;;;; rtl-compilation.test --- test suite for compiling via bytecode -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite bytecode-compilation)
+ #:use-module (test-suite lib)
+ #:use-module (system base compile)
+ #:use-module (system vm loader))
+
+(define* (compile-via-bytecode exp #:key peval? cse? (env (make-fresh-user-module)))
+ (load-thunk-from-memory
+ (compile exp #:env env #:to 'bytecode
+ #:opts `(#:partial-eval? ,peval? #:cse? ,cse?))))
+
+(define* (run-bytecode exp #:key (env (make-fresh-user-module)))
+ (let ((thunk (compile-via-bytecode exp #:env env)))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module env)
+ (thunk)))))
+
+(with-test-prefix "tail context"
+ (pass-if-equal 1
+ (run-bytecode '(let ((x 1)) x)))
+
+ (pass-if-equal 1
+ (run-bytecode 1))
+
+ (pass-if-equal (if #f #f)
+ (run-bytecode '(if #f #f)))
+
+ (pass-if-equal "top-level define"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (let ((result (run-bytecode '(define v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level set!"
+ (list (if #f #f) 1)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'v #f)
+ (let ((result (run-bytecode '(set! v 1) #:env mod)))
+ (list result (module-ref mod 'v)))))
+
+ (pass-if-equal "top-level apply [single value]"
+ 8
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'args '(2 3))
+ (run-bytecode '(apply expt args) #:env mod)))
+
+ (pass-if-equal "top-level apply [zero values]"
+ '()
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda () (values)))
+ (module-define! mod 'args '())
+ (call-with-values
+ (lambda () (run-bytecode '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "top-level apply [two values]"
+ '(1 2)
+ (let ((mod (make-fresh-user-module)))
+ (module-define! mod 'proc (lambda (n d) (floor/ n d)))
+ (module-define! mod 'args '(5 3))
+ (call-with-values
+ (lambda () (run-bytecode '(apply proc args) #:env mod))
+ list)))
+
+ (pass-if-equal "call-with-values"
+ '(1 2 3)
+ ((run-bytecode '(lambda (n d)
+ (call-with-values (lambda () (floor/ n d))
+ (lambda (q r) (list q r (+ q r))))))
+ 5 3))
+
+ (pass-if-equal cons
+ (run-bytecode 'cons))
+
+ (pass-if-equal 1
+ ((run-bytecode '(lambda () 1))))
+
+ (pass-if-equal 1
+ ((run-bytecode '(lambda (x) 1)) 2))
+
+ (pass-if-equal 1
+ ((run-bytecode '(lambda (x) x)) 1))
+
+ (pass-if-equal 6
+ ((((run-bytecode '(lambda (x)
+ (lambda (y)
+ (lambda (z)
+ (+ x y z))))) 1) 2) 3))
+
+ (pass-if-equal 1
+ (run-bytecode '(identity 1)))
+
+ (pass-if-equal '(1 . 2)
+ (run-bytecode '(cons 1 2)))
+
+ (pass-if-equal '(1 2)
+ (call-with-values (lambda () (run-bytecode '(values 1 2))) list))
+
+ (pass-if-equal 28
+ ((run-bytecode '(lambda (x y z rest) (apply + x y z rest)))
+ 2 3 5 '(7 11)))
+
+ ;; prompts
+ )
+
+(with-test-prefix "value context"
+ 1
+ )
+
+(with-test-prefix "drop context"
+ 1
+ )
+
+(with-test-prefix "test context"
+ 1
+ )
+
+(with-test-prefix "values context"
+ (pass-if-equal '(3 . 1)
+ (run-bytecode
+ '(let ((rat (lambda (n d)
+ (call-with-values
+ (lambda () (floor/ n d))
+ (lambda (q r)
+ (cons q r))))))
+ (rat 10 3)))))
+
+(with-test-prefix "contification"
+ (pass-if ((run-bytecode '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3 4)))
+
+ (pass-if (not ((run-bytecode '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (even? x)))
+ '(1 2 3))))
+
+ (pass-if-equal '(#t)
+ ((run-bytecode '(lambda (x)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (list (even? x))))
+ '(1 2 3 4)))
+
+ ;; An irreducible loop between even? and odd?.
+ (pass-if-equal '#t
+ ((run-bytecode '(lambda (x do-even?)
+ (define (even? x)
+ (if (null? x) #t (odd? (cdr x))))
+ (define (odd? x)
+ (if (null? x) #f (even? (cdr x))))
+ (if do-even? (even? x) (odd? x))))
+ '(1 2 3 4)
+ #t)))
+
+(with-test-prefix "case-lambda"
+ (pass-if-equal "simple"
+ '(0 3 9 28)
+ (let ((proc (run-bytecode '(case-lambda
+ (() 0)
+ ((x) x)
+ ((x y) (+ x y))
+ ((x y z . rest) (apply + x y z rest))))))
+ (map (lambda (args) (apply proc args))
+ '(() (3) (2 7) (2 3 5 7 11)))))
+
+ (pass-if-exception "no match"
+ exception:wrong-num-args
+ ((run-bytecode '(case-lambda ((x) x) ((x y) (+ x y))))
+ 1 2 3))
+
+ (pass-if-exception "zero clauses called with no args"
+ exception:wrong-num-args
+ ((run-bytecode '(case-lambda))))
+
+ (pass-if-exception "zero clauses called with args"
+ exception:wrong-num-args
+ ((run-bytecode '(case-lambda)) 1)))
+
+(with-test-prefix "mixed contexts"
+ (pass-if-equal "sequences" '(3 4 5)
+ (let* ((pair (cons 1 2))
+ (result ((run-bytecode '(lambda (pair)
+ (set-car! pair 3)
+ (set-cdr! pair 4)
+ 5))
+ pair)))
+ (list (car pair)
+ (cdr pair)
+ result)))
+
+ (pass-if-equal "mutable lexicals" 2
+ (run-bytecode '(let ((n 1)) (set! n 2) n))))
diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test
new file mode 100644
index 000000000..2ee418a17
--- /dev/null
+++ b/test-suite/tests/rtl.test
@@ -0,0 +1,436 @@
+;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (tests bytecode)
+ #:use-module (test-suite lib)
+ #:use-module (system vm assembler)
+ #:use-module (system vm program)
+ #:use-module (system vm loader)
+ #:use-module (system vm linker)
+ #:use-module (system vm debug))
+
+(define (assemble-program instructions)
+ "Take the sequence of instructions @var{instructions}, assemble them
+into bytecode, link an image, and load that image from memory. Returns
+a procedure."
+ (let ((asm (make-assembler)))
+ (emit-text asm instructions)
+ (load-thunk-from-memory (link-assembly asm #:page-aligned? #f))))
+
+(define-syntax-rule (assert-equal val expr)
+ (let ((x val))
+ (pass-if (object->string x) (equal? expr x))))
+
+(define (return-constant val)
+ (assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 ,val)
+ (return 1)
+ (end-arity)
+ (end-program))))
+
+(define-syntax-rule (assert-constants val ...)
+ (begin
+ (assert-equal val ((return-constant val)))
+ ...))
+
+(with-test-prefix "load-constant"
+ (assert-constants
+ 1
+ -1
+ 0
+ most-positive-fixnum
+ most-negative-fixnum
+ #t
+ #\c
+ (integer->char 16000)
+ 3.14
+ "foo"
+ 'foo
+ #:foo
+ "æ" ;; a non-ASCII Latin-1 string
+ "λ" ;; non-ascii, non-latin-1
+ '(1 . 2)
+ '(1 2 3 4)
+ #(1 2 3)
+ #("foo" "bar" 'baz)
+ #vu8()
+ #vu8(1 2 3 4 128 129 130)
+ #u32()
+ #u32(1 2 3 4 128 129 130 255 1000)
+ ;; FIXME: Add more tests for arrays (uniform and otherwise)
+ ))
+
+(with-test-prefix "static procedure"
+ (assert-equal 42
+ (((assemble-program `((begin-program foo
+ ((name . foo)))
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 bar)
+ (return 1)
+ (end-arity)
+ (end-program)
+ (begin-program bar
+ ((name . bar)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))))
+
+(with-test-prefix "loop"
+ (assert-equal (* 999 500)
+ (let ((sumto
+ (assemble-program
+ ;; 0: limit
+ ;; 1: n
+ ;; 2: accum
+ '((begin-program countdown
+ ((name . countdown)))
+ (begin-standard-arity (x) 4 #f)
+ (br fix-body)
+ (label loop-head)
+ (br-if-= 2 1 #f out)
+ (add 3 2 3)
+ (add1 2 2)
+ (br loop-head)
+ (label fix-body)
+ (load-constant 2 0)
+ (load-constant 3 0)
+ (br loop-head)
+ (label out)
+ (return 3)
+ (end-arity)
+ (end-program)))))
+ (sumto 1000))))
+
+(with-test-prefix "accum"
+ (assert-equal (+ 1 2 3)
+ (let ((make-accum
+ (assemble-program
+ ;; 0: elt
+ ;; 1: tail
+ ;; 2: head
+ '((begin-program make-accum
+ ((name . make-accum)))
+ (begin-standard-arity () 3 #f)
+ (load-constant 1 0)
+ (box 1 1)
+ (make-closure 2 accum 1)
+ (free-set! 2 1 0)
+ (return 2)
+ (end-arity)
+ (end-program)
+ (begin-program accum
+ ((name . accum)))
+ (begin-standard-arity (x) 4 #f)
+ (free-ref 2 0 0)
+ (box-ref 3 2)
+ (add 3 3 1)
+ (box-set! 2 3)
+ (return 3)
+ (end-arity)
+ (end-program)))))
+ (let ((accum (make-accum)))
+ (accum 1)
+ (accum 2)
+ (accum 3)))))
+
+(with-test-prefix "call"
+ (assert-equal 42
+ (let ((call ;; (lambda (x) (x))
+ (assemble-program
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 7 #f)
+ (mov 5 1)
+ (call 5 1)
+ (receive 2 5 7)
+ (return 2)
+ (end-arity)
+ (end-program)))))
+ (call (lambda () 42))))
+
+ (assert-equal 6
+ (let ((call-with-3 ;; (lambda (x) (x 3))
+ (assemble-program
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 7 #f)
+ (mov 5 1)
+ (load-constant 6 3)
+ (call 5 2)
+ (receive 2 5 7)
+ (return 2)
+ (end-arity)
+ (end-program)))))
+ (call-with-3 (lambda (x) (* x 2))))))
+
+(with-test-prefix "tail-call"
+ (assert-equal 3
+ (let ((call ;; (lambda (x) (x))
+ (assemble-program
+ '((begin-program call
+ ((name . call)))
+ (begin-standard-arity (f) 2 #f)
+ (mov 0 1)
+ (tail-call 1)
+ (end-arity)
+ (end-program)))))
+ (call (lambda () 3))))
+
+ (assert-equal 6
+ (let ((call-with-3 ;; (lambda (x) (x 3))
+ (assemble-program
+ '((begin-program call-with-3
+ ((name . call-with-3)))
+ (begin-standard-arity (f) 2 #f)
+ (mov 0 1) ;; R0 <- R1
+ (load-constant 1 3) ;; R1 <- 3
+ (tail-call 2)
+ (end-arity)
+ (end-program)))))
+ (call-with-3 (lambda (x) (* x 2))))))
+
+(with-test-prefix "cached-toplevel-ref"
+ (assert-equal 5.0
+ (let ((get-sqrt-trampoline
+ (assemble-program
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 2 #f)
+ (current-module 1)
+ (cache-current-module! 1 sqrt-scope)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
+ (end-arity)
+ (end-program)
+
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 3 #f)
+ (cached-toplevel-box 2 sqrt-scope sqrt #t)
+ (box-ref 0 2)
+ (tail-call 2)
+ (end-arity)
+ (end-program)))))
+ ((get-sqrt-trampoline) 25.0))))
+
+(define *top-val* 0)
+
+(with-test-prefix "cached-toplevel-set!"
+ (let ((prev *top-val*))
+ (assert-equal (1+ prev)
+ (let ((make-top-incrementor
+ (assemble-program
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 2 #f)
+ (current-module 1)
+ (cache-current-module! 1 top-incrementor)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
+ (end-arity)
+ (end-program)
+
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 3 #f)
+ (cached-toplevel-box 1 top-incrementor *top-val* #t)
+ (box-ref 2 1)
+ (add1 2 2)
+ (box-set! 1 2)
+ (reset-frame 1)
+ (return-values)
+ (end-arity)
+ (end-program)))))
+ ((make-top-incrementor))
+ *top-val*))))
+
+(with-test-prefix "cached-module-ref"
+ (assert-equal 5.0
+ (let ((get-sqrt-trampoline
+ (assemble-program
+ '((begin-program get-sqrt-trampoline
+ ((name . get-sqrt-trampoline)))
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 sqrt-trampoline)
+ (return 1)
+ (end-arity)
+ (end-program)
+
+ (begin-program sqrt-trampoline
+ ((name . sqrt-trampoline)))
+ (begin-standard-arity (x) 3 #f)
+ (cached-module-box 2 (guile) sqrt #t #t)
+ (box-ref 0 2)
+ (tail-call 2)
+ (end-arity)
+ (end-program)))))
+ ((get-sqrt-trampoline) 25.0))))
+
+(with-test-prefix "cached-module-set!"
+ (let ((prev *top-val*))
+ (assert-equal (1+ prev)
+ (let ((make-top-incrementor
+ (assemble-program
+ '((begin-program make-top-incrementor
+ ((name . make-top-incrementor)))
+ (begin-standard-arity () 2 #f)
+ (load-static-procedure 1 top-incrementor)
+ (return 1)
+ (end-arity)
+ (end-program)
+
+ (begin-program top-incrementor
+ ((name . top-incrementor)))
+ (begin-standard-arity () 3 #f)
+ (cached-module-box 1 (tests bytecode) *top-val* #f #t)
+ (box-ref 2 1)
+ (add1 2 2)
+ (box-set! 1 2)
+ (return 2)
+ (end-arity)
+ (end-program)))))
+ ((make-top-incrementor))
+ *top-val*))))
+
+(with-test-prefix "debug contexts"
+ (let ((return-3 (assemble-program
+ '((begin-program return-3 ((name . return-3)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 3)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+ (pass-if "program name"
+ (and=> (find-program-debug-info (program-code return-3))
+ (lambda (pdi)
+ (equal? (program-debug-info-name pdi)
+ 'return-3))))
+
+ (pass-if "program address"
+ (and=> (find-program-debug-info (program-code return-3))
+ (lambda (pdi)
+ (equal? (program-debug-info-addr pdi)
+ (program-code return-3)))))))
+
+(with-test-prefix "procedure name"
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "simply procedure arity"
+ (pass-if-equal "#<procedure foo ()>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+ (pass-if-equal "#<procedure foo (x y)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-standard-arity (x y) 3 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ (pass-if-equal "#<procedure foo (x #:optional y . z)>"
+ (object->string
+ (assemble-program
+ '((begin-program foo ((name . foo)))
+ (begin-opt-arity (x) (y) z 4 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "procedure docstrings"
+ (pass-if-equal "qux qux"
+ (procedure-documentation
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
+
+(with-test-prefix "procedure properties"
+ ;; No properties.
+ (pass-if-equal '()
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ())
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ ;; Name and docstring (which actually don't go out to procprops).
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo) (documentation . "qux qux")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ ;; A property that actually needs serialization.
+ (pass-if-equal '((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo"))
+ (procedure-properties
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program)))))
+
+ ;; Procedure-name still works in this case.
+ (pass-if-equal 'foo
+ (procedure-name
+ (assemble-program
+ '((begin-program foo ((name . foo)
+ (documentation . "qux qux")
+ (moo . "mooooooooooooo")))
+ (begin-standard-arity () 2 #f)
+ (load-constant 1 42)
+ (return 1)
+ (end-arity)
+ (end-program))))))
diff --git a/test-suite/tests/session.test b/test-suite/tests/session.test
index c9aa4a06c..f6fd38951 100644
--- a/test-suite/tests/session.test
+++ b/test-suite/tests/session.test
@@ -77,17 +77,17 @@
(pass-if-valid-arguments "lambda* with keywords"
(lambda* (a b #:key (k 42) l) #f)
((required . (a b)) (optional)
- (keyword . ((#:k . 2) (#:l . 3))) (allow-other-keys? . #f)
+ (keyword . ((#:k . 3) (#:l . 4))) (allow-other-keys? . #f)
(rest . #f)))
(pass-if-valid-arguments "lambda* with keywords and a-o-k"
(lambda* (a b #:key (k 42) #:allow-other-keys) #f)
((required . (a b)) (optional)
- (keyword . ((#:k . 2))) (allow-other-keys? . #t)
+ (keyword . ((#:k . 3))) (allow-other-keys? . #t)
(rest . #f)))
(pass-if-valid-arguments "lambda* with optionals, keys, and rest"
(lambda* (a b #:optional o p #:key k l #:rest r) #f)
((required . (a b)) (optional . (o p))
- (keyword . ((#:k . 5) (#:l . 6))) (allow-other-keys? . #f)
+ (keyword . ((#:k . 6) (#:l . 7))) (allow-other-keys? . #f)
(rest . r)))
(pass-if "aok? is preserved"
diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test
index 99a084bb3..d212bd084 100644
--- a/test-suite/tests/srfi-105.test
+++ b/test-suite/tests/srfi-105.test
@@ -1,6 +1,6 @@
;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*-
;;;;
-;;;; Copyright (C) 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -21,8 +21,7 @@
#:use-module (srfi srfi-1))
(define (read-string s)
- (with-fluids ((%default-port-encoding #f))
- (with-input-from-string s read)))
+ (with-input-from-string s read))
(define (with-read-options opts thunk)
(let ((saved-options (read-options)))
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index 679e17326..56c898c8b 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -2,7 +2,7 @@
;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009, 2010,
-;;;; 2011 Free Software Foundation, Inc.
+;;;; 2011, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -546,10 +546,10 @@
(with-test-prefix "string"
(pass-if-exception "convert circular list to string"
- exception:wrong-type-arg
- (let ((foo (list #\a #\b #\c)))
- (set-cdr! (cddr foo) (cdr foo))
- (apply string foo))))
+ '(wrong-type-arg . "Apply to non-list")
+ (let ((foo (list #\a #\b #\c)))
+ (set-cdr! (cddr foo) (cdr foo))
+ (apply string foo))))
(with-test-prefix "string-split"
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index b1b29227f..15c811cc9 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -22,6 +22,7 @@
(define-module (test-suite test-syncase)
#:use-module (test-suite lib)
#:use-module (system base compile)
+ #:use-module (ice-9 regex)
#:use-module ((srfi srfi-1) :select (member)))
(define-syntax plus
@@ -249,3 +250,60 @@
(parameterize ((current-warning-port (%make-void-port "w")))
(eval '(if #f (baz) #t)
(resolve-module '(test-suite test-syncase-3)))))
+
+(use-modules (system syntax))
+
+(with-test-prefix "syntax-local-binding"
+ (define-syntax syntax-type
+ (lambda (x)
+ (syntax-case x ()
+ ((_ id resolve?)
+ (call-with-values
+ (lambda ()
+ (syntax-local-binding
+ #'id
+ #:resolve-syntax-parameters? (syntax->datum #'resolve?)))
+ (lambda (type value)
+ (with-syntax ((type (datum->syntax #'id type)))
+ #''type)))))))
+
+ (define-syntax-parameter foo
+ (syntax-rules ()))
+
+ (pass-if "syntax-parameters (resolved)"
+ (equal? (syntax-type foo #t) 'macro))
+
+ (pass-if "syntax-parameters (unresolved)"
+ (equal? (syntax-type foo #f) 'syntax-parameter)))
+
+;; (put 'pass-if-syntax-error 'scheme-indent-function 1)
+(define-syntax pass-if-syntax-error
+ (syntax-rules ()
+ ((_ name pat exp)
+ (pass-if name
+ (catch 'syntax-error
+ (lambda () exp (error "expected syntax-error exception"))
+ (lambda (k who what where form . maybe-subform)
+ (if (if (pair? pat)
+ (and (eq? who (car pat))
+ (string-match (cdr pat) what))
+ (string-match pat what))
+ #t
+ (error "unexpected syntax-error exception" what pat))))))))
+
+(with-test-prefix "primitives"
+ (pass-if-syntax-error "primref in default module"
+ "failed to match"
+ (macroexpand '(@@ primitive cons)))
+
+ (pass-if-syntax-error "primcall in default module"
+ "failed to match"
+ (macroexpand '((@@ primitive cons) 1 2)))
+
+ (pass-if-equal "primcall in (guile)"
+ '(1 . 2)
+ (@@ @@ (guile) ((@@ primitive cons) 1 2)))
+
+ (pass-if-syntax-error "primref in (guile)"
+ "not in operator position"
+ (macroexpand '(@@ @@ (guile) (@@ primitive cons)))))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index a1129e9dc..d88e791cc 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -843,7 +843,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 ddc3e7633..c2e6c6591 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -24,47 +24,15 @@
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language glil)
#:use-module (srfi srfi-13))
-;; Of course, the GLIL that is emitted depends on the source info of the
-;; input. Here we're not concerned about that, so we strip source
-;; information from the incoming tree-il.
-
-(define (strip-source x)
- (post-order! (lambda (x) (set! (tree-il-src x) #f))
- x))
-
-(define-syntax assert-tree-il->glil
- (syntax-rules (with-partial-evaluation without-partial-evaluation
- with-options)
- ((_ with-partial-evaluation in pat test ...)
- (assert-tree-il->glil with-options (#:partial-eval? #t)
- in pat test ...))
- ((_ without-partial-evaluation in pat test ...)
- (assert-tree-il->glil with-options (#:partial-eval? #f)
- in pat test ...))
- ((_ with-options opts in pat test ...)
- (let ((exp 'in))
- (pass-if 'in
- (let ((glil (unparse-glil
- (compile (strip-source (parse-tree-il exp))
- #:from 'tree-il #:to 'glil
- #:opts 'opts))))
- (pmatch glil
- (pat (guard test ...) #t)
- (else #f))))))
- ((_ in pat test ...)
- (assert-tree-il->glil with-partial-evaluation
- in pat test ...))))
-
(define-syntax-rule (pass-if-primitives-resolved in expected)
(pass-if (format #f "primitives-resolved in ~s" 'in)
(let* ((module (let ((m (make-module)))
(beautify-user-module! m)
m))
(orig (parse-tree-il 'in))
- (resolved (expand-primitives! (resolve-primitives! orig module))))
+ (resolved (expand-primitives (resolve-primitives orig module))))
(or (equal? (unparse-tree-il resolved) 'expected)
(begin
(format (current-error-port)
@@ -89,62 +57,62 @@
(with-test-prefix "eqv?"
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const #f) (toplevel x))
- (apply (primitive eq?) (const #f) (toplevel x)))
+ (primcall eqv? (toplevel x) (const #f))
+ (primcall eq? (const #f) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const ()) (toplevel x))
- (apply (primitive eq?) (const ()) (toplevel x)))
+ (primcall eqv? (toplevel x) (const ()))
+ (primcall eq? (const ()) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const #t) (lexical x y))
- (apply (primitive eq?) (const #t) (lexical x y)))
+ (primcall eqv? (const #t) (lexical x y))
+ (primcall eq? (const #t) (lexical x y)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x))
- (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+ (primcall eqv? (const this-is-a-symbol) (toplevel x))
+ (primcall eq? (const this-is-a-symbol) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const 42) (toplevel x))
- (apply (primitive eq?) (const 42) (toplevel x)))
+ (primcall eqv? (const 42) (toplevel x))
+ (primcall eq? (const 42) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const 42.0) (toplevel x))
- (apply (primitive eqv?) (const 42.0) (toplevel x)))
+ (primcall eqv? (const 42.0) (toplevel x))
+ (primcall eqv? (const 42.0) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive eqv?) (const #nil) (toplevel x))
- (apply (primitive eq?) (const #nil) (toplevel x))))
+ (primcall eqv? (const #nil) (toplevel x))
+ (primcall eq? (const #nil) (toplevel x))))
(with-test-prefix "equal?"
(pass-if-primitives-resolved
- (apply (primitive equal?) (const #f) (toplevel x))
- (apply (primitive eq?) (const #f) (toplevel x)))
+ (primcall equal? (toplevel x) (const #f))
+ (primcall eq? (const #f) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const ()) (toplevel x))
- (apply (primitive eq?) (const ()) (toplevel x)))
+ (primcall equal? (toplevel x) (const ()))
+ (primcall eq? (const ()) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const #t) (lexical x y))
- (apply (primitive eq?) (const #t) (lexical x y)))
+ (primcall equal? (const #t) (lexical x y))
+ (primcall eq? (const #t) (lexical x y)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const this-is-a-symbol) (toplevel x))
- (apply (primitive eq?) (const this-is-a-symbol) (toplevel x)))
+ (primcall equal? (const this-is-a-symbol) (toplevel x))
+ (primcall eq? (const this-is-a-symbol) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const 42) (toplevel x))
- (apply (primitive eq?) (const 42) (toplevel x)))
+ (primcall equal? (const 42) (toplevel x))
+ (primcall eq? (const 42) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const 42.0) (toplevel x))
- (apply (primitive equal?) (const 42.0) (toplevel x)))
+ (primcall equal? (const 42.0) (toplevel x))
+ (primcall equal? (const 42.0) (toplevel x)))
(pass-if-primitives-resolved
- (apply (primitive equal?) (const #nil) (toplevel x))
- (apply (primitive eq?) (const #nil) (toplevel x)))))
+ (primcall equal? (const #nil) (toplevel x))
+ (primcall eq? (const #nil) (toplevel x)))))
(with-test-prefix "tree-il->scheme"
@@ -153,552 +121,16 @@
(case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
(and (eq? a a1) (eq? b b1) (eq? c c1))))
-(with-test-prefix "void"
- (assert-tree-il->glil
- (void)
- (program () (std-prelude 0 0 #f) (label _) (void) (call return 1)))
- (assert-tree-il->glil
- (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))
- (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))
- (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))
- (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)
- (label ,l4)
- (void) (call return 1))
- (and (eq? l1 l3) (eq? l2 l4)))
- (assert-tree-il->glil
- (apply (toplevel foo) (apply (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))))
-
-(with-test-prefix "conditional"
- (assert-tree-il->glil
- (if (toplevel foo) (const 1) (const 2))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1)
- (const 1) (call return 1)
- (label ,l2) (const 2) (call return 1))
- (eq? l1 l2))
-
- (assert-tree-il->glil without-partial-evaluation
- (begin (if (toplevel foo) (const 1) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
- (label ,l3) (label ,l4) (const #f) (call return 1))
- (eq? l1 l3) (eq? l2 l4))
-
- (assert-tree-il->glil
- (apply (primitive 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)
- (call null? 1) (call return 1))
- (eq? l1 l3) (eq? l2 l4)))
-
-(with-test-prefix "primitive-ref"
- (assert-tree-il->glil
- (primitive +)
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call return 1)))
-
- (assert-tree-il->glil
- (begin (primitive +) (const #f))
- (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive null?) (primitive +))
- (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1)
- (call return 1))))
-
-(with-test-prefix "lexical refs"
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (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 return 1)
- (unbind)))
-
- (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f)
- (let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (const #f) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1)) (apply (primitive 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)
- (unbind))))
-
-(with-test-prefix "lexical sets"
- (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))))
- (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) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil
- (let (x) (y) ((const 1))
- (begin (set! (lexical x y) (apply (primitive 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)
- (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0)
- (lexical #t #t ref 0) (call return 1)
- (unbind)))
-
- (assert-tree-il->glil
- (let (x) (y) ((const 1))
- (apply (primitive null?)
- (set! (lexical x y) (apply (primitive 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)
- (call null? 1) (call return 1)
- (unbind))))
-
-(with-test-prefix "module refs"
- (assert-tree-il->glil
- (@ (foo) bar)
- (program () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar)
- (call return 1)))
-
- (assert-tree-il->glil
- (begin (@ (foo) bar) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar) (call drop 1)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive null?) (@ (foo) bar))
- (program () (std-prelude 0 0 #f) (label _)
- (module public ref (foo) bar)
- (call null? 1) (call return 1)))
-
- (assert-tree-il->glil
- (@@ (foo) bar)
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (foo) bar)
- (call return 1)))
-
- (assert-tree-il->glil
- (begin (@@ (foo) bar) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (foo) bar) (call drop 1)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive null?) (@@ (foo) bar))
- (program () (std-prelude 0 0 #f) (label _)
- (module private ref (foo) bar)
- (call null? 1) (call return 1))))
-
-(with-test-prefix "module sets"
- (assert-tree-il->glil
- (set! (@ (foo) bar) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module public set (foo) bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (set! (@ (foo) bar) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module public set (foo) bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive 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)))
-
- (assert-tree-il->glil
- (set! (@@ (foo) bar) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module private set (foo) bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (set! (@@ (foo) bar) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (module private set (foo) bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive 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))))
-
-(with-test-prefix "toplevel refs"
- (assert-tree-il->glil
- (toplevel bar)
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar)
- (call return 1)))
-
- (assert-tree-il->glil without-partial-evaluation
- (begin (toplevel bar) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar) (call drop 1)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive null?) (toplevel bar))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref bar)
- (call null? 1) (call return 1))))
-
-(with-test-prefix "toplevel sets"
- (assert-tree-il->glil
- (set! (toplevel bar) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel set bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (set! (toplevel bar) (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel set bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive 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))))
-
-(with-test-prefix "toplevel defines"
- (assert-tree-il->glil
- (define bar (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel define bar)
- (void) (call return 1)))
-
- (assert-tree-il->glil
- (begin (define bar (const 2)) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel define bar)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- (apply (primitive null?) (define bar (const 2)))
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (toplevel define bar)
- (void) (call null? 1) (call return 1))))
-
-(with-test-prefix "constants"
- (assert-tree-il->glil
- (const 2)
- (program () (std-prelude 0 0 #f) (label _)
- (const 2) (call return 1)))
-
- (assert-tree-il->glil
- (begin (const 2) (const #f))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1)))
-
- (assert-tree-il->glil
- ;; This gets simplified by `peval'.
- (apply (primitive null?) (const 2))
- (program () (std-prelude 0 0 #f) (label _)
- (const #f) (call return 1))))
-
-(with-test-prefix "letrec"
- ;; 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)))
- (program () (std-prelude 0 2 #f) (label _)
- (const 10) (const 20)
- (bind (x #f 0) (y #f 1))
- (lexical #t #f set 1) (lexical #t #f set 0)
- (toplevel ref foo)
- (lexical #t #f ref 0) (lexical #t #f ref 1)
- (call tail-call 2)
- (unbind)))
-
- ;; 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)))
- (program () (std-prelude 0 4 #f) (label _)
- (void) (void) ;; what are these?
- (bind (x #t 0) (y #t 1))
- (lexical #t #t box 1) (lexical #t #t box 0)
- (call new-frame 0) (toplevel ref foo) (call call 0)
- (call new-frame 0) (toplevel ref bar) (call call 0)
- (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2)
- (lexical #t #f ref 2) (lexical #t #t set 0)
- (lexical #t #f ref 3) (lexical #t #t set 1)
- (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings
- (unbind)
- (lexical #t #t ref 0) (lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind)))
-
- ;; 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)))
- (program () (std-prelude 0 2 #f) (label _)
- (void) (void) ;; what are these?
- (bind (x #t 0) (y #t 1))
- (lexical #t #t box 1) (lexical #t #t box 0)
- (call new-frame 0) (toplevel ref foo) (call call 0)
- (lexical #t #t set 0)
- (call new-frame 0) (toplevel ref bar) (call call 0)
- (lexical #t #t set 1)
- (lexical #t #t ref 0)
- (lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind)))
-
- ;; simple bindings in letrec* -> equivalent to letrec
- (assert-tree-il->glil without-partial-evaluation
- (letrec* (x y) (xx yy) ((const 1) (const 2))
- (lexical y yy))
- (program () (std-prelude 0 1 #f) (label _)
- (const 2)
- (bind (y #f 0)) ;; X is removed, and Y is unboxed
- (lexical #t #f set 0)
- (lexical #t #f ref 0)
- (call return 1) (unbind))))
-
-(with-test-prefix "lambda"
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f #f #f () (y)) (const 2)) #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (std-prelude 1 1 #f)
- (bind (x #f 0)) (label _)
- (const 2) (call return 1) (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x y) #f #f #f () (x1 y1))
- (const 2))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (std-prelude 2 2 #f)
- (bind (x #f 0) (y #f 1)) (label _)
- (const 2) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case ((() #f x #f () (y)) (const 2))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 0 0 0 1 #f)
- (bind (x #f 0)) (label _)
- (const 2) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f x1 #f () (y y1)) (const 2))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 1 0 1 2 #f)
- (bind (x #f 0) (x1 #f 1)) (label _)
- (const 2) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 1 0 1 2 #f)
- (bind (x #f 0) (x1 #f 1)) (label _)
- (lexical #t #f ref 0) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (opt-prelude 1 0 1 2 #f)
- (bind (x #f 0) (x1 #f 1)) (label _)
- (lexical #t #f ref 1) (call return 1)
- (unbind))
- (call return 1)))
-
- (assert-tree-il->glil
- (lambda ()
- (lambda-case (((x) #f #f #f () (x1))
- (lambda ()
- (lambda-case (((y) #f #f #f () (y1))
- (lexical x x1))
- #f)))
- #f))
- (program () (std-prelude 0 0 #f) (label _)
- (program () (std-prelude 1 1 #f)
- (bind (x #f 0)) (label _)
- (program () (std-prelude 1 1 #f)
- (bind (y #f 0)) (label _)
- (lexical #f #f ref 0) (call return 1)
- (unbind))
- (lexical #t #f ref 0)
- (call make-closure 1)
- (call return 1)
- (unbind))
- (call return 1))))
-
-(with-test-prefix "sequence"
- (assert-tree-il->glil
- (begin (begin (const 2) (const #f)) (const #t))
- (program () (std-prelude 0 0 #f) (label _)
- (const #t) (call return 1)))
-
- (assert-tree-il->glil
- ;; This gets simplified by `peval'.
- (apply (primitive 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)))
- (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))
- (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)))
- (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}#))))
- (program () (std-prelude 0 0 #f) (label _)
- (branch br _) ;; entering the fix, jump to :2
- ;; :1 body of lp, jump to :3
- (label _) (bind) (const (one two)) (branch br _) (unbind)
- ;; :2 initial call of lp, jump to :1
- (label _) (bind) (branch br _) (label _) (unbind)
- ;; :3 the push continuation
- (call cdr 1) (call return 1))))
-
-;; FIXME: binding info for or-hacked locals might bork the disassembler,
-;; and could be tightened in any case
-(with-test-prefix "the or hack"
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1))
- (if (lexical x y)
- (lexical x y)
- (let (a) (b) ((const 2))
- (lexical a b))))
- (program () (std-prelude 0 1 #f) (label _)
- (const 1) (bind (x #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (branch br-if-not ,l1)
- (lexical #t #f ref 0) (call return 1)
- (label ,l2)
- (const 2) (bind (a #f 0)) (lexical #t #f set 0)
- (lexical #t #f ref 0) (call return 1)
- (unbind)
- (unbind))
- (eq? l1 l2))
-
- ;; second bound var is unreferenced
- (assert-tree-il->glil without-partial-evaluation
- (let (x) (y) ((const 1))
- (if (lexical x y)
- (lexical x y)
- (let (a) (b) ((const 2))
- (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) (branch br-if-not ,l1)
- (lexical #t #f ref 0) (call return 1)
- (label ,l2)
- (lexical #t #f ref 0) (call return 1)
- (unbind))
- (eq? l1 l2)))
-
-(with-test-prefix "apply"
- (assert-tree-il->glil
- (apply (primitive @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))
- (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)
- (label ,l4)
- (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)))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref foo)
- (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
- (call tail-call 1))))
-
-(with-test-prefix "call/cc"
- (assert-tree-il->glil
- (apply (primitive @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))
- (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)
- (label ,l4)
- (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)))
- (program () (std-prelude 0 0 #f) (label _)
- (toplevel ref foo)
- (toplevel ref bar) (call call/cc 1)
- (call tail-call 1))))
-
-(with-test-prefix "labels allocation"
+(with-test-prefix "contification"
(pass-if "http://debbugs.gnu.org/9769"
((compile '(lambda ()
(let ((fail (lambda () #f)))
(let ((test (lambda () (fail))))
(test))
#t))
- ;; Prevent inlining. We're testing analyze.scm's
- ;; labels allocator here, and inlining it will
- ;; reduce the entire thing to #t.
+ ;; Prevent inlining. We're testing contificatoin here,
+ ;; and inlining it will reduce the entire thing to #t.
#:opts '(#:partial-eval? #f)))))
@@ -720,24 +152,19 @@
(with-test-prefix "tree-il-fold"
- (pass-if "empty tree"
- (let ((leaf? #f) (up? #f) (down? #f) (mark (list 'mark)))
+ (pass-if "void"
+ (let ((up 0) (down 0) (mark (list 'mark)))
(and (eq? mark
- (tree-il-fold (lambda (x y) (set! leaf? #t) y)
- (lambda (x y) (set! down? #t) y)
- (lambda (x y) (set! up? #t) y)
+ (tree-il-fold (lambda (x y) (set! down (1+ down)) y)
+ (lambda (x y) (set! up (1+ up)) y)
mark
- '()))
- (not leaf?)
- (not up?)
- (not down?))))
+ (make-void #f)))
+ (= up 1)
+ (= down 1))))
(pass-if "lambda and application"
- (let* ((leaves '()) (ups '()) (downs '())
+ (let* ((ups '()) (downs '())
(result (tree-il-fold (lambda (x y)
- (set! leaves (cons x leaves))
- (1+ y))
- (lambda (x y)
(set! downs (cons x downs))
(1+ y))
(lambda (x y)
@@ -748,17 +175,24 @@
'(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)
+ (define (strip-source x)
+ (post-order (lambda (x)
+ (set! (tree-il-src x) #f)
+ x)
+ x))
+ (and (= result 12)
+ (equal? (map strip-source (list-head (reverse ups) 3))
+ (list (make-toplevel-ref #f '+)
+ (make-lexical-ref #f 'x 'x1)
+ (make-lexical-ref #f 'y 'y1)))
+ (equal? (map strip-source (reverse (list-head downs 3)))
+ (list (make-toplevel-ref #f '+)
(make-lexical-ref #f 'x 'x1)
- (make-toplevel-ref #f '+)))
- (= (length downs) 3)
- (equal? (reverse (map strip-source ups))
- (map strip-source downs))))))
+ (make-lexical-ref #f 'y 'y1)))))))
;;;
@@ -860,7 +294,7 @@
(let ((_ 'underscore)
(#{gensym name}# 'ignore-me))
#t))
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused))))))
(with-test-prefix "unused-toplevel"
@@ -871,7 +305,7 @@
(let ((in (open-input-string
"(define foo 2) foo")))
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "used before definition"
@@ -880,7 +314,7 @@
(let ((in (open-input-string
"(define (bar) foo) (define foo 2) (bar)")))
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused but public"
@@ -890,7 +324,7 @@
(null? (call-with-warnings
(lambda ()
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused but public (more)"
@@ -902,14 +336,14 @@
(null? (call-with-warnings
(lambda ()
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused but define-public"
(null? (call-with-warnings
(lambda ()
(compile '(define-public foo 2)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(pass-if "used by macro"
@@ -923,14 +357,14 @@
(define-syntax baz
(syntax-rules () ((_) (bar))))")))
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(pass-if "unused"
(let ((w (call-with-warnings
(lambda ()
(compile '(define foo 2)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(and (= (length w) 1)
(number? (string-contains (car w)
@@ -941,7 +375,7 @@
(let ((w (call-with-warnings
(lambda ()
(compile '(define (foo) (foo))
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(and (= (length w) 1)
(number? (string-contains (car w)
@@ -954,7 +388,7 @@
(w (call-with-warnings
(lambda ()
(read-and-compile in
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel)))))
(and (= (length w) 2)
(number? (string-contains (car w)
@@ -968,7 +402,7 @@
(null? (call-with-warnings
(lambda ()
(compile '(define #{gensym name}# 'ignore-me)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unused-toplevel))))))
(with-test-prefix "unbound variable"
@@ -983,7 +417,7 @@
(w (call-with-warnings
(lambda ()
(compile v
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unbound)))))
(and (= (length w) 1)
(number? (string-contains (car w)
@@ -995,7 +429,7 @@
(w (call-with-warnings
(lambda ()
(compile `(set! ,v 7)
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unbound)))))
(and (= (length w) 1)
(number? (string-contains (car w)
@@ -1012,7 +446,7 @@
(lambda ()
(compile v
#:env m
- #:to 'assembly
+ #:to 'cps
#:opts %opts-w-unbound))))))
(pass-if "module-local top-level is visible after"
@@ -1034,14 +468,14 @@
(lambda ()
(compile '(lambda* (x #:optional y z) (list x y z))
#:opts %opts-w-unbound
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "keyword arguments are visible"
(null? (call-with-warnings
(lambda ()
(compile '(lambda* (x #:key y z) (list x y z))
#:opts %opts-w-unbound
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "GOOPS definitions are visible"
(let ((m (make-module))
@@ -1070,7 +504,7 @@
(lambda ()
(compile '((lambda (x y) (or x y)) 1 2 3 4 5)
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1080,7 +514,7 @@
(compile '(let ((f (lambda (x y) (+ x y))))
(f 2))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1090,7 +524,7 @@
(lambda ()
(compile '(cons 1 2 3 4)
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1100,7 +534,7 @@
(lambda ()
(compile '(let ((f cons)) (f 1 2 3 4))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1112,7 +546,7 @@
(let ((g f))
(f 1 2 3 4)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1124,7 +558,7 @@
(let ((g f))
(g 1)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1138,7 +572,7 @@
(odd?)))))
(odd? 1))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1154,7 +588,7 @@
(f 1 2)
(f 1 2 3)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "case-lambda with wrong number of arguments"
(let ((w (call-with-warnings
@@ -1164,7 +598,7 @@
((x y) 2))))
(f 1 2 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1181,7 +615,7 @@
(f #:y 2)
(f 1 2 #:z 3)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "case-lambda* with wrong arguments"
(let ((w (call-with-warnings
@@ -1193,7 +627,7 @@
(list (f)
(f 1 #:z 3)))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 2)
(null? (filter (lambda (w)
(not
@@ -1209,7 +643,7 @@
(p (+ (p) 1))
(p))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "top-level applicable struct with wrong arguments"
(let ((w (call-with-warnings
@@ -1217,7 +651,7 @@
(compile '(let ((p current-warning-port))
(p 1 2 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1230,7 +664,7 @@
(define (f) 1)")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1243,7 +677,7 @@
(define (g) (f))")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1256,7 +690,7 @@
(define (foo x) (cons))")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(pass-if "keyword not passed and quiet"
(null? (call-with-warnings
@@ -1264,7 +698,7 @@
(compile '(let ((f (lambda* (x #:key y) y)))
(f 2))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "keyword passed and quiet"
(null? (call-with-warnings
@@ -1272,7 +706,7 @@
(compile '(let ((f (lambda* (x #:key y) y)))
(f 2 #:y 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "keyword passed to global and quiet"
(null? (call-with-warnings
@@ -1282,7 +716,7 @@
(compile '(+ 2 3) #:env (current-module))")))
(read-and-compile in
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(pass-if "extra keyword"
(let ((w (call-with-warnings
@@ -1290,7 +724,7 @@
(compile '(let ((f (lambda* (x #:key y) y)))
(f 2 #:Z 3))
#:opts %opts-w-arity
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments to")))))
@@ -1302,7 +736,7 @@
y)))
(f 2 #:Z 3))
#:opts %opts-w-arity
- #:to 'assembly))))))
+ #:to 'cps))))))
(with-test-prefix "format"
@@ -1311,28 +745,28 @@
(lambda ()
(compile '(format #t "hey!")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "quiet (1 arg)"
(null? (call-with-warnings
(lambda ()
(compile '(format #t "hey ~A!" "you")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "quiet (2 args)"
(null? (call-with-warnings
(lambda ()
(compile '(format #t "~A ~A!" "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "wrong port arg"
(let ((w (call-with-warnings
(lambda ()
(compile '(format 10 "foo")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong port argument")))))
@@ -1342,7 +776,7 @@
(lambda ()
(compile '(format #f fmt)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"non-literal format string")))))
@@ -1352,14 +786,14 @@
(lambda ()
(compile '(format #t (gettext "~A ~A!") "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as _"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (_ "~A ~A!") "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as top-level _"
(null? (call-with-warnings
@@ -1368,14 +802,14 @@
(define (_ s) (gettext s "my-domain"))
(format #t (_ "~A ~A!") "hello" "world"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as module-ref _"
(null? (call-with-warnings
(lambda ()
(compile '(format #t ((@@ (foo) _) "~A ~A!") "hello" "world")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using gettext as lexical _"
(null? (call-with-warnings
@@ -1384,7 +818,7 @@
(gettext s "my-domain"))))
(format #t (_ "~A ~A!") "hello" "world"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using ngettext"
(null? (call-with-warnings
@@ -1392,14 +826,14 @@
(compile '(format #t
(ngettext "~a thing" "~a things" n "dom") n)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string using ngettext as N_"
(null? (call-with-warnings
(lambda ()
(compile '(format #t (N_ "~a thing" "~a things" n) n)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "non-literal format string with (define _ gettext)"
(null? (call-with-warnings
@@ -1409,14 +843,14 @@
(define (foo)
(format #t (_ "~A ~A!") "hello" "world")))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()
(compile '(format #f 'not-a-string)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong format string")))))
@@ -1426,7 +860,7 @@
(lambda ()
(compile '(format "shbweeb")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"wrong number of arguments")))))
@@ -1437,14 +871,14 @@
(compile '((@ (ice-9 format) format) some-port
"~&~3_~~ ~\n~12they~% ~!~|~/~q")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "one missing argument"
(let ((w (call-with-warnings
(lambda ()
(compile '(format some-port "foo ~A~%")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1454,7 +888,7 @@
(lambda ()
(compile '(format some-port (gettext "foo ~A~%"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1465,7 +899,7 @@
(compile '((@ (ice-9 format) format) #f
"foo ~10,2f and bar ~S~%")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 0")))))
@@ -1475,7 +909,7 @@
(lambda ()
(compile '(format #t "foo ~A and ~S~%" hey)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 1")))))
@@ -1485,7 +919,7 @@
(lambda ()
(compile '(format #t "foo ~A~%" 1 2)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
@@ -1496,7 +930,7 @@
(compile '((@ (ice-9 format) format) #t
"foo ~h ~a~%" 123.4 'bar)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~:h with locale object"
(null? (call-with-warnings
@@ -1504,14 +938,14 @@
(compile '((@ (ice-9 format) format) #t
"foo ~:h~%" 123.4 %global-locale)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~:h without locale object"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #t "foo ~,2:h" 123.4)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 1")))))
@@ -1523,7 +957,7 @@
(compile '((@ (ice-9 format) format) #f "~A ~[foo~;bar~;baz~;~] ~10,2f"
'a 1 3.14)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "literals with selector"
(let ((w (call-with-warnings
@@ -1531,7 +965,7 @@
(compile '((@ (ice-9 format) format) #f "~2[foo~;bar~;baz~;~] ~A"
1 'dont-ignore-me)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
@@ -1541,7 +975,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~[~a~;~a~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 0")))))
@@ -1551,7 +985,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~1[chbouib~;~a~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1561,7 +995,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~[chbouib~;~a~;~2*~a~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1 to 4, got 0")))))
@@ -1571,7 +1005,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~@[temperature=~d~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1581,7 +1015,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~:[~[hey~;~a~;~va~]~;~3*~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2 to 4, got 0")))))
@@ -1591,7 +1025,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~[unterminated")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unterminated conditional")))))
@@ -1601,7 +1035,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "foo~;bar")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unexpected")))))
@@ -1611,7 +1045,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "foo~]")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unexpected"))))))
@@ -1623,14 +1057,14 @@
'hello '("ladies" "and")
'gentlemen)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~{...~}, too many args"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~{~S~}" 1 2 3)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 3")))))
@@ -1640,14 +1074,14 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~@{~S~}" 1 2 3)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~@{...~}, too few args"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~A ~@{~S~}")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected at least 1, got 0")))))
@@ -1657,7 +1091,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~{")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"unterminated")))))
@@ -1667,14 +1101,14 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~:@(~A ~A~)" 'foo 'bar)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~v"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~v_foo")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 0")))))
@@ -1683,7 +1117,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~v:@y" 1 123)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~*"
@@ -1691,7 +1125,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~2*~a" 'a 'b)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 3, got 2")))))
@@ -1701,21 +1135,21 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~?" "~d ~d" '(1 2))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~^"
(null? (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~a ~^ ~a" 0 1)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "~^, too few args"
(let ((w (call-with-warnings
(lambda ()
(compile '((@ (ice-9 format) format) #f "~a ~^ ~a")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected at least 1, got 0")))))
@@ -1726,7 +1160,7 @@
(compile '((@ (ice-9 format) format) some-port
"~#~ ~,,-2f ~,,+2f ~'A~" 1234 1234)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "complex 1"
(let ((w (call-with-warnings
@@ -1735,7 +1169,7 @@
"~4@S ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n"
1 2 3 4 5 6)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 4, got 6")))))
@@ -1747,7 +1181,7 @@
"~:(~A~) Commands~:[~; [abbrev]~]:~2%"
1 2 3 4)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 2, got 4")))))
@@ -1757,7 +1191,7 @@
(lambda ()
(compile '((@ (ice-9 format) format) #f "~9@a~:[~*~3_~;~3d~] ~v:@y~%")
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 5, got 0")))))
@@ -1771,7 +1205,7 @@
(i9-format #t \"yo! ~A\" 1 2)")))
(read-and-compile in
#:opts %opts-w-format
- #:to 'assembly))))))
+ #:to 'cps))))))
(and (= (length w) 1)
(number? (string-contains (car w)
"expected 1, got 2")))))
@@ -1782,7 +1216,7 @@
(compile '(let ((format chbouib))
(format #t "not ~A a format string"))
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(with-test-prefix "simple-format"
@@ -1791,14 +1225,14 @@
(lambda ()
(compile '(simple-format #t "foo ~a bar ~s ~%~~" 1 2)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "wrong number of args"
(let ((w (call-with-warnings
(lambda ()
(compile '(simple-format #t "foo ~a ~s~%" 'one-missing)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "wrong number")))))
@@ -1807,7 +1241,7 @@
(lambda ()
(compile '(simple-format #t "foo ~x~%" 16)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option")))))
@@ -1816,7 +1250,7 @@
(lambda ()
(compile '(simple-format #t (gettext "foo ~2f~%") 3.14)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option")))))
@@ -1825,7 +1259,7 @@
(lambda ()
(compile '(simple-format #t (ngettext "s ~x" "p ~x" x) x)
#:opts %opts-w-format
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format option")))))))
@@ -1836,7 +1270,7 @@
(lambda ()
(compile '(case x ((1) 'one) ((2) 'two))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "one duplicate"
(let ((w (call-with-warnings
@@ -1846,7 +1280,7 @@
((2) 'two)
((1) 'one-again))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "duplicate")))))
@@ -1857,7 +1291,7 @@
((1 2 3) 'a)
((1) 'one))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w) "duplicate"))))))
@@ -1868,7 +1302,7 @@
(lambda ()
(compile '(case x ((1) 'one) ((2) 'two))
#:opts %opts-w-bad-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(pass-if "not eqv?"
(let ((w (call-with-warnings
@@ -1877,7 +1311,7 @@
((1) 'one)
(("bad") 'bad))
#:opts %opts-w-bad-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"cannot be meaningfully compared")))))
@@ -1888,7 +1322,7 @@
(compile '(case x
((1 (2) 3) 'a))
#:opts %opts-w-duplicate-case-datum
- #:to 'assembly)))))
+ #:to 'cps)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"cannot be meaningfully compared")))))))
diff --git a/test-suite/tests/vlist.test b/test-suite/tests/vlist.test
index a37be5e46..dc54ffa50 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
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
index e24a268ec..aa607afad 100644
--- a/test-suite/tests/web-http.test
+++ b/test-suite/tests/web-http.test
@@ -1,6 +1,6 @@
;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2014 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
@@ -252,6 +252,8 @@
(with-test-prefix "entity headers"
(pass-if-parse allow "foo, bar" '(foo bar))
+ (pass-if-parse content-disposition "form-data; name=\"file\"; filename=\"q.go\""
+ '(form-data (name . "file") (filename . "q.go")))
(pass-if-parse content-encoding "qux, baz" '(qux baz))
(pass-if-parse content-language "qux, baz" '("qux" "baz"))
(pass-if-parse content-length "100" 100)
diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test
index 99b129334..3c1894e13 100644
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -1,6 +1,6 @@
;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 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
@@ -115,7 +115,7 @@ consectetur adipisicing elit,\r
(response-content-encoding r))
(pass-if-equal "response-body-port"
- `("utf-8" ,body)
+ `("UTF-8" ,body)
(with-fluids ((%default-port-encoding #f))
(let* ((r (read-response (open-input-string example-1)))
(p (response-body-port r)))