[Guile-commits] 01/02: Fix expansion of 'error' primitive with a non-constant argument.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guile.

commit d49453259bf97aed6d7e41d1bb364b62310c088f
Author: Ludovic Courtès <address@hidden>
AuthorDate: Fri Mar 6 17:57:20 2020 +0100

    Fix expansion of 'error' primitive with a non-constant argument.
    
    Fixes <https://bugs.gnu.org/39509>.
    Reported by Klaus Stehle <address@hidden>.
    
    * module/language/tree-il/primitives.scm (error): Remove extra "?"
    argument when the first argument is not a constant.
    * test-suite/tests/tree-il.test ("primitives")["error"]: New test
    prefix.
---
 module/language/tree-il/primitives.scm |  3 +--
 test-suite/tests/tree-il.test          | 38 ++++++++++++++++++++++++++++++++--
 2 files changed, 37 insertions(+), 4 deletions(-)

diff --git a/module/language/tree-il/primitives.scm 
b/module/language/tree-il/primitives.scm
index 5509217..300080d 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -1,6 +1,6 @@
 ;;; open-coding primitive procedures
 
-;; Copyright (C) 2009-2015, 2017-2019 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2015, 2017-2020 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
@@ -395,7 +395,6 @@
                      (list (make-const src 'misc-error)
                            (make-const src #f)
                            (make-const src msg)
-                           (make-const src "?")
                            (make-primcall src 'list (cons message args))
                            (make-const src #f)))))))
 
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 917316a..e650a2f 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <address@hidden> --- May 2009
 ;;;;
-;;;; Copyright (C) 2009-2014,2018-2019 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014,2018-2020 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
@@ -114,7 +114,41 @@
 
     (pass-if-primitives-resolved
         (primcall equal? (const #nil) (toplevel x))
-      (primcall eq? (const #nil) (toplevel x)))))
+      (primcall eq? (const #nil) (toplevel x))))
+
+  (with-test-prefix "error"
+    (pass-if-primitives-resolved
+        (primcall error (const "message"))
+      (primcall throw (const misc-error) (const #f)
+                (const "message") (primcall list) (const #f)))
+
+    (pass-if-primitives-resolved
+        (primcall error (const "message") (const 42))
+      (primcall throw (const misc-error) (const #f)
+                (const "message ~S") (primcall list (const 42))
+                (const #f)))
+
+    (pass-if-equal "https://bugs.gnu.org/39509";
+        '(throw 'misc-error #f "~A" (list "message") #f)
+      (let ((module (make-fresh-user-module)))
+        (decompile (expand-primitives
+                    (resolve-primitives
+                     (compile '(error ((lambda () "message")))
+                              #:to 'tree-il)
+                     module))
+                   #:from 'tree-il
+                   #:to 'scheme)))
+
+    (pass-if-equal "https://bugs.gnu.org/39509 with argument"
+        '(throw 'misc-error #f "~A ~S" (list "message" 42) #f)
+      (let ((module (make-fresh-user-module)))
+        (decompile (expand-primitives
+                    (resolve-primitives
+                     (compile '(error ((lambda () "message")) 42)
+                              #:to 'tree-il)
+                     module))
+                   #:from 'tree-il
+                   #:to 'scheme)))))
 
 
 (with-test-prefix "tree-il->scheme"