mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-09 10:50:27 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
There are a some failures currently:

    FAIL: tree-il.test: warnings: format: non-literal format string with forward declaration
    ERROR: srfi-18.test: current-exception-handler: current handler returned at top level - arguments: ((wrong-type-arg "car" "Wrong type argument in position ~A (expecting ~A): ~S" (1 "pair" #<unspecified>) (#<unspecified>)))
    ERROR: srfi-18.test: current-exception-handler: multiple levels of handler nesting - arguments: ((wrong-type-arg "car" "Wrong type argument in position ~A (expecting ~A): ~S" (1 "pair" #<unspecified>) (#<unspecified>)))
    ERROR: srfi-18.test: current-exception-handler: exception handler installation is thread-safe - arguments: ((wrong-type-arg "car" "Wrong type argument in position ~A (expecting ~A): ~S" (1 "pair" #<unspecified>) (#<unspecified>)))

Conflicts:
	module/language/tree-il/peval.scm
	module/language/tree-il/primitives.scm
	test-suite/tests/tree-il.test
This commit is contained in:
Andy Wingo 2012-03-02 17:20:47 +01:00
commit d489998364
11 changed files with 535 additions and 449 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/language/tree-il/analyze.scm
View file

@ -1360,7 +1360,8 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
(($ <toplevel-ref> _ name)
(let ((var (false-if-exception (module-variable env name))))
(if var
(eq? (variable-ref var) proc)
(eq? (false-if-exception (variable-ref var)) ; VAR may be unbound
proc)
(eq? name special-name)))) ; special hack to support local aliases
(($ <module-ref> _ module name public?)
(let ((m (false-if-exception (if public?

6
module/language/tree-il/canonicalize.scm
View file

@ -1,6 +1,6 @@
;;; Tree-il canonicalizer
;; Copyright (C) 2011 Free Software Foundation, Inc.
;; Copyright (C) 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
@ -48,10 +48,10 @@
(define (escape-only? handler)
(match handler
(($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
(tree-il-any (lambda (x)
(not (tree-il-any (lambda (x)
(and (lexical-ref? x)
(eq? (lexical-ref-gensym x) cont)))
body))
body)))
(else #f)))
(define (thunk-application? x)
(match x

21
module/language/tree-il/peval.scm
View file

@ -1221,12 +1221,27 @@ top-level bindings from ENV and return the resulting expression."
exp
(make-lambda src meta (for-values body))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
(define (lift-applied-lambda body gensyms)
(and (not opt) rest (not kw)
(match body
(($ <primcall> _ '@apply
(($ <lambda> _ _ lcase)
($ <lexical-ref> _ _ sym)
...))
(and (equal? sym gensyms)
(not (lambda-case-alternate lcase))
lcase))
(_ #f))))
(let* ((vars (map lookup-var gensyms))
(new (fresh-gensyms vars))
(env (fold extend-env env gensyms
(make-unbound-operands vars new)))
(new-sym (lambda (old)
(operand-sym (cdr (vhash-assq old env))))))
(operand-sym (cdr (vhash-assq old env)))))
(body (loop body env counter ctx)))
(or
;; (lambda args (apply (lambda ...) args)) => (lambda ...)
(lift-applied-lambda body new)
(make-lambda-case src req opt rest
(match kw
((aok? (kw name old) ...)
@ -1234,8 +1249,8 @@ top-level bindings from ENV and return the resulting expression."
(_ #f))
(map (cut loop <> env counter 'value) inits)
new
(loop body env counter ctx)
(and alt (for-tail alt)))))
body
(and alt (for-tail alt))))))
(($ <seq> src head tail)
(let ((head (for-effect head))
(tail (for-tail tail)))

17
module/language/tree-il/primitives.scm
View file

@ -544,22 +544,21 @@
'call-with-prompt
(case-lambda
((src tag thunk handler)
;; Sigh. Until the inliner does its job, manually inline
;; (let ((h (lambda ...))) (prompt k x h))
(cond
((lambda? handler)
(let ((args-sym (gensym)))
(let ((handler-sym (gensym))
(args-sym (gensym)))
(make-let
src '(handler) (list handler-sym) (list handler)
(make-prompt
src tag (make-call #f thunk '())
;; If handler itself is a lambda, the inliner can do some
;; trickery here.
(make-lambda-case
(tree-il-src handler) '() #f 'args #f '() (list args-sym)
(make-primcall #f 'apply
(list handler
(make-primcall
#f 'apply
(list (make-lexical-ref #f 'handler handler-sym)
(make-lexical-ref #f 'args args-sym)))
#f))))
(else #f)))
#f)))))
(else #f)))
(hashq-set! *primitive-expand-table*

6
module/srfi/srfi-4.scm
View file

@ -1,6 +1,7 @@
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010,
;; 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
@ -79,7 +80,8 @@
(apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v)
(/ ,size (uniform-vector-element-size v)))))
(uniform-vector-element-size v)
(/ ,size))))
(if (integer? len)
len
(error "fractional length" v ',tag ,size))))

5
module/srfi/srfi-4/gnu.scm
View file

@ -1,6 +1,6 @@
;;; Extensions to SRFI-4
;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 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
@ -52,7 +52,8 @@
(apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v)
(/ ,size (uniform-vector-element-size v)))))
(uniform-vector-element-size v)
(/ ,size))))
(if (integer? len)
len
(error "fractional length" v ',tag ,size))))

16
module/system/base/pmatch.scm
View file

@ -1,6 +1,6 @@
;;; pmatch, a simple matcher
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc
;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
;;; Copyright (C) 2007 Daniel P. Friedman
;;;
@ -35,22 +35,22 @@
;;; Code:
(define-module (system base pmatch)
#:export (pmatch))
#:export-syntax (pmatch))
(define-syntax pmatch
(define-syntax-rule (pmatch e cs ...)
(let ((v e)) (pmatch1 v cs ...)))
(define-syntax pmatch1
(syntax-rules (else guard)
((_ (op arg ...) cs ...)
(let ((v (op arg ...)))
(pmatch v cs ...)))
((_ v) (if #f #f))
((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(let ((fk (lambda () (pmatch1 v cs ...))))
(ppat v pat
(if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(let ((fk (lambda () (pmatch1 v cs ...))))
(ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat

9
test-suite/lib.scm
View file

@ -314,11 +314,11 @@
;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment.
(define run-test #f)
(define run-test
(let ((test-running #f))
(define (local-run-test name expect-pass thunk)
(lambda (name expect-pass thunk)
(if test-running
(error "Nested calls to run-test are not permitted.")
(error "Nested calls to run-test are not permitted."))
(let ((test-name (full-name name)))
(set! test-running #t)
(catch #t
@ -340,8 +340,7 @@
(quit))
(else
(report 'error test-name (cons key args))))))
(set! test-running #f))))
(set! run-test local-run-test))
(set! test-running #f)))))
;;; A short form for tests that are expected to pass, taken from Greg.
(define-syntax pass-if

11
test-suite/tests/srfi-18.test
View file

@ -1,7 +1,7 @@
;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
;;;; Julian Graham, 2007-10-26
;;;;
;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
;;;; Copyright (C) 2007, 2008, 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
@ -25,9 +25,8 @@
(if (provided? 'threads)
(use-modules (srfi srfi-18)))
(and
(provided? 'threads)
(cond
((provided? 'threads)
(with-test-prefix "current-thread"
(pass-if "current-thread eq current-thread"
@ -480,6 +479,4 @@
(eq? (uncaught-exception-reason obj) 'foo)
(set! success #t)))
(lambda () (thread-join! t)))
success)))
)
success)))))

25
test-suite/tests/srfi-4.test
View file

@ -515,3 +515,28 @@
(pass-if-exception "generalized-vector-set!, out-of-range"
exception:out-of-range
(generalized-vector-set! (c64vector 1.0) 1 2.0)))
(with-test-prefix "accessing uniform vectors of different types"
(pass-if "u32vector-length of u16vector"
(= 2 (u32vector-length (make-u16vector 4))))
(pass-if "u32vector-length of u8vector"
(= 2 (u32vector-length (make-u8vector 8))))
(pass-if "u8vector-length of u16vector"
(= 4 (u8vector-length (make-u16vector 2))))
(pass-if "u8vector-length of u32vector"
(= 8 (u8vector-length (make-u32vector 2))))
(pass-if "u32vector-set! of u16vector"
(let ((v (make-u16vector 4 #xFFFF)))
(u32vector-set! v 1 0)
(equal? v #u16(#xFFFF #xFFFF 0 0))))
(pass-if "u16vector-set! of u32vector"
(let ((v (make-u32vector 2 #xFFFFFFFF)))
(u16vector-set! v 2 0)
(u16vector-set! v 3 0)
(equal? v #u32(#xFFFFFFFF 0)))))

49
test-suite/tests/tree-il.test
View file

@ -1549,6 +1549,31 @@
(lambda args args)))
(const 1))
;; Handler lambda inlined
(pass-if-peval
(call-with-prompt tag
(lambda () 1)
(lambda (k x) x))
(prompt (toplevel tag)
(const 1)
(lambda-case
(((k x) #f #f #f () (_ _))
(lexical x _)))))
;; Handler toplevel not inlined
(pass-if-peval
(call-with-prompt tag
(lambda () 1)
handler)
(let (handler) (_) ((toplevel handler))
(prompt (toplevel tag)
(const 1)
(lambda-case
((() #f args #f () (_))
(primcall @apply
(lexical handler _)
(lexical args _)))))))
(pass-if-peval
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
@ -1564,7 +1589,16 @@
((() #f #f #f () ())
(call (lexical loop _))))))
(call (lexical loop _)))))))
(call (lexical lp _)))))
(call (lexical lp _))))
(pass-if-peval
(lambda (a . rest)
(apply (lambda (x y) (+ x y))
a rest))
(lambda _
(lambda-case
(((x y) #f #f #f () (_ _))
_)))))
@ -2200,6 +2234,19 @@
#:opts %opts-w-format
#:to 'assembly)))))
(pass-if "non-literal format string with forward declaration"
(let ((w (call-with-warnings
(lambda ()
(compile '(begin
(define (foo)
(format #t (_ "~A ~A!") "hello" "world"))
(define _ bar))
#:opts %opts-w-format
#:to 'assembly)))))
(and (= (length w) 1)
(number? (string-contains (car w)
"non-literal format string")))))
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()