[Openmcl-cvs-notifications] r10515 - in /trunk/source/level-1: l1-sockets.lisp linux-files.lisp
gb at clozure.com
gb at clozure.com
Thu Aug 21 06:51:47 EDT 2008
Author: gb
Date: Thu Aug 21 06:51:47 2008
New Revision: 10515
Log:
Replace syscall with int-errno call. See what breaks ...
Modified:
trunk/source/level-1/l1-sockets.lisp
trunk/source/level-1/linux-files.lisp
Modified: trunk/source/level-1/l1-sockets.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-sockets.lisp (original)
+++ trunk/source/level-1/l1-sockets.lisp Thu Aug 21 06:51:47 2008
@@ -147,20 +147,7 @@
"SOCKET-ERROR-SITUATION"
"WITH-OPEN-SOCKET"))
=
-(eval-when (:compile-toplevel :execute)
- #+linuxppc-target
- (require "PPC-LINUX-SYSCALLS")
- #+linuxx8664-target
- (require "X8664-LINUX-SYSCALLS")
- #+darwinppc-target
- (require "DARWINPPC-SYSCALLS")
- #+darwinx8664-target
- (require "DARWINX8664-SYSCALLS")
- #+freebsdx8664-target
- (require "X8664-FREEBSD-SYSCALLS")
- #+solarisx8664-target
- (require "X8664-SOLARIS-SYSCALLS")
- )
+
=
(define-condition socket-error (simple-stream-error)
((code :initarg :code :reader socket-error-code)
@@ -1207,16 +1194,7 @@
))))))
=
(defun c_socket_1 (domain type protocol)
- #-(or linuxppc-target solaris-target)
- (syscall syscalls::socket domain type protocol)
- #+linuxppc-target
- (rlet ((params (:array :unsigned-long 3)))
- (setf (paref params (:* :unsigned-long) 0) domain
- (paref params (:* :unsigned-long) 1) type
- (paref params (:* :unsigned-long) 2) protocol)
- (syscall syscalls::socketcall 1 params))
- #+solaris-target
- (syscall syscalls::so_socket domain type protocol +null-ptr+ #$SOV_DEFAU=
LT))
+ (int-errno-call (#_socket domain type protocol)))
=
(defun c_socket (domain type protocol)
(let* ((fd (c_socket_1 domain type protocol)))
@@ -1262,25 +1240,7 @@
=
=
(defun c_bind (sockfd sockaddr addrlen)
- #-linuxppc-target
- (progn
- #+(or darwin-target freebsd-target)
- (setf (pref sockaddr :sockaddr_in.sin_len) addrlen)
- (syscall syscalls::bind sockfd sockaddr addrlen))
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 12))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 4) sockaddr
- (%get-long params 8) addrlen)
- (syscall syscalls::socketcall 2 params))
- #+ppc64-target
- (%stack-block ((params 24))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%get-ptr params 8) sockaddr
- (%%get-unsigned-longlong params 16) addrlen)
- (syscall syscalls::socketcall 2 params))))
+ (int-errno-call (#_bind sockfd sockaddr addrlen)))
=
=
;;; If attempts to connnect are interrupted, we basically have to
@@ -1292,23 +1252,7 @@
(unwind-protect
(progn
(fd-set-flags sockfd (logior flags #$O_NONBLOCK))
- (let* ((err =
- #-linuxppc-target
- (syscall syscalls::connect sockfd addr len)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 12))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 4) addr
- (%get-long params 8) len)
- (syscall syscalls::socketcall 3 params))
- #+ppc64-target
- (%stack-block ((params 24))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%get-ptr params 8) addr
- (%%get-unsigned-longlong params 16) len)
- (syscall syscalls::socketcall 3 params)))))
+ (let* ((err (int-errno-call (#_connect sockfd addr len))))
(cond ((or (eql err (- #$EINPROGRESS)) (eql err (- #$EINTR)))
(if (process-output-wait sockfd timeout-in-millisecond=
s)
(- (int-getsockopt sockfd #$SOL_SOCKET #$SO_ERROR))
@@ -1317,259 +1261,42 @@
(fd-set-flags sockfd flags))))
=
(defun c_listen (sockfd backlog)
- #-linuxppc-target
- (syscall syscalls::listen sockfd backlog)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 8))
- (setf (%get-long params 0) sockfd
- (%get-long params 4) backlog)
- (syscall syscalls::socketcall 4 params))
- #+ppc64-target
- (%stack-block ((params 16))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%%get-unsigned-longlong params 8) backlog)
- (syscall syscalls::socketcall 4 params))))
+ (int-errno-call (#_listen sockfd backlog)))
=
(defun c_accept (sockfd addrp addrlenp)
- (ignoring-eintr =
- #-linuxppc-target
- (syscall syscalls::accept sockfd addrp addrlenp)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 12))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 4) addrp
- (%get-ptr params 8) addrlenp)
- (syscall syscalls::socketcall 5 params))
- #+ppc64-target
- (%stack-block ((params 24))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%get-ptr params 8) addrp
- (%get-ptr params 16) addrlenp)
- (syscall syscalls::socketcall 5 params)))))
+ (ignoring-eintr
+ (int-errno-call (#_accept sockfd addrp addrlenp))))
=
(defun c_getsockname (sockfd addrp addrlenp)
- #-linuxppc-target
- (syscall syscalls::getsockname sockfd addrp addrlenp)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 12))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 4) addrp
- (%get-ptr params 8) addrlenp)
- (syscall syscalls::socketcall 6 params))
- #+ppc64-target
- (%stack-block ((params 24))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%get-ptr params 8) addrp
- (%get-ptr params 16) addrlenp)
- (syscall syscalls::socketcall 6 params))))
+ (int-errno-call (#_getsockname sockfd addrp addrlenp)))
=
(defun c_getpeername (sockfd addrp addrlenp)
- #-linuxppc-target
- (syscall syscalls::getpeername sockfd addrp addrlenp)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 12))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 4) addrp
- (%get-ptr params 8) addrlenp)
- (syscall syscalls::socketcall 7 params))
- #+ppc64-target
- (%stack-block ((params 24))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%get-ptr params 8) addrp
- (%get-ptr params 16) addrlenp)
- (syscall syscalls::socketcall 7 params))))
+ (int-errno-call (#_getpeername sockfd addrp addrlenp)))
=
(defun c_socketpair (domain type protocol socketsptr)
- #-(or linuxppc-target solaris-target)
- (syscall syscalls::socketpair domain type protocol socketsptr)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 16))
- (setf (%get-long params 0) domain
- (%get-long params 4) type
- (%get-long params 8) protocol
- (%get-ptr params 12) socketsptr)
- (syscall syscalls::socketcall 8 params))
- #+ppc64-target
- (%stack-block ((params 32))
- (setf (%%get-unsigned-longlong params 0) domain
- (%%get-unsigned-longlong params 8) type
- (%%get-unsigned-longlong params 16) protocol
- (%get-ptr params 24) socketsptr)
- (syscall syscalls::socketcall 8 params)))
- #+solaris-target
- (let* ((fd1 (syscall syscalls::so_socket domain type protocol +null-ptr+=
#$SOV_DEFAULT)))
- (if (>=3D fd1 0)
- (let* ((fd2 (syscall syscalls::so_socket domain type protocol +null-=
ptr+ #$SOV_DEFAULT)))
- (if (>=3D fd2 0)
- (progn
- (setf (paref socketsptr (:* :int) 0) fd1
- (paref socketsptr (:* :int) 1) fd2)
- (let* ((res (syscall syscalls::so_socketpair socketsptr)))
- (when (< res 0)
- (fd-close fd1)
- (fd-close fd2))
- res))
- (progn
- (fd-close fd1)
- fd2)))
- fd1)))
-
-
+ (int-errno-call (#_socketpair domain type protocol socketsptr)))
=
=
(defun c_sendto (sockfd msgptr len flags addrp addrlen)
- #-linuxppc-target
- (syscall syscalls::sendto sockfd msgptr len flags addrp addrlen)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 24))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 4) msgptr
- (%get-long params 8) len
- (%get-long params 12) flags
- (%get-ptr params 16) addrp
- (%get-long params 20) addrlen)
- (syscall syscalls::socketcall 11 params))
- #+ppc64-target
- (%stack-block ((params 48))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%get-ptr params 8) msgptr
- (%%get-unsigned-longlong params 16) len
- (%%get-unsigned-longlong params 24) flags
- (%get-ptr params 32) addrp
- (%%get-unsigned-longlong params 40) addrlen)
- (syscall syscalls::socketcall 11 params))))
+ (int-errno-call (#_sendto sockfd msgptr len flags addrp addrlen)))
=
(defun c_recvfrom (sockfd bufptr len flags addrp addrlenp)
- #-linuxppc-target
- (syscall syscalls::recvfrom sockfd bufptr len flags addrp addrlenp)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 24))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 4) bufptr
- (%get-long params 8) len
- (%get-long params 12) flags
- (%get-ptr params 16) addrp
- (%get-ptr params 20) addrlenp)
- (syscall syscalls::socketcall 12 params))
- #+ppc64-target
- (%stack-block ((params 48))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 8) bufptr
- (%get-long params 16) len
- (%get-long params 24) flags
- (%get-ptr params 32) addrp
- (%get-ptr params 40) addrlenp)
- (syscall syscalls::socketcall 12 params))))
+ (int-errno-call (#_recvfrom sockfd bufptr len flags addrp addrlenp)))
=
(defun c_shutdown (sockfd how)
- #-linuxppc-target
- (syscall syscalls::shutdown sockfd how)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 8))
- (setf (%get-long params 0) sockfd
- (%get-long params 4) how)
- (syscall syscalls::socketcall 13 params))
- #+ppc64-target
- (%stack-block ((params 16))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%%get-unsigned-longlong params 8) how)
- (syscall syscalls::socketcall 13 params))))
+ (int-errno-call (#_shutdown sockfd how)))
=
(defun c_setsockopt (sockfd level optname optvalp optlen)
- #-linuxppc-target
- (syscall syscalls::setsockopt sockfd level optname optvalp optlen)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 20))
- (setf (%get-long params 0) sockfd
- (%get-long params 4) level
- (%get-long params 8) optname
- (%get-ptr params 12) optvalp
- (%get-long params 16) optlen)
- (syscall syscalls::socketcall 14 params))
- #+ppc64-target
- (%stack-block ((params 40))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%%get-unsigned-longlong params 8) level
- (%%get-unsigned-longlong params 16) optname
- (%get-ptr params 24) optvalp
- (%%get-unsigned-longlong params 32) optlen)
- (syscall syscalls::socketcall 14 params))))
+ (int-errno-call (#_setsockopt sockfd level optname optvalp optlen)))
=
(defun c_getsockopt (sockfd level optname optvalp optlenp)
- #-linuxppc-target
- (syscall syscalls::getsockopt sockfd level optname optvalp optlenp)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 20))
- (setf (%get-long params 0) sockfd
- (%get-long params 4) level
- (%get-long params 8) optname
- (%get-ptr params 12) optvalp
- (%get-ptr params 16) optlenp)
- (syscall syscalls::socketcall 15 params))
- #+ppc64-target
- (%stack-block ((params 40))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%%get-unsigned-longlong params 8) level
- (%%get-unsigned-longlong params 16) optname
- (%get-ptr params 24) optvalp
- (%get-ptr params 32) optlenp)
- (syscall syscalls::socketcall 15 params))))
+ (int-errno-call (#_getsockopt sockfd level optname optvalp optlenp)))
=
(defun c_sendmsg (sockfd msghdrp flags)
- #-linuxppc-target
- (syscall syscalls::sendmsg sockfd msghdrp flags)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 12))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 4) msghdrp
- (%get-long params 8) flags)
- (syscall syscalls::socketcall 16 params))
- #+ppc64-target
- (%stack-block ((params 24))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%get-ptr params 8) msghdrp
- (%%get-unsigned-longlong params 16) flags)
- (syscall syscalls::socketcall 16 params))))
+ (int-errno-call (#_sendmsg sockfd msghdrp flags)))
=
(defun c_recvmsg (sockfd msghdrp flags)
- #-linuxppc-target
- (syscall syscalls::recvmsg sockfd msghdrp flags)
- #+linuxppc-target
- (progn
- #+ppc32-target
- (%stack-block ((params 12))
- (setf (%get-long params 0) sockfd
- (%get-ptr params 4) msghdrp
- (%get-long params 8) flags)
- (syscall syscalls::socketcall 17 params))
- #+ppc64-target
- (%stack-block ((params 24))
- (setf (%%get-unsigned-longlong params 0) sockfd
- (%get-ptr params 8) msghdrp
- (%%get-unsigned-longlong params 16) flags)
- (syscall syscalls::socketcall 17 params))))
+ (int-errno-call (#_recvmsg sockfd msghdrp flags)))
=0C
;;; Return a list of currently configured interfaces, a la ifconfig.
(defstruct ip-interface
Modified: trunk/source/level-1/linux-files.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/linux-files.lisp (original)
+++ trunk/source/level-1/linux-files.lisp Thu Aug 21 06:51:47 2008
@@ -15,23 +15,6 @@
;;; http://opensource.franz.com/preamble.html
=
(in-package "CCL")
-
-(eval-when (:compile-toplevel :execute)
- #+linuxppc-target
- (require "PPC-LINUX-SYSCALLS")
- #+linuxx8664-target
- (require "X8664-LINUX-SYSCALLS")
- #+darwinppc-target
- (require "DARWINPPC-SYSCALLS")
- #+darwinx8632-target
- (require "DARWINX8632-SYSCALLS")
- #+darwinx8664-target
- (require "DARWINX8664-SYSCALLS")
- #+(and freebsd-target x8664-target)
- (require "X8664-FREEBSD-SYSCALLS")
- #+(and solaris-target x8664-target)
- (require "X8664-SOLARIS-SYSCALLS")
- )
=
=
(defun get-foreign-namestring (pointer)
@@ -209,7 +192,7 @@
=
(defun %chdir (dirname)
(with-filename-cstrs ((dirname dirname))
- (syscall syscalls::chdir dirname)))
+ (int-errno-call (#_chdir dirname))))
=
(defun %mkdir (name mode)
(let* ((name name)
@@ -217,7 +200,7 @@
(when (and (> len 0) (eql (char name (1- len)) #\/))
(setq name (subseq name 0 (1- len))))
(with-filename-cstrs ((name name))
- (syscall syscalls::mkdir name mode))))
+ (int-errno-call (#_mkdir name mode)))))
=
(defun %rmdir (name)
(let* ((last (1- (length name))))
@@ -225,7 +208,7 @@
(when (and (>=3D last 0)
(eql (%get-byte name last) (char-code #\/)))
(setf (%get-byte name last) 0))
- (syscall syscalls::rmdir name))))
+ (int-errno-call (#_rmdir name)))))
=
=
(defun getenv (key)
@@ -250,13 +233,13 @@
"Attempt to change the current user ID (both real and effective);
fails unless the OpenMCL process has super-user privileges or the ID
given is that of the current user."
- (syscall syscalls::setuid uid))
+ (int-errno-call (#_setuid uid)))
=
(defun setgid (uid)
"Attempt to change the current group ID (both real and effective);
fails unless the OpenMCL process has super-user privileges or the ID
given is that of a group to which the current user belongs."
- (syscall syscalls::setgid uid))
+ (int-errno-call (#_setgid uid)))
=
=
;;; On Linux, "stat" & friends are implemented in terms of deeper,
@@ -290,7 +273,7 @@
#+linux-target
(#_ __xstat #$_STAT_VER_LINUX cname stat)
#-linux-target
- (syscall syscalls::stat cname stat)
+ (#_stat cname stat)
stat)))
=
(defun %%fstat (fd stat)
@@ -298,7 +281,7 @@
#+linux-target
(#_ __fxstat #$_STAT_VER_LINUX fd stat)
#-linux-target
- (syscall syscalls::fstat fd stat)
+ (#_fstat fd stat)
stat))
=
(defun %%lstat (name stat)
@@ -307,7 +290,7 @@
#+linux-target
(#_ __lxstat #$_STAT_VER_LINUX cname stat)
#-linux-target
- (syscall syscalls::lstat cname stat)
+ (#_lstat cname stat)
stat)))
=
=
@@ -385,7 +368,7 @@
#+linux-target
(defun %uname (idx)
(%stack-block ((buf (* #$_UTSNAME_LENGTH 6))) =
- (%uts-string (syscall syscalls::uname buf) idx buf)))
+ (%uts-string (#_uname buf) idx buf)))
=
#+darwin-target
(defun %uname (idx)
@@ -403,27 +386,16 @@
(%uts-string (#_uname buf) idx buf)))
=
(defun fd-dup (fd)
- (syscall syscalls::dup fd))
+ (int-errno-call (#_dup fd)))
=
(defun fd-fsync (fd)
- #-solaris-target
- (syscall syscalls::fsync fd)
- #+solaris-target
- (syscall syscalls::fdsync fd #$FSYNC))
+ (int-errno-call (#_fsync fd)))
=
(defun fd-get-flags (fd)
- (let* ((result (#_fcntl fd #$F_GETFL)))
- (declare (fixnum result))
- (if (< result 0)
- (%get-errno)
- result)))
+ (int-errno-call (#_fcntl fd #$F_GETFL)))
=
(defun fd-set-flags (fd new)
- (let* ((result (#_fcntl fd #$F_SETFL :int new)))
- (declare (fixnum result))
- (if (< result 0)
- (%get-errno)
- result)))
+ (int-errno-call (#_fcntl fd #$F_SETFL :int new)))
=
(defun fd-set-flag (fd mask)
(let* ((old (fd-get-flags fd)))
@@ -513,11 +485,7 @@
=
=
(defun %%rusage (usage &optional (who #$RUSAGE_SELF))
- #-solaris-target
- (syscall syscalls::getrusage who usage)
- #+solaris-target
- (#_getrusage who usage)
- )
+ (int-errno-call (#_getrusage who usage)))
=
=
=
@@ -578,11 +546,11 @@
=
(defun getpid ()
"Return the ID of the OpenMCL OS process."
- (syscall syscalls::getpid))
+ (int-errno-call (#_getpid)))
=
(defun getuid ()
"Return the (real) user ID of the current user."
- (syscall syscalls::getuid))
+ (int-errno-call (#_getuid)))
=
(defun get-user-home-dir (userid)
"Look up and return the defined home directory of the user identified
@@ -611,7 +579,7 @@
=
(defun %delete-file (name)
(with-cstrs ((n name))
- (syscall syscalls::unlink n)))
+ (int-errno-call (#_unlink n))))
=
(defun os-command (string)
"Invoke the Posix function system(), which invokes the user's default
@@ -747,13 +715,6 @@
(declare (fixnum fd))
(#_close fd)))
=
-
-
-
-
-
-;;; I believe that the Darwin/FreeBSD syscall infterface is rather ... odd.
-;;; Use libc's interface.
(defun pipe ()
;; (rlet ((filedes (:array :int 2)))
(%stack-block ((filedes 8))
@@ -1152,10 +1113,10 @@
it would only be useful to call this function if the EXTERNAL-PROCESS was
created with :WAIT NIL.) Return T if successful; signal an error otherwise=
."
(require-type proc 'external-process)
- (let* ((pid (external-process-pid proc))
- (error (syscall syscalls::kill pid signal)))
- (or (eql error 0)
- (%errno-disp error))))
+ (let* ((pid (external-process-pid proc)))
+ (when pid
+ (int-errno-call (#_kill pid signal)))))
+
=
;;; EOF on a TTY is transient, but I'm less sure of other cases.
(defun eof-transient-p (fd)
More information about the Openmcl-cvs-notifications
mailing list