Fix make-array transforms.

[sbcl.git] / tests / alien.impure.lisp

diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index f97e73c..6637dba 100644 (file)
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -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
@@ -305,9 +307,9 @@
                                            "execv"))
                     (values (alien-funcall sys-execv1 program argv)))))
     (compiler-note (n)
-      (error n))))
+      (error "bad note: ~A" n))))
 
-(with-test (:name :bug-721087)
+(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
@@ -325,4 +327,90 @@
     (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