mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
0aefb19bea
Some checks failed
Linux qemu / ppc64le (push) Failing after 1s
CL-host / ecl (push) Has been cancelled
CL-host / clisp (push) Has been cancelled
CL-host / ccl (push) Has been cancelled
CL-host / cmucl (push) Has been cancelled
CL-host / sbcl (push) Has been cancelled
Linux / build (x86, --with-sb-thread, ) (push) Has been cancelled
Linux / build (x86, --without-sb-thread, ) (push) Has been cancelled
Linux / build (x86, --without-sb-unicode, ) (push) Has been cancelled
Linux / build (x86-64, --with-mark-region-gc) (push) Has been cancelled
Linux / build (x86-64, --with-sb-fasteval --without-sb-eval, fasteval) (push) Has been cancelled
Linux / build (x86-64, --with-sb-thread, ) (push) Has been cancelled
Linux / build (x86-64, --with-sb-thread, sse4) (push) Has been cancelled
Linux / build (x86-64, --without-sb-thread, ) (push) Has been cancelled
Linux / build (x86-64, --without-sb-unicode, ) (push) Has been cancelled
Mac / build (--without-sb-thread, x86-64) (push) Has been cancelled
Mac / build (arm64, --with-mark-region-gc) (push) Has been cancelled
Mac / build (arm64, --with-sb-thread) (push) Has been cancelled
Mac / build (x86-64, --with-mark-region-gc) (push) Has been cancelled
Mac / build (x86-64, --with-sb-thread) (push) Has been cancelled
Windows / build (push) Has been cancelled
CL-host / compare-xc-host-fasls (ccl, false) (push) Has been cancelled
CL-host / compare-xc-host-fasls (clisp, false) (push) Has been cancelled
CL-host / compare-xc-host-fasls (cmucl, false) (push) Has been cancelled
CL-host / compare-xc-host-fasls (self, false) (push) Has been cancelled
81 lines
2.8 KiB
Common Lisp
81 lines
2.8 KiB
Common Lisp
;;;; Structured exception handling. Uses win64-exceptions.c.
|
|
|
|
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
#-(and win32 x86-64) (invoke-restart 'run-tests::skip-file) ;; This is extremely win64-specific.
|
|
|
|
(with-scratch-file (dll "dll")
|
|
(run-program "gcc" `("-shared" "-o" ,dll "win64-exceptions.c")
|
|
:search t)
|
|
(load-shared-object dll))
|
|
|
|
(define-alien-routine "unsafe_div" int
|
|
(dividend int)
|
|
(divisor int))
|
|
|
|
(define-alien-routine "raise_exception" void
|
|
(code int))
|
|
|
|
(define-alien-routine "raise_int_divide_by_zero" int
|
|
(handle int))
|
|
|
|
(define-alien-routine "raise_access_violation" int
|
|
(handle int))
|
|
|
|
(define-alien-routine "allocate_readonly_int" (* int))
|
|
|
|
(define-alien-routine "free_readonly_int" int
|
|
(pointer (* int)))
|
|
|
|
(with-test (:name :unsafe-div)
|
|
(assert (eql 3 (unsafe-div 12 4)))
|
|
(multiple-value-bind (result error)
|
|
(ignore-errors (unsafe-div 12 0))
|
|
(assert (null result))
|
|
(assert (string= (princ-to-string error)
|
|
"EXCEPTION_INT_DIVIDE_BY_ZERO"))))
|
|
|
|
(with-test (:name :raise-exception)
|
|
(let ((e (nth-value 1 (ignore-errors (raise-exception 42)))))
|
|
(assert (typep e 'sb-win32:exception))
|
|
(assert (eql 42 (sb-win32:exception-code e)))))
|
|
|
|
(with-test (:name :raise-int-divide-by-zero)
|
|
(assert (eql 1 (raise-int-divide-by-zero 1)))
|
|
(multiple-value-bind (result error)
|
|
(ignore-errors (raise-int-divide-by-zero 0))
|
|
(assert (null result))
|
|
(assert (string= (princ-to-string error)
|
|
"EXCEPTION_INT_DIVIDE_BY_ZERO"))))
|
|
|
|
(defvar *lose-on-corruption* (extern-alien "lose_on_corruption_p" int))
|
|
(setf (extern-alien "lose_on_corruption_p" int) 0)
|
|
|
|
(with-test (:name :raise-access-violation)
|
|
(assert (eql 1 (raise-access-violation 1)))
|
|
(assert-error (raise-access-violation 0) sb-sys:memory-fault-error))
|
|
|
|
(with-test (:name :access-violation-in-lisp)
|
|
(let ((p (allocate-readonly-int)))
|
|
(assert-error (setf (deref p) 42) sb-sys:memory-fault-error)
|
|
(free-readonly-int p)))
|
|
|
|
(setf (extern-alien "lose_on_corruption_p" int) *lose-on-corruption*)
|
|
|
|
;;; Not a very robust test since neither free() nor HeapFree() document this
|
|
;;; exception. The main result we wish for is not having the process abruptly
|
|
;;; terminated.
|
|
(with-test (:name :heap-corruption)
|
|
(let ((bad-pointer (sb-alien:sap-alien (sb-sys:int-sap 42) (* (unsigned 8)))))
|
|
(assert-error (sb-alien:free-alien bad-pointer)
|
|
sb-sys:foreign-heap-corruption)))
|