From 568daf6b160280428701670b921f419aabd9eba0 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 6 Apr 2006 10:39:28 +0000 Subject: [PATCH] 0.9.11.16: Fix for VECTOR-T-P (bug reported by Utz-Uwe Haus sbcl-devel 2006-03-25). ... add test cases. ... also much whitespaceification, apparently. --- NEWS | 3 + contrib/sb-bsd-sockets/misc.lisp | 2 +- contrib/sb-bsd-sockets/name-service.lisp | 12 +-- contrib/sb-bsd-sockets/sockets.lisp | 2 +- contrib/sb-bsd-sockets/win32-constants.lisp | 2 +- contrib/sb-bsd-sockets/win32-sockets.lisp | 154 +++++++++++++-------------- src/code/filesys.lisp | 12 +-- src/code/pred.lisp | 3 +- src/code/run-program.lisp | 48 ++++----- src/code/toplevel.lisp | 8 +- src/code/unix.lisp | 2 +- src/code/win32.lisp | 28 ++--- src/runtime/run-program.c | 4 +- tests/vector.impure.lisp | 79 ++++++++++++++ version.lisp-expr | 2 +- 15 files changed, 222 insertions(+), 139 deletions(-) create mode 100644 tests/vector.impure.lisp diff --git a/NEWS b/NEWS index e6a4be0..2505dde 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,9 @@ changes in sbcl-0.9.12 relative to sbcl-0.9.11: immediately available from the stream * fixed bug: types of the last two arguments to SET-SYNTAX-FROM-CHAR were reversed. (reported by Levente Mészáros) + * fixed bug: Tests for the (VECTOR T) type gave the wrong answer + when given a vector displaced to an adjustable array. (reported + by Utz-Uwe Haus) * fixed some bugs revealed by Paul Dietz' test suite: ** REMOVE-METHOD returns its generic function argument even when the method is not one of the generic functions' methods. diff --git a/contrib/sb-bsd-sockets/misc.lisp b/contrib/sb-bsd-sockets/misc.lisp index a263ca5..2c0246b 100644 --- a/contrib/sb-bsd-sockets/misc.lisp +++ b/contrib/sb-bsd-sockets/misc.lisp @@ -46,5 +46,5 @@ (defmethod (setf non-blocking-mode) (non-blocking-p (socket socket)) 0) ;; (sb-alien:with-alien ((mode (unsigned 32))) ;; (if non-blocking-p (setf mode 1)) -;; (ioctlsocket socket FIONBIO mode))) +;; (ioctlsocket socket FIONBIO mode))) diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp index d55ee8d..8d1d016 100644 --- a/contrib/sb-bsd-sockets/name-service.lisp +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -41,8 +41,8 @@ (loop for i from 0 below length do (setf (elt addr i) (sb-alien:deref ad i))) addr)) - #-win32 - (#.sockint::af-local + #-win32 + (#.sockint::af-local (sb-alien:cast ad sb-alien:c-string)))))) (make-instance 'host-ent :name (sockint::hostent-name h) @@ -113,7 +113,7 @@ GET-NAME-SERVICE-ERRNO") #-win32 (define-name-service-condition sockint::NETDB-INTERNAL netdb-internal-error) -#-win32 +#-win32 (define-name-service-condition sockint::NETDB-SUCCESS netdb-success-error) (define-name-service-condition sockint::HOST-NOT-FOUND host-not-found-error) (define-name-service-condition sockint::TRY-AGAIN try-again-error) @@ -129,10 +129,10 @@ GET-NAME-SERVICE-ERRNO") (defun get-name-service-errno () (setf *name-service-errno* (sb-alien:alien-funcall - #-win32 + #-win32 (sb-alien:extern-alien "get_h_errno" (function integer)) - #+win32 - (sb-alien:extern-alien "WSAGetLastError" (function integer))))) + #+win32 + (sb-alien:extern-alien "WSAGetLastError" (function integer))))) #-(and cmu solaris) (progn diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index 6cff161..9ead7d6 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -5,7 +5,7 @@ (eval-when (:load-toplevel :compile-toplevel :execute) -#+win32 +#+win32 (defvar *wsa-startup-call* (sockint::wsa-startup (sockint::make-wsa-version 2 2))) diff --git a/contrib/sb-bsd-sockets/win32-constants.lisp b/contrib/sb-bsd-sockets/win32-constants.lisp index 9fa1f17..e9b2596 100644 --- a/contrib/sb-bsd-sockets/win32-constants.lisp +++ b/contrib/sb-bsd-sockets/win32-constants.lisp @@ -46,7 +46,7 @@ (defconstant EPERM 1) ;; basic socket errors -(defconstant WSABASEERR 10000) +(defconstant WSABASEERR 10000) (defconstant EINTR (+ WSABASEERR 4)) (defconstant EBADF (+ WSABASEERR 9)) (defconstant EACCES (+ WSABASEERR 13)) diff --git a/contrib/sb-bsd-sockets/win32-sockets.lisp b/contrib/sb-bsd-sockets/win32-sockets.lisp index 9dff001..42d5c86 100644 --- a/contrib/sb-bsd-sockets/win32-sockets.lisp +++ b/contrib/sb-bsd-sockets/win32-sockets.lisp @@ -16,42 +16,42 @@ (sb-alien:define-alien-type nil (struct WSADATA - (wVersion (unsigned 16)) - (wHighVersion (unsigned 16)) - (szDescription (array char 257)) - (szSystemStatus (array char 129)) - (iMaxSockets (unsigned 16)) - (iMaxUdpDg (unsigned 16)) - (lpVendorInfo sb-alien:c-string))) + (wVersion (unsigned 16)) + (wHighVersion (unsigned 16)) + (szDescription (array char 257)) + (szSystemStatus (array char 129)) + (iMaxSockets (unsigned 16)) + (iMaxUdpDg (unsigned 16)) + (lpVendorInfo sb-alien:c-string))) (sb-alien:define-alien-type nil (struct s_un_byte - (s_b1 (unsigned 8)) - (s_b2 (unsigned 8)) - (s_b3 (unsigned 8)) - (s_b4 (unsigned 8)))) + (s_b1 (unsigned 8)) + (s_b2 (unsigned 8)) + (s_b3 (unsigned 8)) + (s_b4 (unsigned 8)))) (sb-alien:define-alien-type nil (struct s_un_wide - (s_w1 (unsigned 16)) - (s_w2 (unsigned 16)))) + (s_w1 (unsigned 16)) + (s_w2 (unsigned 16)))) (sb-alien:define-alien-type nil (union s_union - (s_un_b (struct s_un_byte)) - (s_un_w (struct s_un_wide)) - (s_addr (unsigned 32)))) + (s_un_b (struct s_un_byte)) + (s_un_w (struct s_un_wide)) + (s_addr (unsigned 32)))) (sb-alien:define-alien-type nil (struct in_addr - (s_union (union s_union)))) + (s_union (union s_union)))) (sb-alien:define-alien-type nil (struct sockaddr_in - (sin_family (signed 16)) - (sin_port (array (unsigned 8) 2)) - (sin_addr (array (unsigned 8) 4)) - (sin_zero (array char 8)))) + (sin_family (signed 16)) + (sin_port (array (unsigned 8) 2)) + (sin_addr (array (unsigned 8) 4)) + (sin_zero (array char 8)))) (defconstant size-of-sockaddr-in 16) @@ -59,49 +59,49 @@ (sb-alien:define-alien-type nil (struct sockaddr - (sa_family (unsigned 16)) - (sa_data (array char 14)))) + (sa_family (unsigned 16)) + (sa_data (array char 14)))) (sb-alien:define-alien-type nil (struct hostent - (h_name sb-alien:c-string) - (h_aliases (* sb-alien:c-string)) - (h_addrtype sb-alien:short) - (h_length sb-alien:short) - (h_addr_list (* (* (unsigned 8)))))) + (h_name sb-alien:c-string) + (h_aliases (* sb-alien:c-string)) + (h_addrtype sb-alien:short) + (h_length sb-alien:short) + (h_addr_list (* (* (unsigned 8)))))) (sb-alien:define-alien-type nil (struct protoent - (pname sb-alien:c-string) - (p_aliases (* sb-alien:c-string)) - (p_proto (signed 16)))) + (pname sb-alien:c-string) + (p_aliases (* sb-alien:c-string)) + (p_proto (signed 16)))) (sb-alien:define-alien-type socklen-t - (unsigned 32)) + (unsigned 32)) ;;; these are all non-HANDLE using, so are safe to have here (sb-alien:define-alien-routine "gethostbyaddr" (struct hostent) - (addr sb-alien:c-string) - (len int) - (type int)) + (addr sb-alien:c-string) + (len int) + (type int)) (sb-alien:define-alien-routine "gethostbyname" (struct hostent) - (addr sb-alien:c-string)) + (addr sb-alien:c-string)) (sb-alien:define-alien-routine "getservbyport" (struct servent) - (port int) - (proto sb-alien:c-string)) + (port int) + (proto sb-alien:c-string)) (sb-alien:define-alien-routine "getservbyname" (struct servent) - (name sb-alien:c-string) - (proto sb-alien:c-string)) + (name sb-alien:c-string) + (proto sb-alien:c-string)) (sb-alien:define-alien-routine "getprotobynumber" (struct protoent) - (number int)) + (number int)) (sb-alien:define-alien-routine "getprotobyname" (struct protoent) - (name sb-alien:c-string)) + (name sb-alien:c-string)) ;;; these are the alien references to the ;;; winsock calls @@ -141,50 +141,50 @@ (addrlen int :in-out)) (sb-alien:define-alien-routine "recv" int - (s int) - (buf (* t)) - (len int) - (flags int)) + (s int) + (buf (* t)) + (len int) + (flags int)) (sb-alien:define-alien-routine "recvfrom" int - (s int) - (buf (* t)) - (len int) - (flags int) - (from (* (struct sockint::sockaddr_in))) - (fromlen (* sockint::socklen-t))) + (s int) + (buf (* t)) + (len int) + (flags int) + (from (* (struct sockint::sockaddr_in))) + (fromlen (* sockint::socklen-t))) (sb-alien:define-alien-routine ("closesocket" close) int - (s int)) + (s int)) (sb-alien:define-alien-routine "connect" int - (s int) - (name (* (struct sockint::sockaddr_in))) - (namelen int)) + (s int) + (name (* (struct sockint::sockaddr_in))) + (namelen int)) (sb-alien:define-alien-routine "getpeername" int - (s int) - (name (* (struct sockint::sockaddr_in))) - (namelen int :in-out)) + (s int) + (name (* (struct sockint::sockaddr_in))) + (namelen int :in-out)) (sb-alien:define-alien-routine "getsockopt" int - (s int) - (level int) - (optname int) - (optval sb-alien:c-string) - (optlen int :in-out)) + (s int) + (level int) + (optname int) + (optval sb-alien:c-string) + (optlen int :in-out)) (sb-alien:define-alien-routine ("ioctlsocket" ioctl) int - (s int) - (cmd int) - (argp (unsigned 32) :in-out)) + (s int) + (cmd int) + (argp (unsigned 32) :in-out)) (sb-alien:define-alien-routine "setsockopt" int - (s int) - (level int) - (optname int) - (optval (* t)) - (optlen int)) + (s int) + (level int) + (optname int) + (optval (* t)) + (optlen int)) ;;;; we are now going back to the normal sockint @@ -194,15 +194,15 @@ (in-package :sockint) (sb-alien:define-alien-routine ("_get_osfhandle" fd->handle) sb-alien:long - (fd int)) + (fd int)) (sb-alien:define-alien-routine ("_open_osfhandle" handle->fd) int - (osfhandle int) - (flags int)) + (osfhandle int) + (flags int)) (defun socket (af type proto) (let* ((handle (win32sockint::wsa-socket af type proto nil 0 0)) - (fd (handle->fd handle 0))) + (fd (handle->fd handle 0))) fd)) (defun bind (fd &rest options) @@ -247,7 +247,7 @@ (defmacro with-in-addr (name init &rest body) (declare (ignore init)) `(with-alien ((,name (struct in_addr))) - ,@body)) + ,@body)) (defun in-addr-addr (addr) (sb-alien:slot (sb-alien:slot addr 's_union) 's_addr)) diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 05f29b1..273e758 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -563,13 +563,13 @@ (pathname (sb!unix:uid-homedir (sb!unix:unix-getuid))) #!+win32 (pathname (if (posix-getenv "HOME") - (let* ((path (posix-getenv "HOME")) + (let* ((path (posix-getenv "HOME")) (last-char (char path (1- (length path))))) - (if (or (char= last-char #\/) - (char= last-char #\\)) - path - (concatenate 'string path "/"))) - (sb!win32::get-folder-path 40)))) ;;SB-WIN32::CSIDL_PROFILE + (if (or (char= last-char #\/) + (char= last-char #\\)) + path + (concatenate 'string path "/"))) + (sb!win32::get-folder-path 40)))) ;;SB-WIN32::CSIDL_PROFILE (defun file-write-date (file) #!+sb-doc diff --git a/src/code/pred.lisp b/src/code/pred.lisp index 93299dd..0d34b48 100644 --- a/src/code/pred.lisp +++ b/src/code/pred.lisp @@ -21,7 +21,8 @@ (defun vector-t-p (x) (or (simple-vector-p x) (and (complex-vector-p x) - (simple-vector-p (%array-data-vector x))))) + (do ((data (%array-data-vector x) (%array-data-vector data))) + ((not (array-header-p data)) (simple-vector-p data)))))) ;;;; primitive predicates. These must be supported directly by the ;;;; compiler. diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 9425173..38a6f0f 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -803,25 +803,25 @@ colon-separated list of pathnames SEARCH-PATH" :if-exists if-error-exists)) (with-c-strvec (args-vec simple-args) (let ((iwait (if wait 1 0))) - (declare (type fixnum iwait)) - (let ((child-pid - (without-gcing - (spawn pfile args-vec - stdin stdout stderr - iwait)))) - (when (< child-pid 0) - (error "couldn't spawn program: ~A" - (strerror))) - (setf proc - (if wait - nil - (make-process :pid child-pid - :%status :running - :input input-stream - :output output-stream - :error error-stream - :status-hook status-hook - :cookie cookie))))))))))) + (declare (type fixnum iwait)) + (let ((child-pid + (without-gcing + (spawn pfile args-vec + stdin stdout stderr + iwait)))) + (when (< child-pid 0) + (error "couldn't spawn program: ~A" + (strerror))) + (setf proc + (if wait + nil + (make-process :pid child-pid + :%status :running + :input input-stream + :output output-stream + :error error-stream + :status-hook status-hook + :cookie cookie))))))))))) proc)) ;;; Install a handler for any input that shows up on the file @@ -858,10 +858,10 @@ colon-separated list of pathnames SEARCH-PATH" (sb-unix:unix-read descriptor (alien-sap buf) 256) - (cond (#-win32(or (and (null count) - (eql errno sb-unix:eio)) - (eql count 0)) - #+win32(<= count 0) + (cond (#-win32(or (and (null count) + (eql errno sb-unix:eio)) + (eql count 0)) + #+win32(<= count 0) (sb-sys:remove-fd-handler handler) (setf handler nil) (decf (car cookie)) @@ -899,7 +899,7 @@ colon-separated list of pathnames SEARCH-PATH" (multiple-value-bind (fd errno) (sb-unix:unix-open #-win32 #.(coerce "/dev/null" 'base-string) - #+win32 #.(coerce "nul" 'base-string) + #+win32 #.(coerce "nul" 'base-string) (case direction (:input sb-unix:o_rdonly) (:output sb-unix:o_wronly) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index db36cfb..11bb423 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -491,11 +491,11 @@ steppers to maintain contextual information.") "sbclrc") "/etc/sbclrc") #!+win32 (probe-init-files sysinit - (init-file-name (posix-getenv "SBCL_HOME") + (init-file-name (posix-getenv "SBCL_HOME") "sbclrc") - (concatenate 'string - (sb!win32::get-folder-path 35) ;;SB-WIN32::CSIDL_COMMON_APPDATA - "\\sbcl\\sbclrc"))) + (concatenate 'string + (sb!win32::get-folder-path 35) ;;SB-WIN32::CSIDL_COMMON_APPDATA + "\\sbcl\\sbclrc"))) (userinit-truename #!-win32 (probe-init-files userinit diff --git a/src/code/unix.lisp b/src/code/unix.lisp index 8312381..d6290d8 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -325,7 +325,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (cast fds (* int)) size mode)) #!+win32(defun unix-pipe () (with-alien ((fds (array int 2))) - (msvcrt-raw-pipe fds 256 o_binary))) + (msvcrt-raw-pipe fds 256 o_binary))) ;; Windows mkdir() doesn't take the mode argument. It's cdecl, so we could ;; actually call it passing the mode argument, but some sharp-eyed reader diff --git a/src/code/win32.lisp b/src/code/win32.lisp index 8b055ea..e4152a8 100644 --- a/src/code/win32.lisp +++ b/src/code/win32.lisp @@ -460,17 +460,17 @@ (declare (type simple-string name)) (let ((name-length (length name))) (with-alien ((aname (* tchar) (make-alien tchar (1+ name-length))) - (aenv (* tchar) (make-alien tchar default-environment-length)) - (afunc (function dword (* tchar) (* tchar) dword) - :extern #!-sb-unicode "GetEnvironmentVariableA@12" - #!+sb-unicode "GetEnvironmentVariableW@12")) - (dotimes (i name-length) (setf (deref aname i) (char-code (aref name i)))) - (setf (deref aname name-length) 0) - (let ((ret (alien-funcall afunc aname aenv default-environment-length))) - (when (> ret default-environment-length) - (free-alien aenv) - (setf aenv (make-alien tchar ret)) - (alien-funcall afunc aname aenv ret)) - (if (> ret 0) - (ucs2->string&free aenv ret) - nil))))) + (aenv (* tchar) (make-alien tchar default-environment-length)) + (afunc (function dword (* tchar) (* tchar) dword) + :extern #!-sb-unicode "GetEnvironmentVariableA@12" + #!+sb-unicode "GetEnvironmentVariableW@12")) + (dotimes (i name-length) (setf (deref aname i) (char-code (aref name i)))) + (setf (deref aname name-length) 0) + (let ((ret (alien-funcall afunc aname aenv default-environment-length))) + (when (> ret default-environment-length) + (free-alien aenv) + (setf aenv (make-alien tchar ret)) + (alien-funcall afunc aname aenv ret)) + (if (> ret 0) + (ucs2->string&free aenv ret) + nil))))) diff --git a/src/runtime/run-program.c b/src/runtime/run-program.c index feb8d8d..76f39b9 100644 --- a/src/runtime/run-program.c +++ b/src/runtime/run-program.c @@ -181,10 +181,10 @@ HANDLE spawn ( } else { wait_mode = P_WAIT; } - + /* Spawn process given on the command line*/ hProcess = (HANDLE) spawnvp ( wait_mode, program, argv ); - + /* Now that the process is launched, replace the original * in/out/err handles */ if ( _dup2 ( fdOut, out ) != 0 ) return (HANDLE)-1; diff --git a/tests/vector.impure.lisp b/tests/vector.impure.lisp new file mode 100644 index 0000000..2e40b3a --- /dev/null +++ b/tests/vector.impure.lisp @@ -0,0 +1,79 @@ +;;;; 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. + +(cl:in-package "CL-USER") + +;;; test case from Utz-Uwe Haus +(defstruct some-struct + (a 0 :type integer)) +(defun foo (m) + (declare (type (vector some-struct) m)) + m) +(defun bar (m) + (declare (type (vector some-struct) m)) + (let* ((subarray (make-array (- (length m) 1) + :element-type 'some-struct + :displaced-to m :displaced-index-offset 1))) + (foo subarray))) +(defvar *a-foo* (make-some-struct)) +(defvar *a-foo-vec* + (make-array 2 :element-type 'some-struct :adjustable t + :initial-contents (list *a-foo* *a-foo*))) +(assert (typep (bar *a-foo-vec*) '(vector some-struct))) + +;;; some extra sanity checks +(compile (defun compiled-vector-t-p (x) (typep x '(vector t)))) +(compile (defun compiled-simple-vector-p (x) (typep x 'simple-vector))) +(declaim (notinline opaque-identity)) +(defun opaque-identity (x) x) +(defun evaluated-vector-t-p (x) (typep x (opaque-identity '(vector t)))) +(defun evaluated-simple-vector-p (x) + (typep x (opaque-identity 'simple-vector))) + +(defvar *simple-vector* (vector 1 2)) +(defvar *adjustable-vector-t* (make-array 2 :adjustable t)) +(defvar *adjustable-array* (make-array '(2 2) :adjustable t)) +(defvar *vector-with-fill-pointer* (make-array 2 :fill-pointer t)) +(defvar *vector-displaced-to-simple-vector* + (make-array 1 :displaced-to *simple-vector* :displaced-index-offset 1)) +(defvar *vector-displaced-to-adjustable-vector-t* + (make-array 1 :displaced-to *adjustable-vector-t* :displaced-index-offset 1)) +(defvar *vector-displaced-to-adjustable-array* + (make-array 1 :displaced-to *adjustable-array* :displaced-index-offset 3)) +(defvar *vector-displaced-to-vector-with-fill-pointer* + (make-array 1 :displaced-to *vector-with-fill-pointer* + :displaced-index-offset 1)) +(defvar *array-displaced-to-simple-vector* + (make-array '(1 1) :displaced-to *simple-vector* + :displaced-index-offset 0)) +(defvar *array-displaced-to-adjustable-vector-t* + (make-array '(1 1) :displaced-to *adjustable-vector-t* + :displaced-index-offset 1)) +(defvar *simple-array* (make-array '(1 1))) + +(macrolet + ((frob (object simple-vector-p vector-t-p) + `(progn + (assert (eq (compiled-vector-t-p ,object) ,vector-t-p)) + (assert (eq (compiled-simple-vector-p ,object) ,simple-vector-p)) + (assert (eq (evaluated-vector-t-p ,object) ,vector-t-p)) + (assert (eq (evaluated-simple-vector-p ,object) ,simple-vector-p))))) + (frob *simple-vector* t t) + (frob *adjustable-vector-t* nil t) + (frob *adjustable-array* nil nil) + (frob *vector-with-fill-pointer* nil t) + (frob *vector-displaced-to-simple-vector* nil t) + (frob *vector-displaced-to-adjustable-vector-t* nil t) + (frob *vector-displaced-to-adjustable-array* nil t) + (frob *vector-displaced-to-vector-with-fill-pointer* nil t) + (frob *array-displaced-to-simple-vector* nil nil) + (frob *array-displaced-to-adjustable-vector-t* nil nil) + (frob *simple-array* nil nil)) diff --git a/version.lisp-expr b/version.lisp-expr index 6333f6b..4a43654 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.11.15" +"0.9.11.16" -- 1.7.10.4