mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Fix expansion of 'error' primitive with a non-constant argument.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2020-03-06 17:57:20 +01:00
parent 5d96e42158
commit d49453259b
2 changed files with 37 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,6 @@
;;; open-coding primitive procedures ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -395,7 +395,6 @@
(list (make-const src 'misc-error) (list (make-const src 'misc-error)
(make-const src #f) (make-const src #f)
(make-const src msg) (make-const src msg)
(make-const src "?")
(make-primcall src 'list (cons message args)) (make-primcall src 'list (cons message args))
(make-const src #f))))))) (make-const src #f)))))))

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

@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009 ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -114,7 +114,41 @@
(pass-if-primitives-resolved (pass-if-primitives-resolved
(primcall equal? (const #nil) (toplevel x)) (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" (with-test-prefix "tree-il->scheme"