diff options
author | Ludovic Courtès <ludo@gnu.org> | 2020-03-06 17:57:20 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2020-03-06 18:06:51 +0100 |
commit | d49453259bf97aed6d7e41d1bb364b62310c088f (patch) | |
tree | f4a6e70364d452c5b7e9e82a5f3331330e638db8 | |
parent | 5d96e421586fa93d6d110c7c139ed6abd158e6e4 (diff) | |
download | guile-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.scm | 3 | ||||
-rw-r--r-- | 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 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" |