summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2020-03-06 17:57:20 +0100
committerLudovic Courtès <ludo@gnu.org>2020-03-06 18:06:51 +0100
commitd49453259bf97aed6d7e41d1bb364b62310c088f (patch)
treef4a6e70364d452c5b7e9e82a5f3331330e638db8
parent5d96e421586fa93d6d110c7c139ed6abd158e6e4 (diff)
downloadguile-d49453259bf97aed6d7e41d1bb364b62310c088f.tar.gz
Fix expansion of 'error' primitive with a non-constant argument.
Fixes <https://bugs.gnu.org/39509>. Reported by Klaus Stehle <klaus.stehle@uni-tuebingen.de>. * 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.
-rw-r--r--module/language/tree-il/primitives.scm3
-rw-r--r--test-suite/tests/tree-il.test38
2 files changed, 37 insertions, 4 deletions
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 550921787..300080d45 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 917316a0b..e650a2f00 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 <wingo@pobox.com> --- 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"