[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.3-61-ge7b2efd

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=e7b2efd582a6146cd9e9c82a905b3e87bb86d046

The branch, stable-2.0 has been updated
       via  e7b2efd582a6146cd9e9c82a905b3e87bb86d046 (commit)
       via  bcec8858a8968a955ac2febe36e5a4657e6054f6 (commit)
      from  679eea4f0ef7720e0ed3c9ba3fddedf35d1501d6 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit e7b2efd582a6146cd9e9c82a905b3e87bb86d046
Author: Ludovic Courtès <address@hidden>
Date:   Tue Dec 6 21:43:12 2011 +0100

    Add an exception printer for `getaddrinfo-error'.
    
    * module/ice-9/boot-9.scm (getaddrinfo-error-printer): New procedure.
      Use it as the `getaddrinfo-error' exception printer.

commit bcec8858a8968a955ac2febe36e5a4657e6054f6
Author: Ludovic Courtès <address@hidden>
Date:   Tue Dec 6 21:36:49 2011 +0100

    peval: Truncate multiple values when extending the environment.
    
    Reported by Cédric Cellier <address@hidden>.
    
    * module/language/tree-il/peval.scm (truncate-values): New procedure.
      (make-operand): Call `truncate-values' SOURCE.
    
    * test-suite/tests/tree-il.test ("partial evaluation"): New tests for
      multiple value truncation.

-----------------------------------------------------------------------

Summary of changes:
 module/ice-9/boot-9.scm           |    7 +++++-
 module/language/tree-il/peval.scm |   45 ++++++++++++++++++++++++++++++++++++-
 test-suite/tests/tree-il.test     |   17 ++++++++++++++
 3 files changed, 67 insertions(+), 2 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 2659d6c..d5ba67a 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -732,6 +732,9 @@ If there is no handler at all, Guile prints an error and 
then exits."
              (_ (default-printer)))
            args))
 
+  (define (getaddrinfo-error-printer port key args default-printer)
+    (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
+
   (set-exception-printer! 'goops-error scm-error-printer)
   (set-exception-printer! 'host-not-found scm-error-printer)
   (set-exception-printer! 'keyword-argument-error scm-error-printer)
@@ -751,7 +754,9 @@ If there is no handler at all, Guile prints an error and 
then exits."
   (set-exception-printer! 'wrong-number-of-args scm-error-printer)
   (set-exception-printer! 'wrong-type-arg scm-error-printer)
 
-  (set-exception-printer! 'syntax-error syntax-error-printer))
+  (set-exception-printer! 'syntax-error syntax-error-printer)
+
+  (set-exception-printer! 'getaddrinfo-error getaddrinfo-error-printer))
 
 
 
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index 634c6c9..0fd37fe 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -99,6 +99,47 @@
            (or (proc (vlist-ref vlist i))
                (lp (1+ i)))))))
 
+(define (truncate-values x)
+  "Discard all but the first value of X."
+  (let loop ((x x))
+    (match x
+      (($ <const>) x)
+      (($ <lexical-ref>) x)
+      (($ <void>) x)
+      (($ <lexical-ref>) x)
+      (($ <primitive-ref>) x)
+      (($ <module-ref>) x)
+      (($ <toplevel-ref>) x)
+      (($ <conditional> src condition subsequent alternate)
+       (make-conditional src condition (loop subsequent) (loop alternate)))
+      (($ <application> _ ($ <primitive-ref> _ 'values) (first _ ...))
+       first)
+      (($ <application> _ ($ <primitive-ref> _ 'values) (val))
+       val)
+      (($ <application> src
+          (and prim ($ <primitive-ref> _ (? singly-valued-primitive?)))
+          args)
+       (make-application src prim (map loop args)))
+      (($ <application> src proc args)
+       (make-application src proc (map loop args)))
+      (($ <sequence> src (exps ... last))
+       (make-sequence src (append exps (list (loop last)))))
+      (($ <lambda>) x)
+      (($ <dynlet> src fluids vals body)
+       (make-dynlet src fluids vals (loop body)))
+      (($ <let> src names gensyms vals body)
+       (make-let src names gensyms vals (loop body)))
+      (($ <letrec> src in-order? names gensyms vals body)
+       (make-letrec src in-order? names gensyms vals (loop body)))
+      (($ <fix> src names gensyms vals body)
+       (make-fix src names gensyms vals body))
+      (($ <let-values> src exp body)
+       (make-let-values src exp (loop body)))
+      (else
+       (make-application (tree-il-src x)
+                         (make-primitive-ref #f 'values)
+                         (list x))))))
+
 ;; Peval will do a one-pass analysis on the source program to determine
 ;; the set of assigned lexicals, and to identify unreferenced and
 ;; singly-referenced lexicals.
@@ -278,8 +319,10 @@
   (constant-value operand-constant-value set-operand-constant-value!))
 
 (define* (make-operand var sym #:optional source visit)
+  ;; Bind SYM to VAR, with value SOURCE.
   ;; Bound operands are considered copyable until we prove otherwise.
-  (%make-operand var sym visit source 0 #f (and source #t) #f #f))
+  (let ((source (if source (truncate-values source) source)))
+    (%make-operand var sym visit source 0 #f (and source #t) #f #f)))
 
 (define (make-bound-operands vars syms sources visit)
   (map (lambda (x y z) (make-operand x y z visit)) vars syms sources))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 5e02bd1..de82340 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -664,6 +664,23 @@
           (+ a b))))
     (const 3))
 
+  (pass-if-peval resolve-primitives
+    ;; First order, multiple values.
+    (let ((x 1) (y 2))
+      (values x y))
+    (apply (primitive values) (const 1) (const 2)))
+
+  (pass-if-peval resolve-primitives
+    ;; First order, multiple values truncated.
+    (let ((x (values 1 'a)) (y 2))
+      (values x y))
+    (apply (primitive values) (const 1) (const 2)))
+
+  (pass-if-peval resolve-primitives
+    ;; First order, multiple values truncated.
+    (or (values 1 2) 3)
+    (const 1))
+
   (pass-if-peval
     ;; First order, coalesced, mutability preserved.
     (cons 0 (cons 1 (cons 2 (list 3 4 5))))


hooks/post-receive
-- 
GNU Guile