/[cmucl]/src/code/unix-glibc2.lisp
ViewVC logotype

Diff of /src/code/unix-glibc2.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by dtc, Tue Jun 16 06:58:54 1998 UTC revision 1.2.2.5 by pw, Thu Aug 24 17:15:05 2000 UTC
# Line 10  Line 10 
10  ;;; **********************************************************************  ;;; **********************************************************************
11  ;;;  ;;;
12  ;;; This file contains the UNIX low-level support for glibc2.  Based  ;;; This file contains the UNIX low-level support for glibc2.  Based
13  ;;; on unix.lisp 1.56, converted for glibc2 by Peter Van Eynde (1998)  ;;; on unix.lisp 1.56, converted for glibc2 by Peter Van Eynde (1998).
14    ;;; Alpha support by Julian Dolby, 1999.
15  ;;;  ;;;
16  ;;; All the functions with #+nil in front are work in progress,  ;;; All the functions with #+nil in front are work in progress,
17  ;;; and mostly don't work.  ;;; and mostly don't work.
# Line 134  Line 135 
135            KBDSCLICK FIONREAD      unix-exit unix-stat unix-lstat unix-fstat            KBDSCLICK FIONREAD      unix-exit unix-stat unix-lstat unix-fstat
136            unix-getrusage unix-fast-getrusage rusage_self rusage_children            unix-getrusage unix-fast-getrusage rusage_self rusage_children
137            unix-gettimeofday            unix-gettimeofday
138            unix-utimes unix-setreuid            unix-utimes unix-sched-yield unix-setreuid
139            unix-setregid            unix-setregid
140            unix-getpid unix-getppid            unix-getpid unix-getppid
141            unix-getgid unix-getegid unix-getpgrp unix-setpgrp unix-getuid            unix-getgid unix-getegid unix-getpgrp unix-setpgrp unix-getuid
142            unix-getpagesize unix-gethostname unix-gethostid unix-fork            unix-getpagesize unix-gethostname unix-gethostid unix-fork
143            unix-current-directory unix-isatty unix-ttyname unix-execve            unix-current-directory unix-isatty unix-ttyname unix-execve
144            unix-socket unix-connect unix-bind unix-listen unix-accept            unix-socket unix-connect unix-bind unix-listen unix-accept
145            unix-recv unix-send unix-getpeername unix-getsockname))            unix-recv unix-send unix-getpeername unix-getsockname
146              unix-getsockopt unix-setsockopt))
147    
148  (pushnew :unix *features*)  (pushnew :unix *features*)
149  (pushnew :glibc2 *features*)  (pushnew :glibc2 *features*)
# Line 257  Line 259 
259  (def-alien-type daddr-t int)  (def-alien-type daddr-t int)
260  (def-alien-type caddr-t (* char))  (def-alien-type caddr-t (* char))
261  (def-alien-type swblk-t long)  (def-alien-type swblk-t long)
262  (def-alien-type size-t unsigned-int)  (def-alien-type size-t #-alpha unsigned-int #+alpha long)
263  (def-alien-type time-t long)  (def-alien-type time-t long)
264  (def-alien-type clock-t long)  (def-alien-type clock-t long)
265  (def-alien-type uid-t unsigned-int)  (def-alien-type uid-t unsigned-int)
266  (def-alien-type ssize-t int)  (def-alien-type ssize-t #-alpha int #+alpha long)
 (def-alien-type fd-mask unsigned-long)  
267  (def-alien-type key-t int)  (def-alien-type key-t int)
268  (def-alien-type int8-t char)  (def-alien-type int8-t char)
269  (def-alien-type u-int8-t unsigned-char)  (def-alien-type u-int8-t unsigned-char)
# Line 272  Line 273 
273  (def-alien-type u-int32-t unsigned-int)  (def-alien-type u-int32-t unsigned-int)
274  (def-alien-type int64-t #+nil long-long #-nil (array long 2))  (def-alien-type int64-t #+nil long-long #-nil (array long 2))
275  (def-alien-type u-int64-t #+nil unsigned-long-long #-nil (array unsigned-long 2))  (def-alien-type u-int64-t #+nil unsigned-long-long #-nil (array unsigned-long 2))
276  (def-alien-type register-t int)  (def-alien-type register-t #-alpha int #+alpha long)
277    
278    
279  (def-alien-type dev-t uquad-t)  (def-alien-type dev-t #-alpha uquad-t #+alpha unsigned-long)
280  (def-alien-type uid-t unsigned-int)  (def-alien-type uid-t unsigned-int)
281  (def-alien-type gid-t unsigned-int)  (def-alien-type gid-t unsigned-int)
282  (def-alien-type ino-t unsigned-long)  (def-alien-type ino-t #-alpha unsigned-long #+alpha unsigned-int)
283  (def-alien-type mode-t unsigned-int)  (def-alien-type mode-t unsigned-int)
284  (def-alien-type nlink-t unsigned-int)  (def-alien-type nlink-t unsigned-int)
285  (def-alien-type off-t long)  (def-alien-type off-t long)
286  (def-alien-type loff-t quad-t)  (def-alien-type loff-t quad-t)
287  (def-alien-type pid-t int)  (def-alien-type pid-t int)
288  (def-alien-type ssize-t int)  (def-alien-type ssize-t #-alpha int #+alpha long)
289    
290  (def-alien-type fsid-t (array int 2))  (def-alien-type fsid-t (array int 2))
291    
292  (defconstant fd-setsize 1024)  (def-alien-type fd-mask #-alpha unsigned-long #+alpha unsigned-int)
293    
294    (defconstant fd-setsize 1024)
295    (defconstant nfdbits 32)
296    
297  (def-alien-type nil  (def-alien-type nil
298    (struct fd-set    (struct fd-set
299            (fds-bits (array fd-mask #.(/ fd-setsize 32)))))            (fds-bits (array fd-mask #.(/ fd-setsize nfdbits)))))
300    
301  (def-alien-type key-t int)  (def-alien-type key-t int)
302    
# Line 396  Line 400 
400     FEXCL           Error if already created.     FEXCL           Error if already created.
401     "     "
402    (declare (type unix-fd fd)    (declare (type unix-fd fd)
403             (type (unsigned-byte 16) cmd)             (type (unsigned-byte 32) cmd)
404             (type (unsigned-byte 16) arg))             (type (unsigned-byte 32) arg))
405    (int-syscall ("fcntl" int int int) fd cmd arg))    (int-syscall ("fcntl" int int int) fd cmd arg))
406    
407  (defun unix-open (path flags mode)  (defun unix-open (path flags mode)
# Line 465  Line 469 
469  (defconstant o_wronly  1 "Write-only flag.")  (defconstant o_wronly  1 "Write-only flag.")
470  (defconstant o_rdwr    2 "Read-write flag.")  (defconstant o_rdwr    2 "Read-write flag.")
471  (defconstant o_accmode 3 "Access mode mask.")  (defconstant o_accmode 3 "Access mode mask.")
472  (defconstant o_creat   #o100 "Create if nonexistant flag. (not fcntl)")  
473  (defconstant o_excl    #o200 "Error if already exists. (not fcntl)")  #-alpha
474  (defconstant o_noctty  #o400 "Don't assign controlling tty. (not fcntl)")  (progn
475  (defconstant o_trunc   #o1000 "Truncate flag. (not fcntl)")    (defconstant o_creat   #o100 "Create if nonexistant flag. (not fcntl)")
476  (defconstant o_append  #o2000 "Append flag.")    (defconstant o_excl    #o200 "Error if already exists. (not fcntl)")
477  (defconstant o_ndelay  #o4000 "Non-blocking I/O")    (defconstant o_noctty  #o400 "Don't assign controlling tty. (not fcntl)")
478  (defconstant o_nonblock #o4000 "Non-blocking I/O")    (defconstant o_trunc   #o1000 "Truncate flag. (not fcntl)")
479  (defconstant o_ndelay  o_nonblock)    (defconstant o_append  #o2000 "Append flag.")
480  (defconstant o_sync    #o10000 "Synchronous writes (on ext2)")    (defconstant o_ndelay  #o4000 "Non-blocking I/O")
481  (defconstant o_fsync    o_sync)    (defconstant o_nonblock #o4000 "Non-blocking I/O")
482  (defconstant o_async   #o20000 "Asynchronous I/O")    (defconstant o_ndelay  o_nonblock)
483      (defconstant o_sync    #o10000 "Synchronous writes (on ext2)")
484      (defconstant o_fsync    o_sync)
485      (defconstant o_async   #o20000 "Asynchronous I/O"))
486    #+alpha
487    (progn
488      (defconstant o_creat   #o1000 "Create if nonexistant flag. (not fcntl)")
489      (defconstant o_trunc   #o2000 "Truncate flag. (not fcntl)")
490      (defconstant o_excl    #o4000 "Error if already exists. (not fcntl)")
491      (defconstant o_noctty  #o10000 "Don't assign controlling tty. (not fcntl)")
492      (defconstant o_nonblock #o4 "Non-blocking I/O")
493      (defconstant o_append  #o10 "Append flag.")
494      (defconstant o_ndelay  o_nonblock)
495      (defconstant o_sync    #o40000 "Synchronous writes (on ext2)")
496      (defconstant o_fsync    o_sync)
497      (defconstant o_async   #o20000 "Asynchronous I/O"))
498    
499  (defconstant f-dupfd    0  "Duplicate a file descriptor")  (defconstant f-dupfd    0  "Duplicate a file descriptor")
500  (defconstant f-getfd    1  "Get file desc. flags")  (defconstant f-getfd    1  "Get file desc. flags")
501  (defconstant f-setfd    2  "Set file desc. flags")  (defconstant f-setfd    2  "Set file desc. flags")
502  (defconstant f-getfl    3  "Get file flags")  (defconstant f-getfl    3  "Get file flags")
503  (defconstant f-setfl    4  "Set file flags")  (defconstant f-setfl    4  "Set file flags")
504  (defconstant f-getlk    5   "Get lock")  
505  (defconstant f-setlk    6   "Set lock")  #-alpha
506  (defconstant f-setlkw   7   "Set lock, wait for release")  (progn
507  (defconstant f-setown   8  "Set owner (for sockets)")    (defconstant f-getlk    5   "Get lock")
508  (defconstant f-getown   9  "Get owner (for sockets)")    (defconstant f-setlk    6   "Set lock")
509      (defconstant f-setlkw   7   "Set lock, wait for release")
510      (defconstant f-setown   8  "Set owner (for sockets)")
511      (defconstant f-getown   9  "Get owner (for sockets)"))
512    #+alpha
513    (progn
514      (defconstant f-getlk    7   "Get lock")
515      (defconstant f-setlk    8   "Set lock")
516      (defconstant f-setlkw   9   "Set lock, wait for release")
517      (defconstant f-setown   5  "Set owner (for sockets)")
518      (defconstant f-getown   6  "Get owner (for sockets)"))
519    
520    
521    
522  (defconstant F-CLOEXEC 1 "for f-getfl and f-setfl")  (defconstant F-CLOEXEC 1 "for f-getfl and f-setfl")
523    
524  (defconstant F-RDLCK 0 "for fcntl and lockf")  #-alpha
525  (defconstant F-WDLCK 1 "for fcntl and lockf")  (progn
526  (defconstant F-UNLCK 2 "for fcntl and lockf")    (defconstant F-RDLCK 0 "for fcntl and lockf")
527  (defconstant F-EXLCK 4 "old bsd flock (depricated)")    (defconstant F-WDLCK 1 "for fcntl and lockf")
528  (defconstant F-SHLCK 8 "old bsd flock (depricated)")    (defconstant F-UNLCK 2 "for fcntl and lockf")
529      (defconstant F-EXLCK 4 "old bsd flock (depricated)")
530      (defconstant F-SHLCK 8 "old bsd flock (depricated)"))
531    #+alpha
532    (progn
533      (defconstant F-RDLCK 1 "for fcntl and lockf")
534      (defconstant F-WDLCK 2 "for fcntl and lockf")
535      (defconstant F-UNLCK 8 "for fcntl and lockf")
536      (defconstant F-EXLCK 16 "old bsd flock (depricated)")
537      (defconstant F-SHLCK 32 "old bsd flock (depricated)"))
538    
539  (defconstant F-LOCK-SH 1 "Shared lock for bsd flock")  (defconstant F-LOCK-SH 1 "Shared lock for bsd flock")
540  (defconstant F-LOCK-EX 2 "Exclusive lock for bsd flock")  (defconstant F-LOCK-EX 2 "Exclusive lock for bsd flock")
# Line 1172  length LEN and type TYPE." Line 1212  length LEN and type TYPE."
1212      (declare (type system-area-pointer result))      (declare (type system-area-pointer result))
1213      (if (zerop (sap-int result))      (if (zerop (sap-int result))
1214          nil          nil
1215        result)))          result)))
1216    
1217  ;;; resourcebits.h  ;;; resourcebits.h
1218    
   
1219  (def-alien-type nil  (def-alien-type nil
1220    (struct rlimit    (struct rlimit
1221      (rlim-cur long)      ; current (soft) limit      (rlim-cur long)      ; current (soft) limit
# Line 1245  length LEN and type TYPE." Line 1284  length LEN and type TYPE."
1284    (int-syscall ("sched_getscheduler" pid-t)    (int-syscall ("sched_getscheduler" pid-t)
1285                  pid))                  pid))
1286    
1287  #+nil  (defun unix-sched-yield ()
 (defun unix-sched_yield ()  
1288    "Retrieve scheduling algorithm for a particular purpose."    "Retrieve scheduling algorithm for a particular purpose."
1289    (int-syscall ("sched_yield")))    (int-syscall ("sched_yield")))
1290    
# Line 1370  length LEN and type TYPE." Line 1408  length LEN and type TYPE."
1408  (def-alien-type nil  (def-alien-type nil
1409    (struct stat    (struct stat
1410      (st-dev dev-t)      (st-dev dev-t)
1411      (st-pad1 unsigned-short)      #-alpha (st-pad1 unsigned-short)
1412      (st-ino ino-t)      (st-ino ino-t)
1413      (st-mode mode-t)      (st-mode mode-t)
1414      (st-nlink  nlink-t)      (st-nlink  nlink-t)
1415      (st-uid  uid-t)      (st-uid  uid-t)
1416      (st-gid  gid-t)      (st-gid  gid-t)
1417      (st-rdev dev-t)      (st-rdev dev-t)
1418      (st-pad2  unsigned-short)      #-alpha (st-pad2  unsigned-short)
1419        #+alpha (st-pad2  unsigned-int)
1420      (st-size off-t)      (st-size off-t)
1421      (st-blksize unsigned-long)      #-alpha (st-blksize unsigned-long)
1422      (st-blocks unsigned-long)      #-alpha (st-blocks unsigned-long)
1423      (st-atime time-t)      (st-atime time-t)
1424      (unused-1 unsigned-long)      #-alpha (unused-1 unsigned-long)
1425      (st-mtime time-t)      (st-mtime time-t)
1426      (unused-2 unsigned-long)      #-alpha (unused-2 unsigned-long)
1427      (st-ctime time-t)      (st-ctime time-t)
1428      (unused-3 unsigned-long)      #+alpha (st-blksize unsigned-int)
1429      (unused-4 unsigned-long)      #+alpha (st-blocks int)
1430      (unused-5 unsigned-long)))      #+alpha (st-flags unsigned-int)
1431        #+alpha (st-gen unsigned-int)
1432        #-alpha (unused-3 unsigned-long)
1433        #-alpha (unused-4 unsigned-long)
1434        #-alpha (unused-5 unsigned-long)))
1435    
1436  ;; Encoding of the file mode.  ;; Encoding of the file mode.
1437    
# Line 1424  length LEN and type TYPE." Line 1467  length LEN and type TYPE."
1467              (f-bsize int)              (f-bsize int)
1468              (f-blocks int)              (f-blocks int)
1469              (f-bfree int)              (f-bfree int)
1470              (f-babail int)              (f-bavail int)
1471              (f-files int)              (f-files int)
1472              (f-ffree int)              (f-ffree int)
1473              (f-fsid fsid-t)              (f-fsid fsid-t)
# Line 1621  length LEN and type TYPE." Line 1664  length LEN and type TYPE."
1664  ;; microsecond but also has a range of years.  ;; microsecond but also has a range of years.
1665  (def-alien-type nil  (def-alien-type nil
1666    (struct timeval    (struct timeval
1667            (tv-sec time-t)               ; seconds            (tv-sec #-alpha time-t #+alpha int)           ; seconds
1668            (tv-usec time-t)))            ; and microseconds            (tv-usec #-alpha time-t #+alpha int)))        ; and microseconds
1669    
1670  ;;; unistd.h  ;;; unistd.h
1671    
# Line 1875  length LEN and type TYPE." Line 1918  length LEN and type TYPE."
1918    "Unix-getppid returns the process-id of the parent of the current process.")    "Unix-getppid returns the process-id of the parent of the current process.")
1919    
1920  ;;; Unix-getpgrp returns the group-id associated with the  ;;; Unix-getpgrp returns the group-id associated with the
1921  ;;; process whose process-id is specified as an argument.  ;;; current process.
1922  ;;; As usual, if the process-id is 0, it refers to the current  
1923  ;;; process.  (defun unix-getpgrp ()
1924      "Unix-getpgrp returns the group-id of the calling process."
1925  (defun unix-getpgrp (pid)    (int-syscall ("getpgrp")))
   "Unix-getpgrp returns the group-id of the process associated  
    with pid."  
   (int-syscall ("getpgrp" int) pid))  
1926    
1927  ;;; Unix-setpgrp sets the group-id of the process specified by  ;;; Unix-setpgid sets the group-id of the process specified by
1928  ;;; "pid" to the value of "pgrp".  The process must either have  ;;; "pid" to the value of "pgrp".  The process must either have
1929  ;;; the same effective user-id or be a super-user process.  ;;; the same effective user-id or be a super-user process.
1930    
1931    ;;; setpgrp(int int)[freebsd] is identical to setpgid and is retained
1932    ;;; for backward compatibility. setpgrp(void)[solaris] is being phased
1933    ;;; out in favor of setsid().
1934    
1935  (defun unix-setpgrp (pid pgrp)  (defun unix-setpgrp (pid pgrp)
1936    "Unix-setpgrp sets the process group on the process pid to    "Unix-setpgrp sets the process group on the process pid to
1937     pgrp.  NIL and an error number is returned upon failure."     pgrp.  NIL and an error number are returned upon failure."
1938    (void-syscall ( "setpgrp" int int) pid pgrp))    (void-syscall ("setpgid" int int) pid pgrp))
1939    
1940    (defun unix-setpgid (pid pgrp)
1941      "Unix-setpgid sets the process group of the process pid to
1942       pgrp. If pgid is equal to pid, the process becomes a process
1943       group leader. NIL and an error number are returned upon failure."
1944      (void-syscall ("setpgid" int int) pid pgrp))
1945    
1946  #+nil  #+nil
1947  (defun unix-setsid ()  (defun unix-setsid ()
# Line 2329  in at a time in poll.") Line 2379  in at a time in poll.")
2379     an event to occur; if TIMEOUT is -1, block until an event occurs.     an event to occur; if TIMEOUT is -1, block until an event occurs.
2380     Returns the number of file descriptors with events, zero if timed out,     Returns the number of file descriptors with events, zero if timed out,
2381     or -1 for errors."     or -1 for errors."
2382   (int-syscall ("pool" (* (struct pollfd)) long int)   (int-syscall ("poll" (* (struct pollfd)) long int)
2383                fds nfds timeout))                fds nfds timeout))
2384    
2385  ;;; sys/resource.h  ;;; sys/resource.h
2386    
2387  #+nil  (defun unix-getrlimit (resource)
2388  (defun unix-getrlimit (resource rlimits)    "Get the soft and hard limits for RESOURCE."
2389    "Put the soft and hard limits for RESOURCE in *RLIMITS.    (with-alien ((rlimits (struct rlimit)))
2390     Returns 0 if successful, -1 if not (and sets errno)."      (syscall ("getrlimit" int (* (struct rlimit)))
2391    (int-syscall ("getrlimit" int (* (struct rlimit)))               (values t
2392                 resource rlimits))                       (slot rlimits 'rlim-cur)
2393                         (slot rlimits 'rlim-max))
2394  #+nil               resource (addr rlimits))))
2395  (defun unix-setrlimit (resource rlimits)  
2396    "Set the soft and hard limits for RESOURCE to *RLIMITS.  (defun unix-setrlimit (resource current maximum)
2397     Only the super-user can increase hard limits.    "Set the current soft and hard maximum limits for RESOURCE.
2398     Return 0 if successful, -1 if not (and sets errno)."     Only the super-user can increase hard limits."
2399    (int-syscall ("setrlimit" int (* (struct rlimit)))    (with-alien ((rlimits (struct rlimit)))
2400                 resource rlimits))      (setf (slot rlimits 'rlim-cur) current)
2401        (setf (slot rlimits 'rlim-max) maximum)
2402        (void-syscall ("setrlimit" int (* (struct rlimit)))
2403                      resource (addr rlimits))))
2404    
2405  (declaim (inline unix-fast-getrusage))  (declaim (inline unix-fast-getrusage))
2406  (defun unix-fast-getrusage (who)  (defun unix-fast-getrusage (who)
# Line 2473  in at a time in poll.") Line 2526  in at a time in poll.")
2526    (sockaddr (* t))    (sockaddr (* t))
2527    (len (* unsigned)))    (len (* unsigned)))
2528    
2529    (def-alien-routine ("getsockopt" unix-getsockopt) int
2530      (socket int)
2531      (level int)
2532      (optname int)
2533      (optval (* t))
2534      (optlen unsigned :in-out))
2535    
2536    (def-alien-routine ("setsockopt" unix-setsockopt) int
2537      (socket int)
2538      (level int)
2539      (optname int)
2540      (optval (* t))
2541      (optlen unsigned))
2542    
2543  ;;; sys/select.h  ;;; sys/select.h
2544    
2545  ;;; UNIX-FAST-SELECT -- public.  ;;; UNIX-FAST-SELECT -- public.
# Line 2505  in at a time in poll.") Line 2572  in at a time in poll.")
2572    `(if (fixnump ,num)    `(if (fixnump ,num)
2573         (progn         (progn
2574           (setf (deref (slot ,fdset 'fds-bits) 0) ,num)           (setf (deref (slot ,fdset 'fds-bits) 0) ,num)
2575           ,@(loop for index upfrom 1 below (/ fd-setsize 32)           ,@(loop for index upfrom 1 below (/ fd-setsize nfdbits)
2576               collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))               collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
2577         (progn         (progn
2578           ,@(loop for index upfrom 0 below (/ fd-setsize 32)           ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits)
2579               collect `(setf (deref (slot ,fdset 'fds-bits) ,index)               collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
2580                              (ldb (byte 32 ,(* index 32)) ,num))))))                              (ldb (byte nfdbits ,(* index nfdbits)) ,num))))))
2581    
2582  (defmacro fd-set-to-num (nfds fdset)  (defmacro fd-set-to-num (nfds fdset)
2583    `(if (<= ,nfds 32)    `(if (<= ,nfds nfdbits)
2584         (deref (slot ,fdset 'fds-bits) 0)         (deref (slot ,fdset 'fds-bits) 0)
2585         (+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)         (+ ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits)
2586                collect `(ash (deref (slot ,fdset 'fds-bits) ,index)                collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
2587                              ,(* index 32))))))                              ,(* index nfdbits))))))
2588    
2589  (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))  (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
2590    "Unix-select examines the sets of descriptors passed as arguments    "Unix-select examines the sets of descriptors passed as arguments
# Line 2555  in at a time in poll.") Line 2622  in at a time in poll.")
2622    
2623  (defmacro extract-stat-results (buf)  (defmacro extract-stat-results (buf)
2624    `(values T    `(values T
2625             #+nil             #+alpha
2626             (slot ,buf 'st-dev)             (slot ,buf 'st-dev)
2627             #-nil             #-alpha
2628             (+ (deref (slot ,buf 'st-dev) 0)             (+ (deref (slot ,buf 'st-dev) 0)
2629                (* (+ +max-u-long+  1)                (* (+ +max-u-long+  1)
2630                   (deref (slot ,buf 'st-dev) 1)))   ;;; let's hope this works..                   (deref (slot ,buf 'st-dev) 1)))   ;;; let's hope this works..
# Line 2566  in at a time in poll.") Line 2633  in at a time in poll.")
2633             (slot ,buf 'st-nlink)             (slot ,buf 'st-nlink)
2634             (slot ,buf 'st-uid)             (slot ,buf 'st-uid)
2635             (slot ,buf 'st-gid)             (slot ,buf 'st-gid)
2636             #+nil             #+alpha
2637             (slot ,buf 'st-rdev)             (slot ,buf 'st-rdev)
2638             #-nil             #-alpha
2639             (+ (deref (slot ,buf 'st-rdev) 0)             (+ (deref (slot ,buf 'st-rdev) 0)
2640                (* (+ +max-u-long+  1)                (* (+ +max-u-long+  1)
2641                   (deref (slot ,buf 'st-rdev) 1)))   ;;; let's hope this works..                   (deref (slot ,buf 'st-rdev) 1)))   ;;; let's hope this works..
# Line 3088  in at a time in poll.") Line 3155  in at a time in poll.")
3155    
3156  (eval-when (compile load eval)  (eval-when (compile load eval)
3157    
3158  (defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))  (defconstant iocparm-mask #x3fff)
3159    (declare (ignore arg parm-type))  (defconstant ioc_void #x00000000)
3160    `(eval-when (eval load compile)  (defconstant ioc_out #x40000000)
3161       (defconstant ,name ,(logior (ash (- (char-code dev) #x20) 8) cmd)))))  (defconstant ioc_in #x80000000)
3162    (defconstant ioc_inout (logior ioc_in ioc_out))
3163    
3164    (defmacro define-ioctl-command (name dev cmd &optional arg parm-type)
3165      "Define an ioctl command. If the optional ARG and PARM-TYPE are given
3166      then ioctl argument size and direction are included as for ioctls defined
3167      by _IO, _IOR, _IOW, or _IOWR. If DEV is a character then the ioctl type
3168      is the characters code, else DEV may be an integer giving the type."
3169      (let* ((type (if (characterp dev)
3170                       (char-code dev)
3171                       dev))
3172             (code (logior (ash type 8) cmd)))
3173        (when arg
3174          (setf code `(logior (ash (logand (alien-size ,arg :bytes) ,iocparm-mask)
3175                                   16)
3176                              ,code)))
3177        (when parm-type
3178          (let ((dir (ecase parm-type
3179                       (:void ioc_void)
3180                       (:in ioc_in)
3181                       (:out ioc_out)
3182                       (:inout ioc_inout))))
3183            (setf code `(logior ,dir ,code))))
3184        `(eval-when (eval load compile)
3185           (defconstant ,name ,code))))
3186    
3187    )
3188    
3189  ;;; TTY ioctl commands.  ;;; TTY ioctl commands.
3190    
3191  (define-ioctl-command TIOCGWINSZ #\t #x13 (struct winsize) :out)  (define-ioctl-command TIOCGWINSZ #\T #x13)
3192  (define-ioctl-command TIOCSWINSZ #\t #x14 (struct winsize) :in)  (define-ioctl-command TIOCSWINSZ #\T #x14)
3193  (define-ioctl-command TIOCNOTTY  #\t #x22 nil :void)  (define-ioctl-command TIOCNOTTY  #\T #x22)
3194  (define-ioctl-command TIOCSPGRP  #\t #x10 int :in)  (define-ioctl-command TIOCSPGRP  #\T #x10)
3195  (define-ioctl-command TIOCGPGRP  #\t #x0F int :out)  (define-ioctl-command TIOCGPGRP  #\T #x0F)
3196    
3197  ;;; File ioctl commands.  ;;; File ioctl commands.
3198  (define-ioctl-command FIONREAD #\t #x1B int :out)  (define-ioctl-command FIONREAD #\T #x1B)
3199    
3200  ;;; asm/sockios.h  ;;; asm/sockios.h
3201    
3202  ;;; Socket options.  ;;; Socket options.
3203    
3204  ;;; should be #x8902  (define-ioctl-command SIOCSPGRP #x89 #x02)
 (define-ioctl-command SIOCSPGRP #.(code-char #x89) #x02 int :in)  
3205    
3206  (defun siocspgrp (fd pgrp)  (defun siocspgrp (fd pgrp)
3207    "Set the socket process-group for the unix file-descriptor FD to PGRP."    "Set the socket process-group for the unix file-descriptor FD to PGRP."
# Line 3378  in at a time in poll.") Line 3470  in at a time in poll.")
3470  (defmacro fd-set (offset fd-set)  (defmacro fd-set (offset fd-set)
3471    (let ((word (gensym))    (let ((word (gensym))
3472          (bit (gensym)))          (bit (gensym)))
3473      `(multiple-value-bind (,word ,bit) (floor ,offset 32)      `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits)
3474         (setf (deref (slot ,fd-set 'fds-bits) ,word)         (setf (deref (slot ,fd-set 'fds-bits) ,word)
3475               (logior (truly-the (unsigned-byte 32) (ash 1 ,bit))               (logior (truly-the (unsigned-byte 32) (ash 1 ,bit))
3476                       (deref (slot ,fd-set 'fds-bits) ,word))))))                       (deref (slot ,fd-set 'fds-bits) ,word))))))
# Line 3387  in at a time in poll.") Line 3479  in at a time in poll.")
3479  (defmacro fd-clr (offset fd-set)  (defmacro fd-clr (offset fd-set)
3480    (let ((word (gensym))    (let ((word (gensym))
3481          (bit (gensym)))          (bit (gensym)))
3482      `(multiple-value-bind (,word ,bit) (floor ,offset 32)      `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits)
3483         (setf (deref (slot ,fd-set 'fds-bits) ,word)         (setf (deref (slot ,fd-set 'fds-bits) ,word)
3484               (logand (deref (slot ,fd-set 'fds-bits) ,word)               (logand (deref (slot ,fd-set 'fds-bits) ,word)
3485                       (32bit-logical-not                       (32bit-logical-not
# Line 3397  in at a time in poll.") Line 3489  in at a time in poll.")
3489  (defmacro fd-isset (offset fd-set)  (defmacro fd-isset (offset fd-set)
3490    (let ((word (gensym))    (let ((word (gensym))
3491          (bit (gensym)))          (bit (gensym)))
3492      `(multiple-value-bind (,word ,bit) (floor ,offset 32)      `(multiple-value-bind (,word ,bit) (floor ,offset nfdbits)
3493         (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))         (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
3494    
3495  ;; not checked for linux...  ;; not checked for linux...
3496  (defmacro fd-zero (fd-set)  (defmacro fd-zero (fd-set)
3497    `(progn    `(progn
3498       ,@(loop for index upfrom 0 below (/ fd-setsize 32)       ,@(loop for index upfrom 0 below (/ fd-setsize nfdbits)
3499           collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))           collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
3500    
3501    

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.2.2.5

  ViewVC Help
Powered by ViewVC 1.1.5