X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Falien.impure.lisp;h=6637dba7fb5f4ef24aad96ce962de66ae7c6dd55;hb=a189a69454ef7635149319ae213b337f17c50d20;hp=b327577dd8141aca25ce9dccfa7c2109928cf7d1;hpb=e7476d980c0b4949c9416b59249d0d621c0f747d;p=sbcl.git diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index b327577..6637dba 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -20,8 +20,8 @@ ;;; In sbcl-0.6.10, Douglas Brebner reported that (SETF EXTERN-ALIEN) ;;; was messed up so badly that trying to execute expressions like ;;; this signalled an error. -(setf (sb-alien:extern-alien "current_control_stack_pointer" sb-alien:unsigned) - (sb-alien:extern-alien "current_control_stack_pointer" sb-alien:unsigned)) +(setf (sb-alien:extern-alien "thread_control_stack_size" sb-alien:unsigned) + (sb-alien:extern-alien "thread_control_stack_size" sb-alien:unsigned)) ;;; bug 133, fixed in 0.7.0.5: Somewhere in 0.pre7.*, C void returns ;;; were broken ("unable to use values types here") when @@ -204,7 +204,7 @@ :ok))))) ;;; Unused local alien caused a compiler error -(with-test (:name unused-local-alien) +(with-test (:name :unused-local-alien) (let ((fun `(lambda () (sb-alien:with-alien ((alien1923 (array (sb-alien:unsigned 8) 72))) (values))))) @@ -247,8 +247,11 @@ ;;; void conflicted with derived type (declaim (inline bug-316075)) +#-win32 ;kludge: This reader conditional masks a bug, but allows the test + ;to fail cleanly. (sb-alien:define-alien-routine bug-316075 void (result char :out)) -(with-test (:name bug-316075) +(with-test (:name :bug-316075 :fails-on :win32) + #+win32 (error "fail") (handler-bind ((warning #'error)) (compile nil '(lambda () (multiple-value-list (bug-316075)))))) @@ -264,8 +267,7 @@ ((foo (unsigned 32))) foo) -#+(or x86-64 x86) -(with-test (:name bug-316325) +(with-test (:name :bug-316325 :skipped-on '(not (or :x86-64 :x86))) ;; This test works by defining a callback function that provides an ;; identity transform over a full-width machine word, then calling ;; it as if it returned a narrower type and checking to see if any @@ -294,4 +296,121 @@ (verify (signed 16) #x003f8042 #x-7fbe) (verify (signed 16) #x003f7042 #x7042))) +(with-test (:name :bug-654485) + ;; DEBUG 2 used to prevent let-conversion of the open-coded ALIEN-FUNCALL body, + ;; which in turn led the dreaded %SAP-ALIEN note. + (handler-case + (compile nil + `(lambda (program argv) + (declare (optimize (debug 2))) + (with-alien ((sys-execv1 (function int c-string (* c-string)) :extern + "execv")) + (values (alien-funcall sys-execv1 program argv))))) + (compiler-note (n) + (error "bad note: ~A" n)))) + +(with-test (:name :bug-721087 :fails-on :win32) + (assert (typep nil '(alien c-string))) + (assert (not (typep nil '(alien (c-string :not-null t))))) + (assert (eq :ok + (handler-case + (posix-getenv nil) + (type-error (e) + (when (and (null (type-error-datum e)) + (equal (type-error-expected-type e) + '(alien (c-string :not-null t)))) + :ok)))))) + +(with-test (:name :make-alien-string) + (let ((alien (sb-alien::make-alien-string "This comes from lisp!"))) + (gc :full t) + (assert (equal "This comes from lisp!" (cast alien c-string))) + (free-alien alien))) + +(with-test (:name :malloc-failure) + (assert (eq :enomem + (handler-case + (loop repeat 128 + collect (sb-alien:make-alien char (1- array-total-size-limit))) + (storage-condition () + :enomem))))) + +(with-test (:name :bug-985505) + ;; Check that correct octets are reported for a c-string-decoding error. + (assert + (eq :unibyte + (handler-case + (let ((c-string (coerce #(70 111 195 182 0) + '(vector (unsigned-byte 8))))) + (sb-sys:with-pinned-objects (c-string) + (sb-alien::c-string-to-string (sb-sys:vector-sap c-string) + :ascii 'character))) + (sb-int:c-string-decoding-error (e) + (assert (equalp #(195) (sb-int:character-decoding-error-octets e))) + :unibyte)))) + (assert + (eq :multibyte-4 + (handler-case + ;; KLUDGE, sort of. + ;; + ;; C-STRING decoding doesn't know how long the string is, and since this + ;; looks like a 4-byte sequence, it will grab 4 octets off the end. + ;; + ;; So we pad the vector for safety's sake. + (let ((c-string (coerce #(70 111 246 0 0 0) + '(vector (unsigned-byte 8))))) + (sb-sys:with-pinned-objects (c-string) + (sb-alien::c-string-to-string (sb-sys:vector-sap c-string) + :utf-8 'character))) + (sb-int:c-string-decoding-error (e) + (assert (equalp #(246 0 0 0) + (sb-int:character-decoding-error-octets e))) + :multibyte-4)))) + (assert + (eq :multibyte-2 + (handler-case + (let ((c-string (coerce #(70 195 1 182 195 182 0) '(vector (unsigned-byte 8))))) + (sb-sys:with-pinned-objects (c-string) + (sb-alien::c-string-to-string (sb-sys:vector-sap c-string) + :utf-8 'character))) + (sb-int:c-string-decoding-error (e) + (assert (equalp #(195 1) + (sb-int:character-decoding-error-octets e))) + :multibyte-2))))) + +(with-test (:name :stream-to-c-string-decoding-restart-leakage) + ;; Restarts for stream decoding errors didn't use to be associated with + ;; their conditions, so they could get confused with c-string decoding errors. + (assert (eq :nesting-ok + (catch 'out + (handler-bind ((sb-int:character-decoding-error + (lambda (stream-condition) + (handler-bind ((sb-int:character-decoding-error + (lambda (c-string-condition) + (throw 'out + (if (find-restart + 'sb-impl::input-replacement + c-string-condition) + :bad-restart + :nesting-ok))))) + (let ((c-string (coerce #(70 195 1 182 195 182 0) + '(vector (unsigned-byte 8))))) + (sb-sys:with-pinned-objects (c-string) + (sb-alien::c-string-to-string + (sb-sys:vector-sap c-string) + :utf-8 'character))))))) + (let ((namestring "alien.impure.tmp")) + (unwind-protect + (progn + (with-open-file (f namestring + :element-type '(unsigned-byte 8) + :direction :output + :if-exists :supersede) + (dolist (b '(70 195 1 182 195 182 0)) + (write-byte b f))) + (with-open-file (f namestring + :external-format :utf-8) + (read-line f))) + (delete-file namestring)))))))) + ;;; success