Raymond Toy pushed to branch rtoy-grand-unix-unification at cmucl / cmucl

Commits:

2 changed files:

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.