mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-24 12:20:20 +02:00
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/array-handle.c libguile/deprecated.h libguile/inline.c libguile/inline.h module/ice-9/deprecated.scm module/language/tree-il/peval.scm
This commit is contained in:
Andy Wingo
commit
9b977c836b
36 changed files with 873 additions and 384 deletions
|
|
@ -1,6 +1,6 @@
|
|||
;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
;;;; Copyright 2004, 2006, 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
|
||||
|
|
@ -227,26 +227,6 @@
|
|||
(b (make-shared-array a (lambda (i) (list i 1)) 2)))
|
||||
(array->list b))))
|
||||
|
||||
;;;
|
||||
;;; generalized-vector->list
|
||||
;;;
|
||||
|
||||
(with-test-prefix "generalized-vector->list"
|
||||
(pass-if-equal '(1 2 3) (generalized-vector->list #s16(1 2 3)))
|
||||
(pass-if-equal '(1 2 3) (generalized-vector->list #(1 2 3)))
|
||||
(pass-if-equal '() (generalized-vector->list #()))
|
||||
|
||||
(pass-if-equal "http://bugs.gnu.org/12465 - ok"
|
||||
'(3 4)
|
||||
(let* ((a #2((1 2) (3 4)))
|
||||
(b (make-shared-array a (lambda (j) (list 1 j)) 2)))
|
||||
(generalized-vector->list b)))
|
||||
(pass-if-equal "http://bugs.gnu.org/12465 - bad"
|
||||
'(2 4)
|
||||
(let* ((a #2((1 2) (3 4)))
|
||||
(b (make-shared-array a (lambda (i) (list i 1)) 2)))
|
||||
(generalized-vector->list b))))
|
||||
|
||||
;;;
|
||||
;;; array-fill!
|
||||
;;;
|
||||
|
|
@ -451,7 +431,7 @@
|
|||
(array-set! a 'y 2))
|
||||
(pass-if-exception "end+1" exception:out-of-range
|
||||
(array-set! a 'y 6))
|
||||
(pass-if-exception "two indexes" exception:out-of-range
|
||||
(pass-if-exception "two indexes" exception:wrong-num-indices
|
||||
(array-set! a 'y 6 7))))
|
||||
|
||||
(with-test-prefix "two dim"
|
||||
|
|
@ -649,6 +629,4 @@
|
|||
(pass-if (equal? (array-row array 1)
|
||||
#u32(2 3)))
|
||||
(pass-if (equal? (array-ref (array-row array 1) 0)
|
||||
2))
|
||||
(pass-if (equal? (generalized-vector-ref (array-row array 1) 0)
|
||||
2))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; bitvectors.test --- tests guile's bitvectors -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright 2010, 2011 Free Software Foundation, Inc.
|
||||
;;;; Copyright 2010, 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
|
||||
|
|
@ -22,7 +22,6 @@
|
|||
|
||||
(with-test-prefix "predicates"
|
||||
(pass-if (bitvector? #*1010101010))
|
||||
(pass-if (generalized-vector? #*1010101010))
|
||||
(pass-if (uniform-vector? #*1010101010))
|
||||
(pass-if (array? #*1010101010)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
|
||||
;;;; Ludovic Courtès
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
|
|
@ -589,42 +589,42 @@
|
|||
(with-input-from-string "#vu8(0 256)" read)))
|
||||
|
||||
|
||||
(with-test-prefix "Generalized Vectors"
|
||||
(with-test-prefix "Arrays"
|
||||
|
||||
(pass-if "generalized-vector?"
|
||||
(generalized-vector? #vu8(1 2 3)))
|
||||
(pass-if "array?"
|
||||
(array? #vu8(1 2 3)))
|
||||
|
||||
(pass-if "generalized-vector-length"
|
||||
(pass-if "array-length"
|
||||
(equal? (iota 16)
|
||||
(map generalized-vector-length
|
||||
(map array-length
|
||||
(map make-bytevector (iota 16)))))
|
||||
|
||||
(pass-if "generalized-vector-ref"
|
||||
(pass-if "array-ref"
|
||||
(let ((bv #vu8(255 127)))
|
||||
(and (= 255 (generalized-vector-ref bv 0))
|
||||
(= 127 (generalized-vector-ref bv 1)))))
|
||||
(and (= 255 (array-ref bv 0))
|
||||
(= 127 (array-ref bv 1)))))
|
||||
|
||||
(pass-if-exception "generalized-vector-ref [index out-of-range]"
|
||||
(pass-if-exception "array-ref [index out-of-range]"
|
||||
exception:out-of-range
|
||||
(let ((bv #vu8(1 2)))
|
||||
(generalized-vector-ref bv 2)))
|
||||
(array-ref bv 2)))
|
||||
|
||||
(pass-if "generalized-vector-set!"
|
||||
(pass-if "array-set!"
|
||||
(let ((bv (make-bytevector 2)))
|
||||
(generalized-vector-set! bv 0 255)
|
||||
(generalized-vector-set! bv 1 77)
|
||||
(array-set! bv 255 0)
|
||||
(array-set! bv 77 1)
|
||||
(equal? '(255 77)
|
||||
(bytevector->u8-list bv))))
|
||||
|
||||
(pass-if-exception "generalized-vector-set! [index out-of-range]"
|
||||
(pass-if-exception "array-set! [index out-of-range]"
|
||||
exception:out-of-range
|
||||
(let ((bv (make-bytevector 2)))
|
||||
(generalized-vector-set! bv 2 0)))
|
||||
(array-set! bv 0 2)))
|
||||
|
||||
(pass-if-exception "generalized-vector-set! [value out-of-range]"
|
||||
(pass-if-exception "array-set! [value out-of-range]"
|
||||
exception:out-of-range
|
||||
(let ((bv (make-bytevector 2)))
|
||||
(generalized-vector-set! bv 0 256)))
|
||||
(array-set! bv 256 0)))
|
||||
|
||||
(pass-if "array-type"
|
||||
(eq? 'vu8 (array-type #vu8())))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
;;;; 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
|
||||
|
|
@ -69,14 +69,19 @@
|
|||
|
||||
(pass-if "equal? modulo finalizer"
|
||||
(let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))))
|
||||
(equal? (make-pointer 123)
|
||||
(make-pointer 123 finalizer))))
|
||||
(if (not finalizer)
|
||||
(throw 'unresolved) ; probably Windows
|
||||
(equal? (make-pointer 123)
|
||||
(make-pointer 123 finalizer)))))
|
||||
|
||||
(pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
|
||||
(let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link)))
|
||||
(ptr (make-pointer 123)))
|
||||
(set-pointer-finalizer! ptr finalizer)
|
||||
(equal? (make-pointer 123) ptr)))
|
||||
(if (not finalizer)
|
||||
(throw 'unresolved) ; probably Windows
|
||||
(begin
|
||||
(set-pointer-finalizer! ptr finalizer)
|
||||
(equal? (make-pointer 123) ptr)))))
|
||||
|
||||
(pass-if "not equal?"
|
||||
(not (equal? (make-pointer 123) (make-pointer 456)))))
|
||||
|
|
|
|||
|
|
@ -292,3 +292,19 @@
|
|||
exception:wrong-type-arg
|
||||
(hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar))
|
||||
)
|
||||
|
||||
|
||||
;;;
|
||||
;;; hash-count
|
||||
;;;
|
||||
|
||||
(with-test-prefix "hash-count"
|
||||
(let ((table (make-hash-table)))
|
||||
(hashq-set! table 'foo "bar")
|
||||
(hashq-set! table 'braz "zonk")
|
||||
(hashq-create-handle! table 'frob #f)
|
||||
|
||||
(pass-if (equal? 3 (hash-count (const #t) table)))
|
||||
|
||||
(pass-if (equal? 2 (hash-count (lambda (k v)
|
||||
(string? v)) table)))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -25,6 +25,7 @@
|
|||
#: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))
|
||||
|
||||
(define peval
|
||||
|
|
@ -835,6 +836,153 @@
|
|||
(((x) #f #f #f () (_))
|
||||
(call (toplevel top) (lexical x _)))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; The inliner sees through a `let'.
|
||||
((let ((a 10)) (lambda (b) (* b 2))) 30)
|
||||
(const 60))
|
||||
|
||||
(pass-if-peval
|
||||
((lambda ()
|
||||
(define (const x) (lambda (_) x))
|
||||
(let ((v #f))
|
||||
((const #t) v))))
|
||||
(const #t))
|
||||
|
||||
(pass-if-peval
|
||||
;; Applications of procedures with rest arguments can get inlined.
|
||||
((lambda (x y . z)
|
||||
(list x y z))
|
||||
1 2 3 4)
|
||||
(let (z) (_) ((primcall list (const 3) (const 4)))
|
||||
(primcall list (const 1) (const 2) (lexical z _))))
|
||||
|
||||
(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))
|
||||
(primcall list (const 0) (const 1) (const 2) (const 3)))
|
||||
|
||||
(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) (_) ((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
|
||||
;; `list', so the inlining still happens.
|
||||
(lambda (bv offset n)
|
||||
(let ((x (bytevector-ieee-single-native-ref
|
||||
bv
|
||||
(+ offset 0)))
|
||||
(y (bytevector-ieee-single-native-ref
|
||||
bv
|
||||
(+ offset 4))))
|
||||
(let ((args (list x y)))
|
||||
(@apply
|
||||
(lambda (bv offset x y)
|
||||
(bytevector-ieee-single-native-set!
|
||||
bv
|
||||
(+ offset 0)
|
||||
x)
|
||||
(bytevector-ieee-single-native-set!
|
||||
bv
|
||||
(+ offset 4)
|
||||
y))
|
||||
bv
|
||||
offset
|
||||
args))))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
(((bv offset n) #f #f #f () (_ _ _))
|
||||
(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
|
||||
(lambda (z x)
|
||||
(list z x))
|
||||
;; This toplevel ref might raise an unbound variable exception.
|
||||
;; The effects of `(foo!)' must be visible before this effect.
|
||||
z
|
||||
args)))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
((() #f #f #f () ())
|
||||
(let (_) (_) ((call (toplevel foo!)))
|
||||
(let (z) (_) ((toplevel z))
|
||||
(primcall 'list
|
||||
(lexical z _)
|
||||
(lexical _ _))))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Rest args referenced more than once are not destructured.
|
||||
(lambda ()
|
||||
(let ((args (list 'foo)))
|
||||
(set-car! args 'bar)
|
||||
(@apply
|
||||
(lambda (z x)
|
||||
(list z x))
|
||||
z
|
||||
args)))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
((() #f #f #f () ())
|
||||
(let (args) (_)
|
||||
((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)))
|
||||
(primcall list (const 1) (const 2)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cons of #nil does not make list
|
||||
(cons 1 #nil)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*-
|
||||
;;;; Martin Grabmueller, 2001-06-26
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001, 2006, 2010, 2011 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2001, 2006, 2010, 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
|
||||
|
|
@ -438,24 +438,24 @@
|
|||
(pass-if "+inf.0, -inf.0, +nan.0 in c32vector"
|
||||
(c32vector? #c32(+inf.0 -inf.0 +nan.0)))
|
||||
|
||||
(pass-if "generalized-vector-ref"
|
||||
(pass-if "array-ref"
|
||||
(let ((v (c32vector 1+1i)))
|
||||
(= (c32vector-ref v 0)
|
||||
(generalized-vector-ref v 0))))
|
||||
(array-ref v 0))))
|
||||
|
||||
(pass-if "generalized-vector-set!"
|
||||
(pass-if "array-set!"
|
||||
(let ((x 1+1i)
|
||||
(v (c32vector 0)))
|
||||
(generalized-vector-set! v 0 x)
|
||||
(= x (generalized-vector-ref v 0))))
|
||||
(array-set! v x 0)
|
||||
(= x (array-ref v 0))))
|
||||
|
||||
(pass-if-exception "generalized-vector-ref, out-of-range"
|
||||
(pass-if-exception "array-ref, out-of-range"
|
||||
exception:out-of-range
|
||||
(generalized-vector-ref (c32vector 1.0) 1))
|
||||
(array-ref (c32vector 1.0) 1))
|
||||
|
||||
(pass-if-exception "generalized-vector-set!, out-of-range"
|
||||
(pass-if-exception "array-set!, out-of-range"
|
||||
exception:out-of-range
|
||||
(generalized-vector-set! (c32vector 1.0) 1 2.0)))
|
||||
(array-set! (c32vector 1.0) 2.0 1)))
|
||||
|
||||
(with-test-prefix "c64 vectors"
|
||||
|
||||
|
|
@ -497,24 +497,24 @@
|
|||
(pass-if "+inf.0, -inf.0, +nan.0 in c64vector"
|
||||
(c64vector? #c64(+inf.0 -inf.0 +nan.0)))
|
||||
|
||||
(pass-if "generalized-vector-ref"
|
||||
(pass-if "array-ref"
|
||||
(let ((v (c64vector 1+1i)))
|
||||
(= (c64vector-ref v 0)
|
||||
(generalized-vector-ref v 0))))
|
||||
(array-ref v 0))))
|
||||
|
||||
(pass-if "generalized-vector-set!"
|
||||
(pass-if "array-set!"
|
||||
(let ((x 1+1i)
|
||||
(v (c64vector 0)))
|
||||
(generalized-vector-set! v 0 x)
|
||||
(= x (generalized-vector-ref v 0))))
|
||||
(array-set! v x 0)
|
||||
(= x (array-ref v 0))))
|
||||
|
||||
(pass-if-exception "generalized-vector-ref, out-of-range"
|
||||
(pass-if-exception "array-ref, out-of-range"
|
||||
exception:out-of-range
|
||||
(generalized-vector-ref (c64vector 1.0) 1))
|
||||
(array-ref (c64vector 1.0) 1))
|
||||
|
||||
(pass-if-exception "generalized-vector-set!, out-of-range"
|
||||
(pass-if-exception "array-set!, out-of-range"
|
||||
exception:out-of-range
|
||||
(generalized-vector-set! (c64vector 1.0) 1 2.0)))
|
||||
(array-set! (c64vector 1.0) 2.0 1)))
|
||||
|
||||
(with-test-prefix "accessing uniform vectors of different types"
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue