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.
(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)))
(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)
#-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)
(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
(eval-when (:load-toplevel :compile-toplevel :execute)
-#+win32
+#+win32
(defvar *wsa-startup-call*
(sockint::wsa-startup (sockint::make-wsa-version 2 2)))
(defconstant EPERM 1)\r
\r
;; basic socket errors\r
-(defconstant WSABASEERR 10000)\r
+(defconstant WSABASEERR 10000)\r
(defconstant EINTR (+ WSABASEERR 4))\r
(defconstant EBADF (+ WSABASEERR 9))\r
(defconstant EACCES (+ WSABASEERR 13))\r
\r
(sb-alien:define-alien-type nil\r
(struct WSADATA\r
- (wVersion (unsigned 16))\r
- (wHighVersion (unsigned 16))\r
- (szDescription (array char 257))\r
- (szSystemStatus (array char 129))\r
- (iMaxSockets (unsigned 16))\r
- (iMaxUdpDg (unsigned 16))\r
- (lpVendorInfo sb-alien:c-string)))\r
+ (wVersion (unsigned 16))\r
+ (wHighVersion (unsigned 16))\r
+ (szDescription (array char 257))\r
+ (szSystemStatus (array char 129))\r
+ (iMaxSockets (unsigned 16))\r
+ (iMaxUdpDg (unsigned 16))\r
+ (lpVendorInfo sb-alien:c-string)))\r
\r
(sb-alien:define-alien-type nil\r
(struct s_un_byte\r
- (s_b1 (unsigned 8))\r
- (s_b2 (unsigned 8))\r
- (s_b3 (unsigned 8))\r
- (s_b4 (unsigned 8))))\r
+ (s_b1 (unsigned 8))\r
+ (s_b2 (unsigned 8))\r
+ (s_b3 (unsigned 8))\r
+ (s_b4 (unsigned 8))))\r
\r
(sb-alien:define-alien-type nil\r
(struct s_un_wide\r
- (s_w1 (unsigned 16))\r
- (s_w2 (unsigned 16))))\r
+ (s_w1 (unsigned 16))\r
+ (s_w2 (unsigned 16))))\r
\r
(sb-alien:define-alien-type nil\r
(union s_union\r
- (s_un_b (struct s_un_byte))\r
- (s_un_w (struct s_un_wide))\r
- (s_addr (unsigned 32))))\r
+ (s_un_b (struct s_un_byte))\r
+ (s_un_w (struct s_un_wide))\r
+ (s_addr (unsigned 32))))\r
\r
(sb-alien:define-alien-type nil\r
(struct in_addr\r
- (s_union (union s_union))))\r
+ (s_union (union s_union))))\r
\r
(sb-alien:define-alien-type nil\r
(struct sockaddr_in\r
- (sin_family (signed 16))\r
- (sin_port (array (unsigned 8) 2))\r
- (sin_addr (array (unsigned 8) 4))\r
- (sin_zero (array char 8))))\r
+ (sin_family (signed 16))\r
+ (sin_port (array (unsigned 8) 2))\r
+ (sin_addr (array (unsigned 8) 4))\r
+ (sin_zero (array char 8))))\r
\r
(defconstant size-of-sockaddr-in 16)\r
\r
\r
(sb-alien:define-alien-type nil\r
(struct sockaddr\r
- (sa_family (unsigned 16))\r
- (sa_data (array char 14))))\r
+ (sa_family (unsigned 16))\r
+ (sa_data (array char 14))))\r
\r
(sb-alien:define-alien-type nil\r
(struct hostent\r
- (h_name sb-alien:c-string)\r
- (h_aliases (* sb-alien:c-string))\r
- (h_addrtype sb-alien:short)\r
- (h_length sb-alien:short)\r
- (h_addr_list (* (* (unsigned 8))))))\r
+ (h_name sb-alien:c-string)\r
+ (h_aliases (* sb-alien:c-string))\r
+ (h_addrtype sb-alien:short)\r
+ (h_length sb-alien:short)\r
+ (h_addr_list (* (* (unsigned 8))))))\r
\r
(sb-alien:define-alien-type nil\r
(struct protoent\r
- (pname sb-alien:c-string)\r
- (p_aliases (* sb-alien:c-string))\r
- (p_proto (signed 16))))\r
+ (pname sb-alien:c-string)\r
+ (p_aliases (* sb-alien:c-string))\r
+ (p_proto (signed 16))))\r
\r
(sb-alien:define-alien-type socklen-t\r
- (unsigned 32))\r
+ (unsigned 32))\r
\r
\r
;;; these are all non-HANDLE using, so are safe to have here\r
(sb-alien:define-alien-routine "gethostbyaddr" (struct hostent)\r
- (addr sb-alien:c-string)\r
- (len int)\r
- (type int))\r
+ (addr sb-alien:c-string)\r
+ (len int)\r
+ (type int))\r
\r
(sb-alien:define-alien-routine "gethostbyname" (struct hostent)\r
- (addr sb-alien:c-string))\r
+ (addr sb-alien:c-string))\r
\r
(sb-alien:define-alien-routine "getservbyport" (struct servent)\r
- (port int)\r
- (proto sb-alien:c-string))\r
+ (port int)\r
+ (proto sb-alien:c-string))\r
\r
(sb-alien:define-alien-routine "getservbyname" (struct servent)\r
- (name sb-alien:c-string)\r
- (proto sb-alien:c-string))\r
+ (name sb-alien:c-string)\r
+ (proto sb-alien:c-string))\r
\r
(sb-alien:define-alien-routine "getprotobynumber" (struct protoent)\r
- (number int))\r
+ (number int))\r
\r
(sb-alien:define-alien-routine "getprotobyname" (struct protoent)\r
- (name sb-alien:c-string))\r
+ (name sb-alien:c-string))\r
\r
;;; these are the alien references to the\r
;;; winsock calls\r
(addrlen int :in-out))\r
\r
(sb-alien:define-alien-routine "recv" int\r
- (s int)\r
- (buf (* t))\r
- (len int)\r
- (flags int))\r
+ (s int)\r
+ (buf (* t))\r
+ (len int)\r
+ (flags int))\r
\r
(sb-alien:define-alien-routine "recvfrom" int\r
- (s int)\r
- (buf (* t))\r
- (len int)\r
- (flags int)\r
- (from (* (struct sockint::sockaddr_in)))\r
- (fromlen (* sockint::socklen-t)))\r
+ (s int)\r
+ (buf (* t))\r
+ (len int)\r
+ (flags int)\r
+ (from (* (struct sockint::sockaddr_in)))\r
+ (fromlen (* sockint::socklen-t)))\r
\r
(sb-alien:define-alien-routine ("closesocket" close) int\r
- (s int))\r
+ (s int))\r
\r
(sb-alien:define-alien-routine "connect" int\r
- (s int)\r
- (name (* (struct sockint::sockaddr_in)))\r
- (namelen int))\r
+ (s int)\r
+ (name (* (struct sockint::sockaddr_in)))\r
+ (namelen int))\r
\r
(sb-alien:define-alien-routine "getpeername" int\r
- (s int)\r
- (name (* (struct sockint::sockaddr_in)))\r
- (namelen int :in-out))\r
+ (s int)\r
+ (name (* (struct sockint::sockaddr_in)))\r
+ (namelen int :in-out))\r
\r
(sb-alien:define-alien-routine "getsockopt" int\r
- (s int)\r
- (level int)\r
- (optname int)\r
- (optval sb-alien:c-string)\r
- (optlen int :in-out))\r
+ (s int)\r
+ (level int)\r
+ (optname int)\r
+ (optval sb-alien:c-string)\r
+ (optlen int :in-out))\r
\r
(sb-alien:define-alien-routine ("ioctlsocket" ioctl) int\r
- (s int)\r
- (cmd int)\r
- (argp (unsigned 32) :in-out))\r
+ (s int)\r
+ (cmd int)\r
+ (argp (unsigned 32) :in-out))\r
\r
(sb-alien:define-alien-routine "setsockopt" int\r
- (s int)\r
- (level int)\r
- (optname int)\r
- (optval (* t))\r
- (optlen int))\r
+ (s int)\r
+ (level int)\r
+ (optname int)\r
+ (optval (* t))\r
+ (optlen int))\r
\r
\r
;;;; we are now going back to the normal sockint\r
(in-package :sockint)\r
\r
(sb-alien:define-alien-routine ("_get_osfhandle" fd->handle) sb-alien:long\r
- (fd int))\r
+ (fd int))\r
\r
(sb-alien:define-alien-routine ("_open_osfhandle" handle->fd) int\r
- (osfhandle int)\r
- (flags int))\r
+ (osfhandle int)\r
+ (flags int))\r
\r
(defun socket (af type proto)\r
(let* ((handle (win32sockint::wsa-socket af type proto nil 0 0))\r
- (fd (handle->fd handle 0)))\r
+ (fd (handle->fd handle 0)))\r
fd))\r
\r
(defun bind (fd &rest options)\r
(defmacro with-in-addr (name init &rest body)\r
(declare (ignore init))\r
`(with-alien ((,name (struct in_addr)))\r
- ,@body))\r
+ ,@body))\r
\r
(defun in-addr-addr (addr)\r
(sb-alien:slot (sb-alien:slot addr 's_union) 's_addr))\r
(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
(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))))))
\f
;;;; primitive predicates. These must be supported directly by the
;;;; compiler.
: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
(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))
(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)
"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
(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
(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)))))
} 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;
--- /dev/null
+;;;; 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))
;;; 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"
projects / sbcl.git / commitdiff