diff options
-rw-r--r-- | libguile/loader.c | 7 | ||||
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/vm.test | 54 |
3 files changed, 60 insertions, 2 deletions
diff --git a/libguile/loader.c b/libguile/loader.c index 54bf1bff5..26a73436b 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -1,5 +1,5 @@ /* Copyright (C) 2001, 2009, 2010, 2011, 2012 - * 2013, 2014, 2015 Free Software Foundation, Inc. + * 2013, 2014, 2015, 2017 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 License @@ -362,7 +362,10 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only) header = (Elf_Ehdr*) data; if ((err_msg = check_elf_header (header))) - goto cleanup; + { + errno = 0; /* not an OS error */ + goto cleanup; + } if (header->e_phnum == 0) ABORT ("no loadable segments"); diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index bbf41b673..226e695e8 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -189,6 +189,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/version.test \ tests/vectors.test \ tests/vlist.test \ + tests/vm.test \ tests/weaks.test \ tests/web-client.test \ tests/web-http.test \ diff --git a/test-suite/tests/vm.test b/test-suite/tests/vm.test new file mode 100644 index 000000000..870e0f355 --- /dev/null +++ b/test-suite/tests/vm.test @@ -0,0 +1,54 @@ +;;;; vm.test --- tests for the ELF machinery and VM -*- scheme -*- +;;;; Copyright (C) 2017 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (tests vm) + #:use-module (test-suite lib) + #:use-module (system vm loader) + #:use-module (system vm elf) + #:use-module (rnrs bytevectors)) + +(define (elf->bytevector elf) + (let ((bv (make-bytevector 1000))) + (write-elf-header bv elf) + bv)) + + +(with-test-prefix "load-thunk-from-memory" + + (pass-if-exception "wrong byte order" + '(misc-error . "does not have native byte order") + ;; This used to throw to 'system-error' with whatever value errno had. + (begin + (false-if-exception (open-output-file "/does-not-exist")) + (load-thunk-from-memory + (elf->bytevector + (make-elf #:byte-order (if (eq? (native-endianness) + (endianness little)) + (endianness big) + (endianness + little)) + #:shoff 0))))) + + (pass-if-exception "wrong OS ABI" + '(misc-error . "OS ABI") + ;; This used to throw to 'system-error' with whatever value errno had. + (begin + (false-if-exception (open-output-file "/does-not-exist")) + (load-thunk-from-memory + (elf->bytevector + (make-elf #:abi ELFOSABI_TRU64 ;RIP + #:shoff 0)))))) |