[Git][cmucl/cmucl][rtoy-grand-unix-unification] 3 commits: Add more missing things from unix-glibc2.
Raymond Toy
rtoy at common-lisp.net
Sun Oct 18 19:53:29 UTC 2015
Raymond Toy pushed to branch rtoy-grand-unix-unification at cmucl / cmucl
Commits:
91b7fea4 by Raymond Toy at 2015-10-18T00:18:17Z
Add more missing things from unix-glibc2.
In particular, use the 64-bit versions of most functions.
- - - - -
e0835904 by Raymond Toy at 2015-10-18T00:19:24Z
Need to export some symbols for linux.
This allows us to build all of cmucl, but the utilities don't yet
build completely.
- - - - -
dcb8aafc by Raymond Toy at 2015-10-18T12:53:17Z
More changes for linux.
o Add :glibc2 to *features*. (Need to simplify that.)
o Add define-ioctl-command and constants for linux.
- - - - -
2 changed files:
- src/code/exports.lisp
- src/code/unix.lisp
Changes:
=====================================
src/code/exports.lisp
=====================================
--- a/src/code/exports.lisp
+++ b/src/code/exports.lisp
@@ -394,6 +394,9 @@
"LTCHARS"
"D-NAMLEN"
+ ;; run-program.lisp
+ "SGTTYB"
+
;; Other symbols
"BLKCNT-T" "D-INO" "D-OFF" "EADV" "EBADE" "EBADFD" "EBADMSG" "EBADR"
"EBADRQC" "EBADSLT" "EBFONT" "ECHRNG" "ECOMM" "EDEADLOCK" "EDOTDOT"
@@ -402,7 +405,11 @@
"ENOANO" "ENOCSI" "ENODATA" "ENOLCK" "ENOLINK" "ENOMSG" "ENONET" "ENOPKG"
"ENOSR" "ENOSTR" "ENOSYS" "ENOTNAM" "ENOTUNIQ" "EOVERFLOW" "EPROTO"
"EREMCHG" "EREMOTEIO" "ERESTART" "ESRMNT" "ESTALE" "ESTRPIPE" "ETIME"
- "EUCLEAN" "EUNATCH" "EXFULL" "O_NOCTTY" "SIGSTKFLT" "TTY-IUCLC"
+ "EUCLEAN" "EUNATCH" "EXFULL" "O_NOCTTY" "SIGSTKFLT"
+ "SG-FLAGS"
+ "TIOCGETP"
+ "TIOCSETP"
+ "TTY-IUCLC"
"TTY-OCRNL" "TTY-OFDEL" "TTY-OFILL" "TTY-OLCUC" "TTY-ONLRET" "TTY-ONOCR"
"TTY-XCASE" "UNIX-DUP2" "UNIX-GETITIMER" "UNIX-PID" "UNIX-UNAME"
"UTSNAME"
=====================================
src/code/unix.lisp
=====================================
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -17,6 +17,8 @@
(intl:textdomain "cmucl-unix")
(pushnew :unix *features*)
+#+linux
+(pushnew :glibc2 *features*)
;; Check the G_BROKEN_FILENAMES environment variable; if set the encoding
;; is locale-dependent...else use :utf-8 on Unicode Lisps. On 8 bit Lisps
@@ -37,6 +39,8 @@
;;;; Common machine independent structures.
+#+linux
+(defconstant +max-u-long+ 4294967295)
(def-alien-type int64-t (signed 64))
@@ -53,6 +57,9 @@
#+alpha unsigned-int
#-(or alpha netbsd) unsigned-long)
+#+linux
+(def-alien-type ino64-t u-int64-t)
+
(def-alien-type size-t
#-(or linux alpha) long
#+linux unsigned-int
@@ -488,6 +495,7 @@
(defconstant l_incr 1 _N"increment the file pointer")
(defconstant l_xtnd 2 _N"extend the file size")
+#-linux
(defun unix-lseek (fd offset whence)
_N"Unix-lseek accepts a file descriptor and moves the file pointer ahead
a certain offset for that file. Whence can be any of the following:
@@ -501,6 +509,24 @@
(type (integer 0 2) whence))
(off-t-syscall ("lseek" (int off-t int)) fd offset whence))
+#+linux
+(defun unix-lseek (fd offset whence)
+ _N"UNIX-LSEEK accepts a file descriptor and moves the file pointer ahead
+ a certain OFFSET for that file. WHENCE can be any of the following:
+
+ l_set Set the file pointer.
+ l_incr Increment the file pointer.
+ l_xtnd Extend the file size.
+ "
+ (declare (type unix-fd fd)
+ (type (signed-byte 64) offset)
+ (type (integer 0 2) whence))
+ (let ((result (alien-funcall
+ (extern-alien "lseek64" (function off-t int off-t int))
+ fd offset whence)))
+ (if (minusp result)
+ (values nil (unix-errno))
+ (values result 0))))
;;; Unix-mkdir accepts a name and a mode and attempts to create the
;;; corresponding directory with mode mode.
@@ -606,7 +632,7 @@
(declare (type unix-pathname name)
(type unix-file-mode mode))
- (int-syscall (#+solaris "creat64" #-solaris "creat" c-string int)
+ (int-syscall (#+(or linux solaris) "creat64" #-(or linux solaris) "creat" c-string int)
(%name->file name) mode))
;;; Unix-read accepts a file descriptor, a buffer, and the length to read.
@@ -1015,27 +1041,55 @@
(defconstant ,name ,(logior (ash (char-code #\t) 8) cmd))))
#+linux
-(defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
- (declare (ignore arg parm-type))
- `(eval-when (eval load compile)
- (defconstant ,name ,(logior (ash (- (char-code dev) #x20) 8) cmd))))
+(progn
+ (defconstant iocparm-mask #x3fff)
+ (defconstant ioc_void #x00000000)
+ (defconstant ioc_out #x40000000)
+ (defconstant ioc_in #x80000000)
+ (defconstant ioc_inout (logior ioc_in ioc_out)))
+
+#+linux
+(defmacro define-ioctl-command (name dev cmd &optional arg parm-type)
+ _N"Define an ioctl command. If the optional ARG and PARM-TYPE are given
+ then ioctl argument size and direction are included as for ioctls defined
+ by _IO, _IOR, _IOW, or _IOWR. If DEV is a character then the ioctl type
+ is the characters code, else DEV may be an integer giving the type."
+ (let* ((type (if (characterp dev)
+ (char-code dev)
+ dev))
+ (code (logior (ash type 8) cmd)))
+ (when arg
+ (setf code `(logior (ash (logand (alien-size ,arg :bytes) ,iocparm-mask)
+ 16)
+ ,code)))
+ (when parm-type
+ (let ((dir (ecase parm-type
+ (:void ioc_void)
+ (:in ioc_in)
+ (:out ioc_out)
+ (:inout ioc_inout))))
+ (setf code `(logior ,dir ,code))))
+ `(eval-when (eval load compile)
+ (defconstant ,name ,code))))
)
;;; TTY ioctl commands.
-(define-ioctl-command TIOCGETP #\t #-linux 8 #+linux #x81 (struct sgttyb) :out)
-(define-ioctl-command TIOCSETP #\t #-linux 9 #+linux #x82 (struct sgttyb) :in)
-(define-ioctl-command TIOCFLUSH #\t #-linux 16 #+linux #x89 int :in)
-(define-ioctl-command TIOCSETC #\t #-linux 17 #+linux #x84 (struct tchars) :in)
-(define-ioctl-command TIOCGETC #\t #-linux 18 #+linux #x83 (struct tchars) :out)
-(define-ioctl-command TIOCGWINSZ #\t #-hpux 104 #+hpux 107 (struct winsize)
- :out)
-(define-ioctl-command TIOCSWINSZ #\t #-hpux 103 #+hpux 106 (struct winsize)
- :in)
-
-(define-ioctl-command TIOCNOTTY #\t #-linux 113 #+linux #x22 nil :void)
-#-hpux
+#-linux
+(progn
+ (define-ioctl-command TIOCGETP #\t #-linux 8 #+linux #x81 (struct sgttyb) :out)
+ (define-ioctl-command TIOCSETP #\t #-linux 9 #+linux #x82 (struct sgttyb) :in)
+ (define-ioctl-command TIOCFLUSH #\t #-linux 16 #+linux #x89 int :in)
+ (define-ioctl-command TIOCSETC #\t #-linux 17 #+linux #x84 (struct tchars) :in)
+ (define-ioctl-command TIOCGETC #\t #-linux 18 #+linux #x83 (struct tchars) :out)
+ (define-ioctl-command TIOCGWINSZ #\t #-hpux 104 #+hpux 107 (struct winsize)
+ :out)
+ (define-ioctl-command TIOCSWINSZ #\t #-hpux 103 #+hpux 106 (struct winsize)
+ :in)
+
+ (define-ioctl-command TIOCNOTTY #\t #-linux 113 #+linux #x22 nil :void))
+#-(or hpux linux)
(progn
(define-ioctl-command TIOCSLTC #\t #-linux 117 #+linux #x84 (struct ltchars) :in)
(define-ioctl-command TIOCGLTC #\t #-linux 116 #+linux #x85 (struct ltchars) :out)
@@ -1048,9 +1102,19 @@
(define-ioctl-command TIOCSPGRP #\T 29 int :in)
(define-ioctl-command TIOCGPGRP #\T 30 int :out)
(define-ioctl-command TIOCSIGSEND #\t 93 nil))
+#+linux
+(progn
+ (define-ioctl-command TIOCGWINSZ #\T #x13)
+ (define-ioctl-command TIOCSWINSZ #\T #x14)
+ (define-ioctl-command TIOCNOTTY #\T #x22)
+ (define-ioctl-command TIOCSPGRP #\T #x10)
+ (define-ioctl-command TIOCGPGRP #\T #x0F))
;;; File ioctl commands.
+#-linux
(define-ioctl-command FIONREAD #\f #-linux 127 #+linux #x1B int :out)
+#+linux
+(define-ioctl-command FIONREAD #\T #x1B)
(defun unix-ioctl (fd cmd arg)
@@ -1463,7 +1527,8 @@
(when (string= name "")
(setf name "."))
(with-alien ((buf (struct stat)))
- (syscall (#-netbsd "stat" #+netbsd "__stat50" c-string (* (struct stat)))
+ (syscall (#+linux "stat64" #+netbsd "__stat50" #-(or linux netbsd) "stat"
+ c-string (* (struct stat)))
(extract-stat-results buf)
(%name->file name) (addr buf))))
@@ -1472,7 +1537,8 @@
file must be a symbolic link."
(declare (type unix-pathname name))
(with-alien ((buf (struct stat)))
- (syscall (#-netbsd "lstat" #+netbsd "__lstat50" c-string (* (struct stat)))
+ (syscall (#+linux "lstat64" #+netbsd "__lstat50" #-(or linux netbsd) "lstat"
+ c-string (* (struct stat)))
(extract-stat-results buf)
(%name->file name) (addr buf))))
@@ -1481,7 +1547,8 @@
by the file descriptor fd."
(declare (type unix-fd fd))
(with-alien ((buf (struct stat)))
- (syscall (#-netbsd "fstat" #+netbsd "__fstat50" int (* (struct stat)))
+ (syscall (#+linux "fstat64" #+netbsd "__fstat50" #-(or linux netbsd) "fstat"
+ int (* (struct stat)))
(extract-stat-results buf)
fd (addr buf))))
)
@@ -2630,6 +2697,37 @@
:dir (string (cast (slot result 'pw-dir) c-call:c-string))
:shell (string (cast (slot result 'pw-shell) c-call:c-string))))))
+#+linux
+(defun unix-getpwuid (uid)
+ _N"Return a USER-INFO structure for the user identified by UID, or NIL if not found."
+ (declare (type unix-uid uid))
+ (with-alien ((buf (array c-call:char 1024))
+ (user-info (struct passwd))
+ (result (* (struct passwd))))
+ (let ((returned
+ (alien-funcall
+ (extern-alien "getpwuid_r"
+ (function c-call:int
+ c-call:unsigned-int
+ (* (struct passwd))
+ (* c-call:char)
+ c-call:unsigned-int
+ (* (* (struct passwd)))))
+ uid
+ (addr user-info)
+ (cast buf (* c-call:char))
+ 1024
+ (addr result))))
+ (when (zerop returned)
+ (make-user-info
+ :name (string (cast (slot result 'pw-name) c-call:c-string))
+ :password (string (cast (slot result 'pw-passwd) c-call:c-string))
+ :uid (slot result 'pw-uid)
+ :gid (slot result 'pw-gid)
+ :gecos (string (cast (slot result 'pw-gecos) c-call:c-string))
+ :dir (string (cast (slot result 'pw-dir) c-call:c-string))
+ :shell (string (cast (slot result 'pw-shell) c-call:c-string)))))))
+
;;; Getrusage is not provided in the C library on Solaris 2.4, and is
;;; rather slow on later versions so the "times" system call is
;;; provided.
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/ce8ced742daeaed09a4ffd45c813908b514860bd...dcb8aafc94cc6b92e6f58fe84b65ca7107cdc5cc
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20151018/5190931d/attachment.html>
More information about the cmucl-cvs
mailing list