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

Contents of /src/code/unix.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.134 - (show annotations)
Fri Jan 7 03:46:42 2011 UTC (3 years, 3 months ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, HEAD
Changes since 1.133: +1 -1 lines
Fix typo in unix-uname.  We want to use "uname" everywhere except on
freebsd and solaris/x86.
1 ;;; -*- Package: UNIX -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/unix.lisp,v 1.134 2011/01/07 03:46:42 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the UNIX low-level support.
13 ;;;
14 (in-package "UNIX")
15 (use-package "ALIEN")
16 (use-package "C-CALL")
17 (use-package "SYSTEM")
18 (use-package "EXT")
19 (intl:textdomain "cmucl-unix")
20
21 ;; Check the G_BROKEN_FILENAMES environment variable; if set the encoding
22 ;; is locale-dependent...else use :utf-8 on Unicode Lisps. On 8 bit Lisps
23 ;; it must be set to :iso8859-1 (or left as NIL), making files with
24 ;; non-Latin-1 characters "mojibake", but otherwise they'll be inaccessible.
25 ;; Must be set to NIL initially to enable building Lisp!
26 (defvar *filename-encoding* nil)
27
28 (export '(daddr-t caddr-t ino-t swblk-t size-t time-t dev-t off-t uid-t gid-t
29 timeval tv-sec tv-usec timezone tz-minuteswest tz-dsttime
30 itimerval it-interval it-value tchars t-intrc t-quitc t-startc
31 t-stopc t-eofc t-brkc ltchars t-suspc t-dsuspc t-rprntc t-flushc
32 t-werasc t-lnextc sgttyb sg-ispeed sg-ospeed sg-erase sg-kill
33 sg-flags winsize ws-row ws-col ws-xpixel ws-ypixel
34 direct d-off d-ino d-reclen #-(or linux svr4) d-namlen d-name
35 stat st-dev st-mode st-nlink st-uid st-gid st-rdev st-size
36 st-atime st-mtime st-ctime st-blksize st-blocks
37 s-ifmt s-ifdir s-ifchr s-ifblk s-ifreg s-iflnk s-ifsock
38 s-isuid s-isgid s-isvtx s-iread s-iwrite s-iexec
39 ruseage ru-utime ru-stime ru-maxrss ru-ixrss ru-idrss
40 ru-isrss ru-minflt ru-majflt ru-nswap ru-inblock ru-oublock
41 ru-msgsnd ru-msgrcv ru-nsignals ru-nvcsw ru-nivcsw
42 rlimit rlim-cur rlim-max sc-onstack sc-mask sc-pc
43
44 unix-errno get-unix-error-msg
45
46 prot_read prot_write prot_exec prot_none
47 map_shared map_private map_fixed map_anonymous
48 ms_async ms_sync ms_invalidate
49 unix-mmap unix-munmap unix-msync
50 unix-mprotect
51
52 unix-pathname unix-file-mode unix-fd unix-pid unix-uid unix-gid
53 unix-setitimer unix-getitimer
54 unix-access r_ok w_ok x_ok f_ok unix-chdir unix-chmod setuidexec
55 setgidexec savetext readown writeown execown readgrp writegrp
56 execgrp readoth writeoth execoth unix-fchmod unix-chown unix-fchown
57 unix-getdtablesize unix-close unix-creat unix-dup unix-dup2
58 unix-fcntl f-dupfd f-getfd f-setfd f-getfl f-setfl f-getown f-setown
59 fndelay fappend fasync fcreat ftrunc fexcl unix-link unix-lseek
60 l_set l_incr l_xtnd unix-mkdir unix-open o_rdonly o_wronly o_rdwr
61 #+(or hpux svr4 bsd linux) o_ndelay
62 #+(or hpux svr4 bsd linux) o_noctty #+(or hpux svr4 bsd) o_nonblock
63 o_append o_creat o_trunc o_excl unix-pipe unix-read unix-readlink
64 unix-rename unix-rmdir unix-fast-select fd-setsize fd-set fd-clr
65 fd-isset fd-zero unix-select unix-sync unix-fsync unix-truncate
66 unix-ftruncate unix-symlink
67 #+(and sparc svr4) unix-times
68 unix-unlink unix-write unix-ioctl
69 tcsetpgrp tcgetpgrp tty-process-group
70 terminal-speeds tty-raw tty-crmod tty-echo tty-lcase
71 #-hpux tty-cbreak #-(or hpux linux) tty-tandem
72 #+(or hpux svr4 linux bsd) termios
73 #+(or hpux svr4 linux bsd) c-lflag
74 #+(or hpux svr4 linux bsd) c-iflag
75 #+(or hpux svr4 linux bsd) c-oflag
76 #+(or hpux svr4 linux bsd) tty-icrnl
77 #+(or hpux svr4 linux) tty-ocrnl
78 #+(or hpux svr4 bsd) vdsusp #+(or hpux svr4 linux bsd) veof
79 #+(or hpux svr4 linux bsd) vintr
80 #+(or hpux svr4 linux bsd) vquit
81 #+(or hpux svr4 linux bsd) vstart
82 #+(or hpux svr4 linux bsd) vstop
83 #+(or hpux svr4 linux bsd) vsusp
84 #+(or hpux svr4 linux bsd) c-cflag
85 #+(or hpux svr4 linux bsd) c-cc
86 #+(or bsd osf1) c-ispeed
87 #+(or bsd osf1) c-ospeed
88 #+(or hpux svr4 linux bsd) tty-icanon
89 #+(or hpux svr4 linux bsd) vmin
90 #+(or hpux svr4 linux bsd) vtime
91 #+(or hpux svr4 linux bsd) tty-ixon
92 #+(or hpux svr4 linux bsd) tcsanow
93 #+(or hpux svr4 linux bsd) tcsadrain
94 #+(or hpux svr4 linux bsd) tciflush
95 #+(or hpux svr4 linux bsd) tcoflush
96 #+(or hpux svr4 linux bsd) tcioflush
97 #+(or hpux svr4 linux bsd) tcsaflush
98 #+(or hpux svr4 linux bsd) unix-tcgetattr
99 #+(or hpux svr4 linux bsd) unix-tcsetattr
100 #+(or hpux svr4 bsd) unix-cfgetospeed
101 #+(or hpux svr4 bsd) unix-cfsetospeed
102 #+(or hpux svr4 bsd) unix-cfgetispeed
103 #+(or hpux svr4 bsd) unix-cfsetispeed
104 #+(or hpux svr4 linux bsd) tty-ignbrk
105 #+(or hpux svr4 linux bsd) tty-brkint
106 #+(or hpux svr4 linux bsd) tty-ignpar
107 #+(or hpux svr4 linux bsd) tty-parmrk
108 #+(or hpux svr4 linux bsd) tty-inpck
109 #+(or hpux svr4 linux bsd) tty-istrip
110 #+(or hpux svr4 linux bsd) tty-inlcr
111 #+(or hpux svr4 linux bsd) tty-igncr
112 #+(or hpux svr4 linux) tty-iuclc
113 #+(or hpux svr4 linux bsd) tty-ixany
114 #+(or hpux svr4 linux bsd) tty-ixoff
115 #+hpux tty-ienqak
116 #+(or hpux irix solaris linux bsd) tty-imaxbel
117 #+(or hpux svr4 linux bsd) tty-opost
118 #+(or hpux svr4 linux) tty-olcuc
119 #+(or hpux svr4 linux bsd) tty-onlcr
120 #+(or hpux svr4 linux) tty-onocr
121 #+(or hpux svr4 linux) tty-onlret
122 #+(or hpux svr4 linux) tty-ofill
123 #+(or hpux svr4 linux) tty-ofdel
124 #+(or hpux svr4 linux bsd) tty-isig
125 #+(or hpux svr4 linux) tty-xcase
126 #+(or hpux svr4 linux bsd) tty-echoe
127 #+(or hpux svr4 linux bsd) tty-echok
128 #+(or hpux svr4 linux bsd) tty-echonl
129 #+(or hpux svr4 linux bsd) tty-noflsh
130 #+(or hpux svr4 linux bsd) tty-iexten
131 #+(or hpux svr4 linux bsd) tty-tostop
132 #+(or hpux irix solaris linux bsd) tty-echoctl
133 #+(or hpux irix solaris linux bsd) tty-echoprt
134 #+(or hpux irix solaris linux bsd) tty-echoke
135 #+(or hpux irix solaris) tty-defecho
136 #+(or hpux irix solaris bsd) tty-flusho
137 #+(or hpux irix solaris linux bsd) tty-pendin
138 #+(or hpux svr4 linux bsd) tty-cstopb
139 #+(or hpux svr4 linux bsd) tty-cread
140 #+(or hpux svr4 linux bsd) tty-parenb
141 #+(or hpux svr4 linux bsd) tty-parodd
142 #+(or hpux svr4 linux bsd) tty-hupcl
143 #+(or hpux svr4 linux bsd) tty-clocal
144 #+(or irix solaris) rcv1en
145 #+(or irix solaris) xmt1en
146 #+(or hpux irix solaris) tty-loblk
147 #+(or hpux svr4 linux bsd) vintr
148 #+(or hpux svr4 linux bsd) verase
149 #+(or hpux svr4 linux bsd) vkill
150 #+(or hpux svr4 linux bsd) veol
151 #+(or hpux irix solaris linux bsd) veol2
152 #+(or hpux irix solaris) tty-cbaud
153 #+(or hpux svr4 bsd) tty-csize #+(or hpux svr4 bsd) tty-cs5
154 #+(or hpux svr4 bsd) tty-cs6 #+(or hpux svr4 bsd) tty-cs7
155 #+(or hpux svr4 bsd) tty-cs8
156 #+(or hpux svr4 bsd) unix-tcsendbreak
157 #+(or hpux svr4 bsd) unix-tcdrain
158 #+(or hpux svr4 bsd) unix-tcflush
159 #+(or hpux svr4 bsd) unix-tcflow
160
161 TIOCGETP TIOCSETP TIOCFLUSH TIOCSETC TIOCGETC TIOCSLTC
162 TIOCGLTC TIOCNOTTY TIOCSPGRP TIOCGPGRP TIOCGWINSZ TIOCSWINSZ
163 TIOCSIGSEND
164
165 KBDCGET KBDCSET KBDCRESET KBDCRST KBDCSSTD KBDSGET KBDGCLICK
166 KBDSCLICK FIONREAD #+(or hpux bsd) siocspgrp
167 unix-exit unix-stat unix-lstat unix-fstat
168 unix-getrusage unix-fast-getrusage rusage_self rusage_children
169 unix-gettimeofday
170 #-hpux unix-utimes #-(or svr4 hpux) unix-setreuid
171 #-(or svr4 hpux) unix-setregid
172 unix-getpid unix-getppid
173 #+(or svr4 bsd)unix-setpgid
174 unix-getgid unix-getegid unix-getpgrp unix-setpgrp unix-getuid
175 unix-getpagesize unix-gethostname unix-gethostid unix-fork
176 unix-getenv unix-setenv unix-putenv unix-unsetenv
177 unix-current-directory unix-isatty unix-ttyname unix-execve
178 unix-socket unix-connect unix-bind unix-listen unix-accept
179 unix-recv unix-send unix-getpeername unix-getsockname
180 unix-getsockopt unix-setsockopt unix-openpty
181
182 unix-recvfrom unix-sendto unix-shutdown
183
184 unix-getpwnam unix-getpwuid unix-getgrnam unix-getgrgid
185 user-info user-info-name user-info-password user-info-uid
186 user-info-gid user-info-gecos user-info-dir user-info-shell
187 group-info group-info-name group-info-gid group-info-members
188
189 unix-uname))
190
191 (pushnew :unix *features*)
192
193 (eval-when (:compile-toplevel)
194 (defmacro %name->file (string)
195 `(if *filename-encoding*
196 (string-encode ,string *filename-encoding*)
197 ,string))
198 (defmacro %file->name (string)
199 `(if *filename-encoding*
200 (string-decode ,string *filename-encoding*)
201 ,string)))
202
203
204 ;;;; Common machine independent structures.
205
206 ;;; From sys/types.h
207
208 (def-alien-type int64-t (signed 64))
209 (def-alien-type u-int64-t (unsigned 64))
210
211 (def-alien-type daddr-t
212 #-(or linux alpha) long
213 #+(or linux alpha) int)
214
215 (def-alien-type caddr-t (* char))
216
217 (def-alien-type ino-t
218 #-alpha unsigned-long
219 #+alpha unsigned-int)
220
221 (def-alien-type swblk-t long)
222
223 (def-alien-type size-t
224 #-(or linux alpha) long
225 #+linux unsigned-int
226 #+alpha unsigned-long)
227
228 (def-alien-type time-t
229 #-(or bsd linux alpha) unsigned-long
230 #+linux long
231 #+bsd long
232 #+alpha unsigned-int)
233
234 (def-alien-type dev-t
235 #-(or alpha svr4 bsd linux) short
236 #+linux unsigned-short
237 #+alpha int
238 #+(and (not linux) (or bsd svr4)) unsigned-long)
239
240 #-BSD
241 (progn
242 (deftype file-offset () '(signed-byte 32))
243 (def-alien-type off-t
244 #-alpha long
245 #+alpha unsigned-long) ;??? very dubious
246 (def-alien-type uid-t
247 #-(or alpha svr4) unsigned-short
248 #+alpha unsigned-int
249 #+svr4 long)
250 (def-alien-type gid-t
251 #-(or alpha svr4) unsigned-short
252 #+alpha unsigned-int
253 #+svr4 long))
254
255 #+BSD
256 (progn
257 (deftype file-offset () '(signed-byte 64))
258 (def-alien-type off-t int64-t)
259 (def-alien-type uid-t unsigned-long)
260 (def-alien-type gid-t unsigned-long))
261
262 ;;; Large file support for Solaris. Define some of the 64-bit types
263 ;;; we need. Unlike unix-glibc's large file support, Solaris's
264 ;;; version is a little simpler because all of the 64-bit versions of
265 ;;; the functions actually exist as functions. So instead of calling
266 ;;; the 32-bit versions of the functions, we call the 64-bit versions.
267 ;;;
268 ;;; These functions are: creat64, open64, truncate64, ftruncate64,
269 ;;; stat64, lstat64, fstat64, readdir64.
270 ;;;
271 ;;; There are also some new structures for large file support:
272 ;;; dirent64, stat64.
273 ;;;
274 ;;; FIXME: We should abstract this better, but I (rtoy) don't have any
275 ;;; other system to test this out on, so it's a Solaris hack for now.
276 #+solaris
277 (progn
278 (deftype file-offset64 () '(signed-byte 64))
279 (def-alien-type off64-t int64-t)
280 (def-alien-type ino64-t u-int64-t)
281 (def-alien-type blkcnt64-t u-int64-t))
282
283 (def-alien-type mode-t
284 #-(or alpha svr4) unsigned-short
285 #+alpha unsigned-int
286 #+svr4 unsigned-long)
287
288 (def-alien-type nlink-t
289 #-svr4 unsigned-short
290 #+svr4 unsigned-long)
291
292 (defconstant FD-SETSIZE
293 #-(or hpux alpha linux FreeBSD) 256
294 #+hpux 2048 #+alpha 4096 #+(or linux FreeBSD) 1024)
295
296 ;; not checked for linux...
297 (def-alien-type nil
298 (struct fd-set
299 (fds-bits (array #-alpha unsigned-long #+alpha int #.(/ fd-setsize 32)))))
300
301 ;; not checked for linux...
302 (defmacro fd-set (offset fd-set)
303 (let ((word (gensym))
304 (bit (gensym)))
305 `(multiple-value-bind (,word ,bit) (floor ,offset 32)
306 (setf (deref (slot ,fd-set 'fds-bits) ,word)
307 (logior (truly-the (unsigned-byte 32) (ash 1 ,bit))
308 (deref (slot ,fd-set 'fds-bits) ,word))))))
309
310 ;; not checked for linux...
311 (defmacro fd-clr (offset fd-set)
312 (let ((word (gensym))
313 (bit (gensym)))
314 `(multiple-value-bind (,word ,bit) (floor ,offset 32)
315 (setf (deref (slot ,fd-set 'fds-bits) ,word)
316 (logand (deref (slot ,fd-set 'fds-bits) ,word)
317 (32bit-logical-not
318 (truly-the (unsigned-byte 32) (ash 1 ,bit))))))))
319
320 ;; not checked for linux...
321 (defmacro fd-isset (offset fd-set)
322 (let ((word (gensym))
323 (bit (gensym)))
324 `(multiple-value-bind (,word ,bit) (floor ,offset 32)
325 (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
326
327 ;; not checked for linux...
328 (defmacro fd-zero (fd-set)
329 `(progn
330 ,@(loop for index upfrom 0 below (/ fd-setsize 32)
331 collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
332
333 ;;; From sys/time.h
334
335 (def-alien-type nil
336 (struct timeval
337 (tv-sec #-linux time-t #+linux int) ; seconds
338 (tv-usec #-linux time-t #+linux int))) ; and microseconds
339
340 (def-alien-type nil
341 (struct timezone
342 (tz-minuteswest int) ; minutes west of Greenwich
343 (tz-dsttime ; type of dst correction
344 #-linux (enum nil :none :usa :aust :wet :met :eet :can)
345 #+linux int)))
346
347 (def-alien-type nil
348 (struct itimerval
349 (it-interval (struct timeval)) ; timer interval
350 (it-value (struct timeval)))) ; current value
351
352 #+(or linux svr4)
353 ; High-res time. Actually posix definition under svr4 name.
354 (def-alien-type nil
355 (struct timestruc-t
356 (tv-sec time-t)
357 (tv-nsec long)))
358
359 #+(or linux BSD)
360 (def-alien-type nil
361 (struct timespec-t
362 (ts-sec long)
363 (ts-nsec long)))
364
365 ;;; From ioctl.h
366 (def-alien-type nil
367 (struct tchars
368 (t-intrc char) ; interrupt
369 (t-quitc char) ; quit
370 #+linux (t-eofc char)
371 (t-startc char) ; start output
372 (t-stopc char) ; stop output
373 #-linux (t-eofc char) ; end-of-file
374 (t-brkc char))) ; input delimiter (like nl)
375
376 ;; not found (semi) linux
377 (def-alien-type nil
378 (struct ltchars
379 #+linux (t-werasc char) ; word erase
380 (t-suspc char) ; stop process signal
381 (t-dsuspc char) ; delayed stop process signal
382 (t-rprntc char) ; reprint line
383 (t-flushc char) ; flush output (toggles)
384 #-linux (t-werasc char) ; word erase
385 (t-lnextc char))) ; literal next character
386
387
388 (def-alien-type nil
389 (struct sgttyb
390 #+linux (sg-flags #+mach short #-mach int) ; mode flags
391 (sg-ispeed char) ; input speed.
392 (sg-ospeed char) ; output speed
393 (sg-erase char) ; erase character
394 #-linux (sg-kill char) ; kill character
395 #-linux (sg-flags #+mach short #-mach int) ; mode flags
396 #+linux (sg-kill char)
397 #+linux (t (struct termios))
398 #+linux (check int)))
399
400 (def-alien-type nil
401 (struct winsize
402 (ws-row unsigned-short) ; rows, in characters
403 (ws-col unsigned-short) ; columns, in characters
404 (ws-xpixel unsigned-short) ; horizontal size, pixels
405 (ws-ypixel unsigned-short))) ; veritical size, pixels
406
407
408 ;;; From sys/termios.h
409
410 ;;; NOTE: There is both a termio (SYSV) and termios (POSIX)
411 ;;; structure with similar but incompatible definitions. It may be that
412 ;;; the non-BSD variant of termios below is really a termio but I (pw)
413 ;;; can't verify. The BSD variant uses the Posix termios def. Some systems
414 ;;; (Ultrix and OSF1) seem to support both if used independently.
415 ;;; The 17f version of this seems a bit confused wrt the conditionals.
416 ;;; Please check these defs for your system.
417
418 ;;; TSM: from what I can tell looking at the 17f definition, my guess is that it
419 ;;; was originally a termio for sunos (nonsolaris) (because it had the c-line
420 ;;; member for sunos only), and then was mutated into the termios definition for
421 ;;; later systems. The definition here is definitely not an IRIX termio because
422 ;;; it doesn't have c-line. In any case, the functions tcgetattr, etc.,
423 ;;; definitely take a termios, and termios seems to be the more standard
424 ;;; standard now, so my suggestion is to just go with termios and forget about
425 ;;; termio. Note the SVID says NCCS not NCC for the constant here, so I've
426 ;;; changed it (which means you need to bootstrap it to avoid a reader error).
427
428 ;;; On top of all that, SGI decided to change the termios structure on irix
429 ;;; 6.[34] (but NOT 6.2), left the old routines named the same in the library,
430 ;;; but introduced static functions in termios.h to redirect new calls to the
431 ;;; new library--which means it's important not to #include termios.h before
432 ;;; undefineds.h when building lisp.
433
434 (defconstant +NCCS+
435 #+hpux 16
436 #+irix 23
437 #+(or linux solaris) 19
438 #+(or bsd osf1) 20
439 #+(and sunos (not svr4)) 17
440 _N"Size of control character vector.")
441
442 (def-alien-type nil
443 (struct termios
444 (c-iflag unsigned-int)
445 (c-oflag unsigned-int)
446 (c-cflag unsigned-int)
447 (c-lflag unsigned-int)
448 #+(or linux hpux (and sunos (not svr4)))
449 (c-reserved #-(or linux (and sunos (not svr4))) unsigned-int
450 #+(or linux (and sunos (not svr4))) unsigned-char)
451 (c-cc (array unsigned-char #.+NCCS+))
452 #+(or bsd osf1) (c-ispeed unsigned-int)
453 #+(or bsd osf1) (c-ospeed unsigned-int)))
454
455 ;;; From sys/dir.h
456 ;;;
457 ;;; (For Solaris, this is not struct direct, but struct dirent!)
458 #-bsd
459 (def-alien-type nil
460 (struct direct
461 #+(and sunos (not svr4)) (d-off long) ; offset of next disk directory entry
462 (d-ino ino-t); inode number of entry
463 #+(or linux svr4) (d-off long)
464 (d-reclen unsigned-short) ; length of this record
465 #-(or linux svr4)
466 (d-namlen unsigned-short) ; length of string in d-name
467 (d-name (array char 256)))) ; name must be no longer than this
468
469 #+bsd
470 (def-alien-type nil
471 (struct direct
472 (d-fileno unsigned-long)
473 (d-reclen unsigned-short)
474 (d-type unsigned-char)
475 (d-namlen unsigned-char) ; length of string in d-name
476 (d-name (array char 256)))) ; name must be no longer than this
477
478 ;;; The 64-bit version of struct dirent.
479 #+solaris
480 (def-alien-type nil
481 (struct dirent64
482 (d-ino ino64-t); inode number of entry
483 (d-off off64-t) ; offset of next disk directory entry
484 (d-reclen unsigned-short) ; length of this record
485 (d-name (array char 256)))) ; name must be no longer than this
486
487
488 ;;; From sys/stat.h
489 ;; oh boy, in linux-> 2 stat(s)!!
490
491 #-(or svr4 bsd linux) ; eg hpux and alpha
492 (def-alien-type nil
493 (struct stat
494 (st-dev dev-t)
495 (st-ino ino-t)
496 (st-mode mode-t)
497 (st-nlink nlink-t)
498 (st-uid uid-t)
499 (st-gid gid-t)
500 (st-rdev dev-t)
501 (st-size off-t)
502 (st-atime time-t)
503 (st-spare1 int)
504 (st-mtime time-t)
505 (st-spare2 int)
506 (st-ctime time-t)
507 (st-spare3 int)
508 (st-blksize #-alpha long #+alpha unsigned-int)
509 (st-blocks #-alpha long #+alpha int)
510 (st-spare4 (array long 2))))
511
512 #+bsd
513 (def-alien-type nil
514 (struct stat
515 (st-dev dev-t)
516 (st-ino ino-t)
517 (st-mode mode-t)
518 (st-nlink nlink-t)
519 (st-uid uid-t)
520 (st-gid gid-t)
521 (st-rdev dev-t)
522 (st-atime (struct timespec-t))
523 (st-mtime (struct timespec-t))
524 (st-ctime (struct timespec-t))
525 (st-size off-t)
526 (st-blocks off-t)
527 (st-blksize unsigned-long)
528 (st-flags unsigned-long)
529 (st-gen unsigned-long)
530 (st-lspare long)
531 (st-qspare (array long 4))))
532
533 #+(or linux svr4)
534 (def-alien-type nil
535 (struct stat
536 (st-dev dev-t)
537 (st-pad1 #-linux (array long 3) #+linux unsigned-short)
538 (st-ino ino-t)
539 (st-mode #-linux unsigned-long #+linux unsigned-short)
540 (st-nlink #-linux short #+linux unsigned-short)
541 (st-uid #-linux uid-t #+linux unsigned-short)
542 (st-gid #-linux gid-t #+linux unsigned-short)
543 (st-rdev dev-t)
544 (st-pad2 #-linux (array long 2) #+linux unsigned-short)
545 (st-size off-t)
546 #-linux (st-pad3 long)
547 #+linux (st-blksize unsigned-long)
548 #+linux (st-blocks unsigned-long)
549 #-linux (st-atime (struct timestruc-t))
550 #+linux (st-atime unsigned-long)
551 #+linux (unused-1 unsigned-long)
552 #-linux (st-mtime (struct timestruc-t))
553 #+linux (st-mtime unsigned-long)
554 #+linux (unused-2 unsigned-long)
555 #-linux (st-ctime (struct timestruc-t))
556 #+linux (st-ctime unsigned-long)
557 #+linux (unused-3 unsigned-long)
558 #+linux (unused-4 unsigned-long)
559 #+linux (unused-5 unsigned-long)
560 #-linux(st-blksize long)
561 #-linux (st-blocks long)
562 #-linux (st-fstype (array char 16))
563 #-linux (st-pad4 (array long 8))))
564
565 ;;; 64-bit stat for Solaris
566 #+solaris
567 (def-alien-type nil
568 (struct stat64
569 (st-dev dev-t)
570 (st-pad1 (array long 3)) ; Pad so ino is 64-bit aligned
571 (st-ino ino64-t)
572 (st-mode unsigned-long)
573 (st-nlink short)
574 (st-uid uid-t)
575 (st-gid gid-t)
576 (st-rdev dev-t)
577 (st-pad2 (array long 3)) ; Pad so size is 64-bit aligned
578 (st-size off64-t)
579 (st-atime (struct timestruc-t))
580 (st-mtime (struct timestruc-t))
581 (st-ctime (struct timestruc-t))
582 (st-blksize long)
583 (st-pad3 (array long 1)) ; Pad so blocks is 64-bit aligned
584 (st-blocks blkcnt64-t)
585 (st-fstype (array char 16))
586 (st-pad4 (array long 8))))
587
588 (defconstant s-ifmt #o0170000)
589 (defconstant s-ifdir #o0040000)
590 (defconstant s-ifchr #o0020000)
591 #+linux (defconstant s-ififo #x0010000)
592 (defconstant s-ifblk #o0060000)
593 (defconstant s-ifreg #o0100000)
594 (defconstant s-iflnk #o0120000)
595 (defconstant s-ifsock #o0140000)
596 (defconstant s-isuid #o0004000)
597 (defconstant s-isgid #o0002000)
598 (defconstant s-isvtx #o0001000)
599 (defconstant s-iread #o0000400)
600 (defconstant s-iwrite #o0000200)
601 (defconstant s-iexec #o0000100)
602
603 ;;; From sys/resource.h
604
605 (def-alien-type nil
606 (struct rusage
607 (ru-utime (struct timeval)) ; user time used
608 (ru-stime (struct timeval)) ; system time used.
609 (ru-maxrss long)
610 (ru-ixrss long) ; integral sharded memory size
611 (ru-idrss long) ; integral unsharded data "
612 (ru-isrss long) ; integral unsharded stack "
613 (ru-minflt long) ; page reclaims
614 (ru-majflt long) ; page faults
615 (ru-nswap long) ; swaps
616 (ru-inblock long) ; block input operations
617 (ru-oublock long) ; block output operations
618 (ru-msgsnd long) ; messages sent
619 (ru-msgrcv long) ; messages received
620 (ru-nsignals long) ; signals received
621 (ru-nvcsw long) ; voluntary context switches
622 (ru-nivcsw long))) ; involuntary "
623
624 (def-alien-type nil
625 (struct rlimit
626 (rlim-cur #-(or linux alpha) int #+linux long #+alpha unsigned-int) ; current (soft) limit
627 (rlim-max #-(or linux alpha) int #+linux long #+alpha unsigned-int))); maximum value for rlim-cur
628
629
630
631 ;;;; Errno stuff.
632
633 (eval-when (compile eval)
634
635 (defparameter *compiler-unix-errors* nil)
636
637 (defmacro def-unix-error (name number description)
638 `(progn
639 (eval-when (compile eval)
640 (push (cons ,number ,description) *compiler-unix-errors*))
641 (defconstant ,name ,number ,description)
642 (export ',name)))
643
644 (defmacro emit-unix-errors ()
645 (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*)))
646 (array (make-array (1+ max) :initial-element nil)))
647 (dolist (error *compiler-unix-errors*)
648 (setf (svref array (car error)) (cdr error)))
649 `(progn
650 (defvar *unix-errors* ',array)
651 (declaim (simple-vector *unix-errors*)))))
652
653 ) ;eval-when
654
655 ;;;
656 ;;; From <errno.h>
657 ;;;
658 (def-unix-error ESUCCESS 0 _N"Successful")
659 (def-unix-error EPERM 1 _N"Operation not permitted")
660 (def-unix-error ENOENT 2 _N"No such file or directory")
661 (def-unix-error ESRCH 3 _N"No such process")
662 (def-unix-error EINTR 4 _N"Interrupted system call")
663 (def-unix-error EIO 5 _N"I/O error")
664 (def-unix-error ENXIO 6 _N"Device not configured")
665 (def-unix-error E2BIG 7 _N"Arg list too long")
666 (def-unix-error ENOEXEC 8 _N"Exec format error")
667 (def-unix-error EBADF 9 _N"Bad file descriptor")
668 (def-unix-error ECHILD 10 _N"No child process")
669 #+bsd(def-unix-error EDEADLK 11 _N"Resource deadlock avoided")
670 #-bsd(def-unix-error EAGAIN 11 #-linux _N"No more processes" #+linux _N"Try again")
671 (def-unix-error ENOMEM 12 _N"Out of memory")
672 (def-unix-error EACCES 13 _N"Permission denied")
673 (def-unix-error EFAULT 14 _N"Bad address")
674 (def-unix-error ENOTBLK 15 _N"Block device required")
675 (def-unix-error EBUSY 16 _N"Device or resource busy")
676 (def-unix-error EEXIST 17 _N"File exists")
677 (def-unix-error EXDEV 18 _N"Cross-device link")
678 (def-unix-error ENODEV 19 _N"No such device")
679 (def-unix-error ENOTDIR 20 _N"Not a director")
680 (def-unix-error EISDIR 21 _N"Is a directory")
681 (def-unix-error EINVAL 22 _N"Invalid argument")
682 (def-unix-error ENFILE 23 _N"File table overflow")
683 (def-unix-error EMFILE 24 _N"Too many open files")
684 (def-unix-error ENOTTY 25 _N"Inappropriate ioctl for device")
685 (def-unix-error ETXTBSY 26 _N"Text file busy")
686 (def-unix-error EFBIG 27 _N"File too large")
687 (def-unix-error ENOSPC 28 _N"No space left on device")
688 (def-unix-error ESPIPE 29 _N"Illegal seek")
689 (def-unix-error EROFS 30 _N"Read-only file system")
690 (def-unix-error EMLINK 31 _N"Too many links")
691 (def-unix-error EPIPE 32 _N"Broken pipe")
692 ;;;
693 ;;; Math
694 (def-unix-error EDOM 33 _N"Numerical argument out of domain")
695 (def-unix-error ERANGE 34 #-linux _N"Result too large" #+linux _N"Math result not representable")
696 ;;;
697 #-(or linux svr4)
698 (progn
699 ;;; non-blocking and interrupt i/o
700 (def-unix-error EWOULDBLOCK 35 _N"Operation would block")
701 #-bsd(def-unix-error EDEADLK 35 _N"Operation would block") ; Ditto
702 #+bsd(def-unix-error EAGAIN 35 _N"Resource temporarily unavailable")
703 (def-unix-error EINPROGRESS 36 _N"Operation now in progress")
704 (def-unix-error EALREADY 37 _N"Operation already in progress")
705 ;;;
706 ;;; ipc/network software
707 (def-unix-error ENOTSOCK 38 _N"Socket operation on non-socket")
708 (def-unix-error EDESTADDRREQ 39 _N"Destination address required")
709 (def-unix-error EMSGSIZE 40 _N"Message too long")
710 (def-unix-error EPROTOTYPE 41 _N"Protocol wrong type for socket")
711 (def-unix-error ENOPROTOOPT 42 _N"Protocol not available")
712 (def-unix-error EPROTONOSUPPORT 43 _N"Protocol not supported")
713 (def-unix-error ESOCKTNOSUPPORT 44 _N"Socket type not supported")
714 (def-unix-error EOPNOTSUPP 45 _N"Operation not supported on socket")
715 (def-unix-error EPFNOSUPPORT 46 _N"Protocol family not supported")
716 (def-unix-error EAFNOSUPPORT 47 _N"Address family not supported by protocol family")
717 (def-unix-error EADDRINUSE 48 _N"Address already in use")
718 (def-unix-error EADDRNOTAVAIL 49 _N"Can't assign requested address")
719 ;;;
720 ;;; operational errors
721 (def-unix-error ENETDOWN 50 _N"Network is down")
722 (def-unix-error ENETUNREACH 51 _N"Network is unreachable")
723 (def-unix-error ENETRESET 52 _N"Network dropped connection on reset")
724 (def-unix-error ECONNABORTED 53 _N"Software caused connection abort")
725 (def-unix-error ECONNRESET 54 _N"Connection reset by peer")
726 (def-unix-error ENOBUFS 55 _N"No buffer space available")
727 (def-unix-error EISCONN 56 _N"Socket is already connected")
728 (def-unix-error ENOTCONN 57 _N"Socket is not connected")
729 (def-unix-error ESHUTDOWN 58 _N"Can't send after socket shutdown")
730 (def-unix-error ETOOMANYREFS 59 _N"Too many references: can't splice")
731 (def-unix-error ETIMEDOUT 60 _N"Connection timed out")
732 (def-unix-error ECONNREFUSED 61 _N"Connection refused")
733 ;;;
734 (def-unix-error ELOOP 62 _N"Too many levels of symbolic links")
735 (def-unix-error ENAMETOOLONG 63 _N"File name too long")
736 ;;;
737 (def-unix-error EHOSTDOWN 64 _N"Host is down")
738 (def-unix-error EHOSTUNREACH 65 _N"No route to host")
739 (def-unix-error ENOTEMPTY 66 _N"Directory not empty")
740 ;;;
741 ;;; quotas & resource
742 (def-unix-error EPROCLIM 67 _N"Too many processes")
743 (def-unix-error EUSERS 68 _N"Too many users")
744 (def-unix-error EDQUOT 69 _N"Disc quota exceeded")
745 ;;;
746 ;;; CMU RFS
747 (def-unix-error ELOCAL 126 _N"namei should continue locally")
748 (def-unix-error EREMOTE 127 _N"namei was handled remotely")
749 ;;;
750 ;;; VICE
751 (def-unix-error EVICEERR 70 _N"Remote file system error _N")
752 (def-unix-error EVICEOP 71 _N"syscall was handled by Vice")
753 )
754 #+svr4
755 (progn
756 (def-unix-error ENOMSG 35 _N"No message of desired type")
757 (def-unix-error EIDRM 36 _N"Identifier removed")
758 (def-unix-error ECHRNG 37 _N"Channel number out of range")
759 (def-unix-error EL2NSYNC 38 _N"Level 2 not synchronized")
760 (def-unix-error EL3HLT 39 _N"Level 3 halted")
761 (def-unix-error EL3RST 40 _N"Level 3 reset")
762 (def-unix-error ELNRNG 41 _N"Link number out of range")
763 (def-unix-error EUNATCH 42 _N"Protocol driver not attached")
764 (def-unix-error ENOCSI 43 _N"No CSI structure available")
765 (def-unix-error EL2HLT 44 _N"Level 2 halted")
766 (def-unix-error EDEADLK 45 _N"Deadlock situation detected/avoided")
767 (def-unix-error ENOLCK 46 _N"No record locks available")
768 (def-unix-error ECANCELED 47 _N"Error 47")
769 (def-unix-error ENOTSUP 48 _N"Error 48")
770 (def-unix-error EBADE 50 _N"Bad exchange descriptor")
771 (def-unix-error EBADR 51 _N"Bad request descriptor")
772 (def-unix-error EXFULL 52 _N"Message tables full")
773 (def-unix-error ENOANO 53 _N"Anode table overflow")
774 (def-unix-error EBADRQC 54 _N"Bad request code")
775 (def-unix-error EBADSLT 55 _N"Invalid slot")
776 (def-unix-error EDEADLOCK 56 _N"File locking deadlock")
777 (def-unix-error EBFONT 57 _N"Bad font file format")
778 (def-unix-error ENOSTR 60 _N"Not a stream device")
779 (def-unix-error ENODATA 61 _N"No data available")
780 (def-unix-error ETIME 62 _N"Timer expired")
781 (def-unix-error ENOSR 63 _N"Out of stream resources")
782 (def-unix-error ENONET 64 _N"Machine is not on the network")
783 (def-unix-error ENOPKG 65 _N"Package not installed")
784 (def-unix-error EREMOTE 66 _N"Object is remote")
785 (def-unix-error ENOLINK 67 _N"Link has been severed")
786 (def-unix-error EADV 68 _N"Advertise error")
787 (def-unix-error ESRMNT 69 _N"Srmount error")
788 (def-unix-error ECOMM 70 _N"Communication error on send")
789 (def-unix-error EPROTO 71 _N"Protocol error")
790 (def-unix-error EMULTIHOP 74 _N"Multihop attempted")
791 (def-unix-error EBADMSG 77 _N"Not a data message")
792 (def-unix-error ENAMETOOLONG 78 _N"File name too long")
793 (def-unix-error EOVERFLOW 79 _N"Value too large for defined data type")
794 (def-unix-error ENOTUNIQ 80 _N"Name not unique on network")
795 (def-unix-error EBADFD 81 _N"File descriptor in bad state")
796 (def-unix-error EREMCHG 82 _N"Remote address changed")
797 (def-unix-error ELIBACC 83 _N"Can not access a needed shared library")
798 (def-unix-error ELIBBAD 84 _N"Accessing a corrupted shared library")
799 (def-unix-error ELIBSCN 85 _N".lib section in a.out corrupted")
800 (def-unix-error ELIBMAX 86 _N"Attempting to link in more shared libraries than system limit")
801 (def-unix-error ELIBEXEC 87 _N"Can not exec a shared library directly")
802 (def-unix-error EILSEQ 88 _N"Error 88")
803 (def-unix-error ENOSYS 89 _N"Operation not applicable")
804 (def-unix-error ELOOP 90 _N"Number of symbolic links encountered during path name traversal exceeds MAXSYMLINKS")
805 (def-unix-error ERESTART 91 _N"Error 91")
806 (def-unix-error ESTRPIPE 92 _N"Error 92")
807 (def-unix-error ENOTEMPTY 93 _N"Directory not empty")
808 (def-unix-error EUSERS 94 _N"Too many users")
809 (def-unix-error ENOTSOCK 95 _N"Socket operation on non-socket")
810 (def-unix-error EDESTADDRREQ 96 _N"Destination address required")
811 (def-unix-error EMSGSIZE 97 _N"Message too long")
812 (def-unix-error EPROTOTYPE 98 _N"Protocol wrong type for socket")
813 (def-unix-error ENOPROTOOPT 99 _N"Option not supported by protocol")
814 (def-unix-error EPROTONOSUPPORT 120 _N"Protocol not supported")
815 (def-unix-error ESOCKTNOSUPPORT 121 _N"Socket type not supported")
816 (def-unix-error EOPNOTSUPP 122 _N"Operation not supported on transport endpoint")
817 (def-unix-error EPFNOSUPPORT 123 _N"Protocol family not supported")
818 (def-unix-error EAFNOSUPPORT 124 _N"Address family not supported by protocol family")
819 (def-unix-error EADDRINUSE 125 _N"Address already in use")
820 (def-unix-error EADDRNOTAVAIL 126 _N"Cannot assign requested address")
821 (def-unix-error ENETDOWN 127 _N"Network is down")
822 (def-unix-error ENETUNREACH 128 _N"Network is unreachable")
823 (def-unix-error ENETRESET 129 _N"Network dropped connection because of reset")
824 (def-unix-error ECONNABORTED 130 _N"Software caused connection abort")
825 (def-unix-error ECONNRESET 131 _N"Connection reset by peer")
826 (def-unix-error ENOBUFS 132 _N"No buffer space available")
827 (def-unix-error EISCONN 133 _N"Transport endpoint is already connected")
828 (def-unix-error ENOTCONN 134 _N"Transport endpoint is not connected")
829 (def-unix-error ESHUTDOWN 143 _N"Cannot send after socket shutdown")
830 (def-unix-error ETOOMANYREFS 144 _N"Too many references: cannot splice")
831 (def-unix-error ETIMEDOUT 145 _N"Connection timed out")
832 (def-unix-error ECONNREFUSED 146 _N"Connection refused")
833 (def-unix-error EHOSTDOWN 147 _N"Host is down")
834 (def-unix-error EHOSTUNREACH 148 _N"No route to host")
835 (def-unix-error EWOULDBLOCK 11 _N"Resource temporarily unavailable")
836 (def-unix-error EALREADY 149 _N"Operation already in progress")
837 (def-unix-error EINPROGRESS 150 _N"Operation now in progress")
838 (def-unix-error ESTALE 151 _N"Stale NFS file handle")
839 )
840 #+linux
841 (progn
842 (def-unix-error EDEADLK 35 _N"Resource deadlock would occur")
843 (def-unix-error ENAMETOOLONG 36 _N"File name too long")
844 (def-unix-error ENOLCK 37 _N"No record locks available")
845 (def-unix-error ENOSYS 38 _N"Function not implemented")
846 (def-unix-error ENOTEMPTY 39 _N"Directory not empty")
847 (def-unix-error ELOOP 40 _N"Too many symbolic links encountered")
848 (def-unix-error EWOULDBLOCK 11 _N"Operation would block")
849 (def-unix-error ENOMSG 42 _N"No message of desired type")
850 (def-unix-error EIDRM 43 _N"Identifier removed")
851 (def-unix-error ECHRNG 44 _N"Channel number out of range")
852 (def-unix-error EL2NSYNC 45 _N"Level 2 not synchronized")
853 (def-unix-error EL3HLT 46 _N"Level 3 halted")
854 (def-unix-error EL3RST 47 _N"Level 3 reset")
855 (def-unix-error ELNRNG 48 _N"Link number out of range")
856 (def-unix-error EUNATCH 49 _N"Protocol driver not attached")
857 (def-unix-error ENOCSI 50 _N"No CSI structure available")
858 (def-unix-error EL2HLT 51 _N"Level 2 halted")
859 (def-unix-error EBADE 52 _N"Invalid exchange")
860 (def-unix-error EBADR 53 _N"Invalid request descriptor")
861 (def-unix-error EXFULL 54 _N"Exchange full")
862 (def-unix-error ENOANO 55 _N"No anode")
863 (def-unix-error EBADRQC 56 _N"Invalid request code")
864 (def-unix-error EBADSLT 57 _N"Invalid slot")
865 (def-unix-error EDEADLOCK EDEADLK _N"File locking deadlock error")
866 (def-unix-error EBFONT 59 _N"Bad font file format")
867 (def-unix-error ENOSTR 60 _N"Device not a stream")
868 (def-unix-error ENODATA 61 _N"No data available")
869 (def-unix-error ETIME 62 _N"Timer expired")
870 (def-unix-error ENOSR 63 _N"Out of streams resources")
871 (def-unix-error ENONET 64 _N"Machine is not on the network")
872 (def-unix-error ENOPKG 65 _N"Package not installed")
873 (def-unix-error EREMOTE 66 _N"Object is remote")
874 (def-unix-error ENOLINK 67 _N"Link has been severed")
875 (def-unix-error EADV 68 _N"Advertise error")
876 (def-unix-error ESRMNT 69 _N"Srmount error")
877 (def-unix-error ECOMM 70 _N"Communication error on send")
878 (def-unix-error EPROTO 71 _N"Protocol error")
879 (def-unix-error EMULTIHOP 72 _N"Multihop attempted")
880 (def-unix-error EDOTDOT 73 _N"RFS specific error")
881 (def-unix-error EBADMSG 74 _N"Not a data message")
882 (def-unix-error EOVERFLOW 75 _N"Value too large for defined data type")
883 (def-unix-error ENOTUNIQ 76 _N"Name not unique on network")
884 (def-unix-error EBADFD 77 _N"File descriptor in bad state")
885 (def-unix-error EREMCHG 78 _N"Remote address changed")
886 (def-unix-error ELIBACC 79 _N"Can not access a needed shared library")
887 (def-unix-error ELIBBAD 80 _N"Accessing a corrupted shared library")
888 (def-unix-error ELIBSCN 81 _N".lib section in a.out corrupted")
889 (def-unix-error ELIBMAX 82 _N"Attempting to link in too many shared libraries")
890 (def-unix-error ELIBEXEC 83 _N"Cannot exec a shared library directly")
891 (def-unix-error EILSEQ 84 _N"Illegal byte sequence")
892 (def-unix-error ERESTART 85 _N"Interrupted system call should be restarted _N")
893 (def-unix-error ESTRPIPE 86 _N"Streams pipe error")
894 (def-unix-error EUSERS 87 _N"Too many users")
895 (def-unix-error ENOTSOCK 88 _N"Socket operation on non-socket")
896 (def-unix-error EDESTADDRREQ 89 _N"Destination address required")
897 (def-unix-error EMSGSIZE 90 _N"Message too long")
898 (def-unix-error EPROTOTYPE 91 _N"Protocol wrong type for socket")
899 (def-unix-error ENOPROTOOPT 92 _N"Protocol not available")
900 (def-unix-error EPROTONOSUPPORT 93 _N"Protocol not supported")
901 (def-unix-error ESOCKTNOSUPPORT 94 _N"Socket type not supported")
902 (def-unix-error EOPNOTSUPP 95 _N"Operation not supported on transport endpoint")
903 (def-unix-error EPFNOSUPPORT 96 _N"Protocol family not supported")
904 (def-unix-error EAFNOSUPPORT 97 _N"Address family not supported by protocol")
905 (def-unix-error EADDRINUSE 98 _N"Address already in use")
906 (def-unix-error EADDRNOTAVAIL 99 _N"Cannot assign requested address")
907 (def-unix-error ENETDOWN 100 _N"Network is down")
908 (def-unix-error ENETUNREACH 101 _N"Network is unreachable")
909 (def-unix-error ENETRESET 102 _N"Network dropped connection because of reset")
910 (def-unix-error ECONNABORTED 103 _N"Software caused connection abort")
911 (def-unix-error ECONNRESET 104 _N"Connection reset by peer")
912 (def-unix-error ENOBUFS 105 _N"No buffer space available")
913 (def-unix-error EISCONN 106 _N"Transport endpoint is already connected")
914 (def-unix-error ENOTCONN 107 _N"Transport endpoint is not connected")
915 (def-unix-error ESHUTDOWN 108 _N"Cannot send after transport endpoint shutdown")
916 (def-unix-error ETOOMANYREFS 109 _N"Too many references: cannot splice")
917 (def-unix-error ETIMEDOUT 110 _N"Connection timed out")
918 (def-unix-error ECONNREFUSED 111 _N"Connection refused")
919 (def-unix-error EHOSTDOWN 112 _N"Host is down")
920 (def-unix-error EHOSTUNREACH 113 _N"No route to host")
921 (def-unix-error EALREADY 114 _N"Operation already in progress")
922 (def-unix-error EINPROGRESS 115 _N"Operation now in progress")
923 (def-unix-error ESTALE 116 _N"Stale NFS file handle")
924 (def-unix-error EUCLEAN 117 _N"Structure needs cleaning")
925 (def-unix-error ENOTNAM 118 _N"Not a XENIX named type file")
926 (def-unix-error ENAVAIL 119 _N"No XENIX semaphores available")
927 (def-unix-error EISNAM 120 _N"Is a named type file")
928 (def-unix-error EREMOTEIO 121 _N"Remote I/O error")
929 (def-unix-error EDQUOT 122 _N"Quota exceeded")
930 )
931
932 ;;;
933 ;;; And now for something completely different ...
934 (emit-unix-errors)
935
936 (def-alien-routine ("os_get_errno" unix-get-errno) int)
937 (def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int))
938 (defun unix-errno () (unix-get-errno))
939 (defun (setf unix-errno) (newvalue) (unix-set-errno newvalue))
940
941 ;;; GET-UNIX-ERROR-MSG -- public.
942 ;;;
943 (defun get-unix-error-msg (&optional (error-number (unix-errno)))
944 _N"Returns a string describing the error number which was returned by a
945 UNIX system call."
946 (declare (type integer error-number))
947 (if (array-in-bounds-p *unix-errors* error-number)
948 (svref *unix-errors* error-number)
949 (format nil _"Unknown error [~d]" error-number)))
950
951
952 ;;;; Lisp types used by syscalls.
953
954 (deftype unix-pathname () 'simple-string)
955 (deftype unix-fd () `(integer 0 ,most-positive-fixnum))
956
957 (deftype unix-file-mode () '(unsigned-byte 32))
958 (deftype unix-pid () '(unsigned-byte 32))
959 (deftype unix-uid () '(unsigned-byte 32))
960 (deftype unix-gid () '(unsigned-byte 32))
961
962
963
964 ;;;; User and group database structures
965
966 (defstruct user-info
967 (name "" :type string)
968 (password "" :type string)
969 (uid 0 :type unix-uid)
970 (gid 0 :type unix-gid)
971 #+solaris (age "" :type string)
972 #+solaris (comment "" :type string)
973 #+freebsd (change -1 :type fixnum)
974 (gecos "" :type string)
975 (dir "" :type string)
976 (shell "" :type string))
977
978 (defstruct group-info
979 (name "" :type string)
980 (password "" :type string)
981 (gid 0 :type unix-gid)
982 (members nil :type list)) ; list of logins as strings
983
984 ;; see <pwd.h>
985 #+solaris
986 (def-alien-type nil
987 (struct passwd
988 (pw-name (* char)) ; user's login name
989 (pw-passwd (* char)) ; no longer used
990 (pw-uid uid-t) ; user id
991 (pw-gid gid-t) ; group id
992 (pw-age (* char)) ; password age (not used)
993 (pw-comment (* char)) ; not used
994 (pw-gecos (* char)) ; typically user's full name
995 (pw-dir (* char)) ; user's home directory
996 (pw-shell (* char)))) ; user's login shell
997
998 #+bsd
999 (def-alien-type nil
1000 (struct passwd
1001 (pw-name (* char)) ; user's login name
1002 (pw-passwd (* char)) ; no longer used
1003 (pw-uid uid-t) ; user id
1004 (pw-gid gid-t) ; group id
1005 (pw-change int) ; password change time
1006 (pw-class (* char)) ; user access class
1007 (pw-gecos (* char)) ; typically user's full name
1008 (pw-dir (* char)) ; user's home directory
1009 (pw-shell (* char)) ; user's login shell
1010 (pw-expire int) ; account expiration
1011 #+(or freebsd darwin)
1012 (pw-fields int))) ; internal
1013
1014 ;; see <grp.h>
1015 (def-alien-type nil
1016 (struct group
1017 (gr-name (* char)) ; name of the group
1018 (gr-passwd (* char)) ; encrypted group password
1019 (gr-gid gid-t) ; numerical group ID
1020 (gr-mem (* (* char))))) ; vector of pointers to member names
1021
1022
1023 ;;;; System calls.
1024
1025 (defmacro %syscall ((name (&rest arg-types) result-type)
1026 success-form &rest args)
1027 `(let* ((fn (extern-alien ,name (function ,result-type ,@arg-types)))
1028 (result (alien-funcall fn ,@args)))
1029 (if (eql -1 result)
1030 (values nil (unix-errno))
1031 ,success-form)))
1032
1033 (defmacro syscall ((name &rest arg-types) success-form &rest args)
1034 `(%syscall (,name (,@arg-types) int) ,success-form ,@args))
1035
1036 ;;; Like syscall, but if it fails, signal an error instead of returing error
1037 ;;; codes. Should only be used for syscalls that will never really get an
1038 ;;; error.
1039 ;;;
1040 (defmacro syscall* ((name &rest arg-types) success-form &rest args)
1041 `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
1042 ,@args)))
1043 (if (eql -1 result)
1044 (error _"Syscall ~A failed: ~A" ,name (get-unix-error-msg))
1045 ,success-form)))
1046
1047 (defmacro void-syscall ((name &rest arg-types) &rest args)
1048 `(syscall (,name ,@arg-types) (values t 0) ,@args))
1049
1050 (defmacro int-syscall ((name &rest arg-types) &rest args)
1051 `(syscall (,name ,@arg-types) (values result 0) ,@args))
1052
1053 (defmacro off-t-syscall ((name arg-types) &rest args)
1054 `(%syscall (,name ,arg-types off-t) (values result 0) ,@args))
1055
1056
1057 ;;;; Memory-mapped files
1058
1059 (defconstant +null+ (sys:int-sap 0))
1060
1061 (defconstant prot_read 1) ; Readable
1062 (defconstant prot_write 2) ; Writable
1063 (defconstant prot_exec 4) ; Executable
1064 (defconstant prot_none 0) ; No access
1065
1066 (defconstant map_shared 1) ; Changes are shared
1067 (defconstant map_private 2) ; Changes are private
1068 (defconstant map_fixed 16) ; Fixed, user-defined address
1069 (defconstant map_noreserve #x40) ; Don't reserve swap space
1070 (defconstant map_anonymous
1071 #+solaris #x100 ; Solaris
1072 #+linux 32 ; Linux
1073 #+bsd #x1000)
1074
1075 (defconstant ms_async 1)
1076 (defconstant ms_sync 4)
1077 (defconstant ms_invalidate 2)
1078
1079 ;; The return value from mmap that means mmap failed.
1080 (defconstant map_failed (int-sap (1- (ash 1 vm:word-bits))))
1081
1082 (defun unix-mmap (addr length prot flags fd offset)
1083 (declare (type (or null system-area-pointer) addr)
1084 (type (unsigned-byte 32) length)
1085 (type (integer 1 7) prot)
1086 (type (unsigned-byte 32) flags)
1087 (type (or null unix-fd) fd)
1088 (type file-offset offset))
1089 ;; Can't use syscall, because the address that is returned could be
1090 ;; "negative". Hence we explicitly check for mmap returning
1091 ;; MAP_FAILED.
1092 (let ((result
1093 (alien-funcall (extern-alien "mmap" (function system-area-pointer
1094 system-area-pointer
1095 size-t int int int off-t))
1096 (or addr +null+) length prot flags (or fd -1) offset)))
1097 (if (sap= result map_failed)
1098 (values nil (unix-errno))
1099 (values result 0))))
1100
1101 (defun unix-munmap (addr length)
1102 (declare (type system-area-pointer addr)
1103 (type (unsigned-byte 32) length))
1104 (syscall ("munmap" system-area-pointer size-t) t addr length))
1105
1106 (defun unix-mprotect (addr length prot)
1107 (declare (type system-area-pointer addr)
1108 (type (unsigned-byte 32) length)
1109 (type (integer 1 7) prot))
1110 (syscall ("mprotect" system-area-pointer size-t int)
1111 t addr length prot))
1112
1113 (defun unix-setuid (uid)
1114 _N"Set the user ID of the calling process to UID.
1115 If the calling process is the super-user, set the real
1116 and effective user IDs, and the saved set-user-ID to UID;
1117 if not, the effective user ID is set to UID."
1118 (int-syscall ("setuid" uid-t) uid))
1119
1120 (defun unix-setgid (gid)
1121 _N"Set the group ID of the calling process to GID.
1122 If the calling process is the super-user, set the real
1123 and effective group IDs, and the saved set-group-ID to GID;
1124 if not, the effective group ID is set to GID."
1125 (int-syscall ("setgid" gid-t) gid))
1126
1127
1128
1129 (defun unix-msync (addr length flags)
1130 (declare (type system-area-pointer addr)
1131 (type (unsigned-byte 32) length)
1132 (type (signed-byte 32) flags))
1133 (syscall ("msync" system-area-pointer size-t int) t addr length flags))
1134
1135 ;;; Unix-access accepts a path and a mode. It returns two values the
1136 ;;; first is T if the file is accessible and NIL otherwise. The second
1137 ;;; only has meaning in the second case and is the unix errno value.
1138
1139 (defconstant r_ok 4 _N"Test for read permission")
1140 (defconstant w_ok 2 _N"Test for write permission")
1141 (defconstant x_ok 1 _N"Test for execute permission")
1142 (defconstant f_ok 0 _N"Test for presence of file")
1143
1144 (defun unix-access (path mode)
1145 _N"Given a file path (a string) and one of four constant modes,
1146 unix-access returns T if the file is accessible with that
1147 mode and NIL if not. It also returns an errno value with
1148 NIL which determines why the file was not accessible.
1149
1150 The access modes are:
1151 r_ok Read permission.
1152 w_ok Write permission.
1153 x_ok Execute permission.
1154 f_ok Presence of file."
1155 (declare (type unix-pathname path)
1156 (type (mod 8) mode))
1157 (void-syscall ("access" c-string int) (%name->file path) mode))
1158
1159 ;;; Unix-chdir accepts a directory name and makes that the
1160 ;;; current working directory.
1161
1162 (defun unix-chdir (path)
1163 _N"Given a file path string, unix-chdir changes the current working
1164 directory to the one specified."
1165 (declare (type unix-pathname path))
1166 (void-syscall ("chdir" c-string) (%name->file path)))
1167
1168 ;;; Unix-chmod accepts a path and a mode and changes the mode to the new mode.
1169
1170 (defconstant setuidexec #o4000 _N"Set user ID on execution")
1171 (defconstant setgidexec #o2000 _N"Set group ID on execution")
1172 (defconstant savetext #o1000 _N"Save text image after execution")
1173 (defconstant readown #o400 _N"Read by owner")
1174 (defconstant writeown #o200 _N"Write by owner")
1175 (defconstant execown #o100 _N"Execute (search directory) by owner")
1176 (defconstant readgrp #o40 _N"Read by group")
1177 (defconstant writegrp #o20 _N"Write by group")
1178 (defconstant execgrp #o10 _N"Execute (search directory) by group")
1179 (defconstant readoth #o4 _N"Read by others")
1180 (defconstant writeoth #o2 _N"Write by others")
1181 (defconstant execoth #o1 _N"Execute (search directory) by others")
1182
1183 (defun unix-chmod (path mode)
1184 _N"Given a file path string and a constant mode, unix-chmod changes the
1185 permission mode for that file to the one specified. The new mode
1186 can be created by logically OR'ing the following:
1187
1188 setuidexec Set user ID on execution.
1189 setgidexec Set group ID on execution.
1190 savetext Save text image after execution.
1191 readown Read by owner.
1192 writeown Write by owner.
1193 execown Execute (search directory) by owner.
1194 readgrp Read by group.
1195 writegrp Write by group.
1196 execgrp Execute (search directory) by group.
1197 readoth Read by others.
1198 writeoth Write by others.
1199 execoth Execute (search directory) by others.
1200
1201 Thus #o444 and (logior unix:readown unix:readgrp unix:readoth)
1202 are equivalent for 'mode. The octal-base is familar to Unix users.
1203
1204 It returns T on successfully completion; NIL and an error number
1205 otherwise."
1206 (declare (type unix-pathname path)
1207 (type unix-file-mode mode))
1208 (void-syscall ("chmod" c-string int) (%name->file path) mode))
1209
1210 ;;; Unix-fchmod accepts a file descriptor ("fd") and a file protection mode
1211 ;;; ("mode") and changes the protection of the file described by "fd" to
1212 ;;; "mode".
1213
1214 (defun unix-fchmod (fd mode)
1215 _N"Given an integer file descriptor and a mode (the same as those
1216 used for unix-chmod), unix-fchmod changes the permission mode
1217 for that file to the one specified. T is returned if the call
1218 was successful."
1219 (declare (type unix-fd fd)
1220 (type unix-file-mode mode))
1221 (void-syscall ("fchmod" int int) fd mode))
1222
1223 (defun unix-chown (path uid gid)
1224 _N"Given a file path, an integer user-id, and an integer group-id,
1225 unix-chown changes the owner of the file and the group of the
1226 file to those specified. Either the owner or the group may be
1227 left unchanged by specifying them as -1. Note: Permission will
1228 fail if the caller is not the superuser."
1229 (declare (type unix-pathname path)
1230 (type (or unix-uid (integer -1 -1)) uid)
1231 (type (or unix-gid (integer -1 -1)) gid))
1232 (void-syscall ("chown" c-string int int) (%name->file path) uid gid))
1233
1234 ;;; Unix-fchown is exactly the same as unix-chown except that the file
1235 ;;; is specified by a file-descriptor ("fd") instead of a pathname.
1236
1237 (defun unix-fchown (fd uid gid)
1238 _N"Unix-fchown is like unix-chown, except that it accepts an integer
1239 file descriptor instead of a file path name."
1240 (declare (type unix-fd fd)
1241 (type (or unix-uid (integer -1 -1)) uid)
1242 (type (or unix-gid (integer -1 -1)) gid))
1243 (void-syscall ("fchown" int int int) fd uid gid))
1244
1245 ;;; Returns the maximum size (i.e. the number of array elements
1246 ;;; of the file descriptor table.
1247
1248 (defun unix-getdtablesize ()
1249 _N"Unix-getdtablesize returns the maximum size of the file descriptor
1250 table. (i.e. the maximum number of descriptors that can exist at
1251 one time.)"
1252 (int-syscall ("getdtablesize")))
1253
1254 ;;; Unix-close accepts a file descriptor and attempts to close the file
1255 ;;; associated with it.
1256
1257 (defun unix-close (fd)
1258 _N"Unix-close takes an integer file descriptor as an argument and
1259 closes the file associated with it. T is returned upon successful
1260 completion, otherwise NIL and an error number."
1261 (declare (type unix-fd fd))
1262 (void-syscall ("close" int) fd))
1263
1264 ;;; Unix-creat accepts a file name and a mode. It creates a new file
1265 ;;; with name and sets it mode to mode (as for chmod).
1266
1267 (defun unix-creat (name mode)
1268 _N"Unix-creat accepts a file name and a mode (same as those for
1269 unix-chmod) and creates a file by that name with the specified
1270 permission mode. It returns a file descriptor on success,
1271 or NIL and an error number otherwise.
1272
1273 This interface is made obsolete by UNIX-OPEN."
1274
1275 (declare (type unix-pathname name)
1276 (type unix-file-mode mode))
1277 (int-syscall (#+solaris "creat64" #-solaris "creat" c-string int)
1278 (%name->file name) mode))
1279
1280 ;;; Unix-dup returns a duplicate copy of the existing file-descriptor
1281 ;;; passed as an argument.
1282
1283 (defun unix-dup (fd)
1284 _N"Unix-dup duplicates an existing file descriptor (given as the
1285 argument) and return it. If FD is not a valid file descriptor, NIL
1286 and an error number are returned."
1287 (declare (type unix-fd fd))
1288 (int-syscall ("dup" int) fd))
1289
1290 ;;; Unix-dup2 makes the second file-descriptor describe the same file
1291 ;;; as the first. If the second file-descriptor points to an open
1292 ;;; file, it is first closed. In any case, the second should have a
1293 ;;; value which is a valid file-descriptor.
1294
1295 (defun unix-dup2 (fd1 fd2)
1296 _N"Unix-dup2 duplicates an existing file descriptor just as unix-dup
1297 does only the new value of the duplicate descriptor may be requested
1298 through the second argument. If a file already exists with the
1299 requested descriptor number, it will be closed and the number
1300 assigned to the duplicate."
1301 (declare (type unix-fd fd1 fd2))
1302 (void-syscall ("dup2" int int) fd1 fd2))
1303
1304 ;;; Unix-fcntl takes a file descriptor, an integer command
1305 ;;; number, and optional command arguments. It performs
1306 ;;; operations on the associated file and/or returns inform-
1307 ;;; ation about the file.
1308
1309 ;;; Operations performed on file descriptors:
1310
1311 (defconstant F-DUPFD 0 _N"Duplicate a file descriptor")
1312 (defconstant F-GETFD 1 _N"Get file desc. flags")
1313 (defconstant F-SETFD 2 _N"Set file desc. flags")
1314 (defconstant F-GETFL 3 _N"Get file flags")
1315 (defconstant F-SETFL 4 _N"Set file flags")
1316 #-(or linux svr4)
1317 (defconstant F-GETOWN 5 _N"Get owner")
1318 #+svr4
1319 (defconstant F-GETOWN 23 _N"Get owner")
1320 #+linux
1321 (defconstant F-GETLK 5 _N"Get lock")
1322 #-(or linux svr4)
1323 (defconstant F-SETOWN 6 _N"Set owner")
1324 #+svr4
1325 (defconstant F-SETOWN 24 _N"Set owner")
1326 #+linux
1327 (defconstant F-SETLK 6 _N"Set lock")
1328 #+linux
1329 (defconstant F-SETLKW 7 _N"Set lock, wait for release")
1330 #+linux
1331 (defconstant F-SETOWN 8 _N"Set owner")
1332
1333 ;;; File flags for F-GETFL and F-SETFL:
1334
1335 (defconstant FNDELAY #-osf1 #o0004 #+osf1 #o100000 _N"Non-blocking reads")
1336 (defconstant FAPPEND #-linux #o0010 #+linux #o2000 _N"Append on each write")
1337 (defconstant FASYNC #-(or linux svr4) #o0100 #+svr4 #o10000 #+linux #o20000
1338 _N"Signal pgrp when data ready")
1339 ;; doesn't exist in Linux ;-(
1340 #-linux (defconstant FCREAT #-(or hpux svr4) #o1000 #+(or hpux svr4) #o0400
1341 _N"Create if nonexistant")
1342 #-linux (defconstant FTRUNC #-(or hpux svr4) #o2000 #+(or hpux svr4) #o1000
1343 _N"Truncate to zero length")
1344 #-linux (defconstant FEXCL #-(or hpux svr4) #o4000 #+(or hpux svr4) #o2000
1345 _N"Error if already created")
1346
1347 (defun unix-fcntl (fd cmd arg)
1348 _N"Unix-fcntl manipulates file descriptors according to the
1349 argument CMD which can be one of the following:
1350
1351 F-DUPFD Duplicate a file descriptor.
1352 F-GETFD Get file descriptor flags.
1353 F-SETFD Set file descriptor flags.
1354 F-GETFL Get file flags.
1355 F-SETFL Set file flags.
1356 F-GETOWN Get owner.
1357 F-SETOWN Set owner.
1358
1359 The flags that can be specified for F-SETFL are:
1360
1361 FNDELAY Non-blocking reads.
1362 FAPPEND Append on each write.
1363 FASYNC Signal pgrp when data ready.
1364 FCREAT Create if nonexistant.
1365 FTRUNC Truncate to zero length.
1366 FEXCL Error if already created.
1367 "
1368 (declare (type unix-fd fd)
1369 (type (unsigned-byte 32) cmd)
1370 (type (unsigned-byte 32) arg))
1371 (int-syscall ("fcntl" int unsigned-int unsigned-int) fd cmd arg))
1372
1373 ;;; Unix-link creates a hard link from name2 to name1.
1374
1375 (defun unix-link (name1 name2)
1376 _N"Unix-link creates a hard link from the file with name1 to the
1377 file with name2."
1378 (declare (type unix-pathname name1 name2))
1379 (void-syscall ("link" c-string c-string)
1380 (%name->file name1) (%name->file name2)))
1381
1382 ;;; Unix-lseek accepts a file descriptor, an offset, and whence value.
1383
1384 (defconstant l_set 0 _N"set the file pointer")
1385 (defconstant l_incr 1 _N"increment the file pointer")
1386 (defconstant l_xtnd 2 _N"extend the file size")
1387
1388 #-solaris
1389 (defun unix-lseek (fd offset whence)
1390 _N"Unix-lseek accepts a file descriptor and moves the file pointer ahead
1391 a certain offset for that file. Whence can be any of the following:
1392
1393 l_set Set the file pointer.
1394 l_incr Increment the file pointer.
1395 l_xtnd Extend the file size.
1396 _N"
1397 (declare (type unix-fd fd)
1398 (type file-offset offset)
1399 (type (integer 0 2) whence))
1400 (off-t-syscall ("lseek" (int off-t int)) fd offset whence))
1401
1402 #+solaris
1403 (defun unix-lseek (fd offset whence)
1404 _N"Unix-lseek accepts a file descriptor and moves the file pointer ahead
1405 a certain offset for that file. Whence can be any of the following:
1406
1407 l_set Set the file pointer.
1408 l_incr Increment the file pointer.
1409 l_xtnd Extend the file size.
1410 _N"
1411 (declare (type unix-fd fd)
1412 (type file-offset64 offset)
1413 (type (integer 0 2) whence))
1414 (let ((result (alien-funcall
1415 (extern-alien "lseek64" (function off64-t int off64-t int))
1416 fd offset whence)))
1417 (if (minusp result)
1418 (progn
1419 (values nil (unix-errno)))
1420 (values result 0))))
1421
1422 ;;; Unix-mkdir accepts a name and a mode and attempts to create the
1423 ;;; corresponding directory with mode mode.
1424
1425 (defun unix-mkdir (name mode)
1426 _N"Unix-mkdir creates a new directory with the specified name and mode.
1427 (Same as those for unix-chmod.) It returns T upon success, otherwise
1428 NIL and an error number."
1429 (declare (type unix-pathname name)
1430 (type unix-file-mode mode))
1431 (void-syscall ("mkdir" c-string int) (%name->file name) mode))
1432
1433 ;;; Unix-open accepts a pathname (a simple string), flags, and mode and
1434 ;;; attempts to open file with name pathname.
1435
1436 (defconstant o_rdonly 0 _N"Read-only flag.")
1437 (defconstant o_wronly 1 _N"Write-only flag.")
1438 (defconstant o_rdwr 2 _N"Read-write flag.")
1439 #+(or hpux linux svr4)
1440 (defconstant o_ndelay #-linux 4 #+linux #o4000 _N"Non-blocking I/O")
1441 (defconstant o_append #-linux #o10 #+linux #o2000 _N"Append flag.")
1442 #+(or hpux svr4 linux)
1443 (progn
1444 (defconstant o_creat #-linux #o400 #+linux #o100 _N"Create if nonexistant flag.")
1445 (defconstant o_trunc #o1000 _N"Truncate flag.")
1446 (defconstant o_excl #-linux #o2000 #+linux #o200 _N"Error if already exists.")
1447 (defconstant o_noctty #+linux #o400 #+hpux #o400000 #+(or irix solaris) #x800
1448 _N"Don't assign controlling tty"))
1449 #+(or hpux svr4 BSD)
1450 (defconstant o_nonblock #+hpux #o200000 #+(or irix solaris) #x80 #+BSD #x04
1451 _N"Non-blocking mode")
1452 #+BSD
1453 (defconstant o_ndelay o_nonblock) ; compatibility
1454 #+linux
1455 (progn
1456 (defconstant o_sync #o10000 _N"Synchronous writes (on ext2)"))
1457
1458 #-(or hpux svr4 linux)
1459 (progn
1460 (defconstant o_creat #o1000 _N"Create if nonexistant flag.")
1461 (defconstant o_trunc #o2000 _N"Truncate flag.")
1462 (defconstant o_excl #o4000 _N"Error if already exists."))
1463
1464 (defun unix-open (path flags mode)
1465 _N"Unix-open opens the file whose pathname is specified by path
1466 for reading and/or writing as specified by the flags argument.
1467 The flags argument can be:
1468
1469 o_rdonly Read-only flag.
1470 o_wronly Write-only flag.
1471 o_rdwr Read-and-write flag.
1472 o_append Append flag.
1473 o_creat Create-if-nonexistant flag.
1474 o_trunc Truncate-to-size-0 flag.
1475
1476 If the o_creat flag is specified, then the file is created with
1477 a permission of argument mode if the file doesn't exist. An
1478 integer file descriptor is returned by unix-open."
1479 (declare (type unix-pathname path)
1480 (type fixnum flags)
1481 (type unix-file-mode mode))
1482 (int-syscall (#+solaris "open64" #-solaris "open" c-string int int)
1483 (%name->file path) flags mode))
1484
1485 (defun unix-pipe ()
1486 _N"Unix-pipe sets up a unix-piping mechanism consisting of
1487 an input pipe and an output pipe. Unix-Pipe returns two
1488 values: if no error occurred the first value is the pipe
1489 to be read from and the second is can be written to. If
1490 an error occurred the first value is NIL and the second
1491 the unix error code."
1492 (with-alien ((fds (array int 2)))
1493 (syscall ("pipe" (* int))
1494 (values (deref fds 0) (deref fds 1))
1495 (cast fds (* int)))))
1496
1497 ;;; Unix-read accepts a file descriptor, a buffer, and the length to read.
1498 ;;; It attempts to read len bytes from the device associated with fd
1499 ;;; and store them into the buffer. It returns the actual number of
1500 ;;; bytes read.
1501
1502 (defun unix-read (fd buf len)
1503 _N"Unix-read attempts to read from the file described by fd into
1504 the buffer buf until it is full. Len is the length of the buffer.
1505 The number of bytes actually read is returned or NIL and an error
1506 number if an error occured."
1507 (declare (type unix-fd fd)
1508 (type (unsigned-byte 32) len))
1509 #+(or sunos gencgc)
1510 ;; Note: Under sunos we touch each page before doing the read to give
1511 ;; the segv handler a chance to fix the permissions. Otherwise,
1512 ;; read will return EFAULT. This also bypasses a bug in 4.1.1 in which
1513 ;; read fails with EFAULT if the page has never been touched even if
1514 ;; the permissions are okay.
1515 ;;
1516 ;; (Is this true for Solaris?)
1517 ;;
1518 ;; Also, with gencgc, the collector tries to keep raw objects like
1519 ;; strings in separate pages that are not write-protected. However,
1520 ;; this isn't always true. Thus, BUF will sometimes be
1521 ;; write-protected and the kernel doesn't like writing to
1522 ;; write-protected pages. So go through and touch each page to give
1523 ;; the segv handler a chance to unprotect the pages.
1524 (without-gcing
1525 (let* ((page-size (get-page-size))
1526 (1-page-size (1- page-size))
1527 (sap (etypecase buf
1528 (system-area-pointer buf)
1529 (vector (vector-sap buf))))
1530 (end (sap+ sap len)))
1531 (declare (type (and fixnum unsigned-byte) page-size 1-page-size)
1532 (type system-area-pointer sap end)
1533 (optimize (speed 3) (safety 0)))
1534 ;; Touch the beginning of every page
1535 (do ((sap (int-sap (logand (sap-int sap)
1536 (logxor 1-page-size (ldb (byte 32 0) -1))))
1537 (sap+ sap page-size)))
1538 ((sap>= sap end))
1539 (declare (type system-area-pointer sap))
1540 (setf (sap-ref-8 sap 0) (sap-ref-8 sap 0)))))
1541 (int-syscall ("read" int (* char) int) fd buf len))
1542
1543 (defun unix-readlink (path)
1544 _N"Unix-readlink invokes the readlink system call on the file name
1545 specified by the simple string path. It returns up to two values:
1546 the contents of the symbolic link if the call is successful, or
1547 NIL and the Unix error number."
1548 (declare (type unix-pathname path))
1549 (with-alien ((buf (array char 1024)))
1550 (syscall ("readlink" c-string (* char) int)
1551 (let ((string (make-string result)))
1552 #-unicode
1553 (kernel:copy-from-system-area
1554 (alien-sap buf) 0
1555 string (* vm:vector-data-offset vm:word-bits)
1556 (* result vm:byte-bits))
1557 #+unicode
1558 (let ((sap (alien-sap buf)))
1559 (dotimes (k result)
1560 (setf (aref string k)
1561 (code-char (sap-ref-8 sap k)))))
1562 (%file->name string))
1563 (%name->file path) (cast buf (* char)) 1024)))
1564
1565 ;;; Unix-rename accepts two files names and renames the first to the second.
1566
1567 (defun unix-rename (name1 name2)
1568 _N"Unix-rename renames the file with string name1 to the string
1569 name2. NIL and an error code is returned if an error occured."
1570 (declare (type unix-pathname name1 name2))
1571 (void-syscall ("rename" c-string c-string)
1572 (%name->file name1) (%name->file name2)))
1573
1574 ;;; Unix-rmdir accepts a name and removes the associated directory.
1575
1576 (defun unix-rmdir (name)
1577 _N"Unix-rmdir attempts to remove the directory name. NIL and
1578 an error number is returned if an error occured."
1579 (declare (type unix-pathname name))
1580 (void-syscall ("rmdir" c-string) (%name->file name)))
1581
1582
1583 ;;; UNIX-FAST-SELECT -- public.
1584 ;;;
1585 (defmacro unix-fast-select (num-descriptors
1586 read-fds write-fds exception-fds
1587 timeout-secs &optional (timeout-usecs 0))
1588 _N"Perform the UNIX select(2) system call.
1589 (declare (type (integer 0 #.FD-SETSIZE) num-descriptors)
1590 (type (or (alien (* (struct fd-set))) null)
1591 read-fds write-fds exception-fds)
1592 (type (or null (unsigned-byte 31)) timeout-secs)
1593 (type (unsigned-byte 31) timeout-usecs)
1594 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))"
1595 `(let ((timeout-secs ,timeout-secs))
1596 (with-alien ((tv (struct timeval)))
1597 (when timeout-secs
1598 (setf (slot tv 'tv-sec) timeout-secs)
1599 (setf (slot tv 'tv-usec) ,timeout-usecs))
1600 (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
1601 (* (struct fd-set)) (* (struct timeval)))
1602 ,num-descriptors ,read-fds ,write-fds ,exception-fds
1603 (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))))
1604
1605
1606 ;;; Unix-select accepts sets of file descriptors and waits for an event
1607 ;;; to happen on one of them or to time out.
1608
1609 (defmacro num-to-fd-set (fdset num)
1610 `(if (fixnump ,num)
1611 (progn
1612 (setf (deref (slot ,fdset 'fds-bits) 0) ,num)
1613 ,@(loop for index upfrom 1 below (/ fd-setsize 32)
1614 collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
1615 (progn
1616 ,@(loop for index upfrom 0 below (/ fd-setsize 32)
1617 collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
1618 (ldb (byte 32 ,(* index 32)) ,num))))))
1619
1620 (defmacro fd-set-to-num (nfds fdset)
1621 `(if (<= ,nfds 32)
1622 (deref (slot ,fdset 'fds-bits) 0)
1623 (+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
1624 collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
1625 ,(* index 32))))))
1626
1627 (defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
1628 _N"Unix-select examines the sets of descriptors passed as arguments
1629 to see if they are ready for reading and writing. See the UNIX
1630 Programmers Manual for more information."
1631 (declare (type (integer 0 #.FD-SETSIZE) nfds)
1632 (type unsigned-byte rdfds wrfds xpfds)
1633 (type (or (unsigned-byte 31) null) to-secs)
1634 (type (unsigned-byte 31) to-usecs)
1635 (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
1636 (with-alien ((tv (struct timeval))
1637 (rdf (struct fd-set))
1638 (wrf (struct fd-set))
1639 (xpf (struct fd-set)))
1640 (when to-secs
1641 (setf (slot tv 'tv-sec) to-secs)
1642 (setf (slot tv 'tv-usec) to-usecs))
1643 (num-to-fd-set rdf rdfds)
1644 (num-to-fd-set wrf wrfds)
1645 (num-to-fd-set xpf xpfds)
1646 (macrolet ((frob (lispvar alienvar)
1647 `(if (zerop ,lispvar)
1648 (int-sap 0)
1649 (alien-sap (addr ,alienvar)))))
1650 (syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
1651 (* (struct fd-set)) (* (struct timeval)))
1652 (values result
1653 (fd-set-to-num nfds rdf)
1654 (fd-set-to-num nfds wrf)
1655 (fd-set-to-num nfds xpf))
1656 nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf)
1657 (if to-secs (alien-sap (addr tv)) (int-sap 0))))))
1658
1659
1660 ;;; Unix-sync writes all information in core memory which has been modified
1661 ;;; to permanent storage (i.e. disk).
1662
1663 (defun unix-sync ()
1664 _N"Unix-sync writes all information in core memory which has been
1665 modified to disk. It returns NIL and an error code if an error
1666 occured."
1667 (void-syscall ("sync")))
1668
1669 ;;; Unix-fsync writes the core-image of the file described by "fd" to
1670 ;;; permanent storage (i.e. disk).
1671
1672 (defun unix-fsync (fd)
1673 _N"Unix-fsync writes the core image of the file described by
1674 fd to disk."
1675 (declare (type unix-fd fd))
1676 (void-syscall ("fsync" int) fd))
1677
1678 ;;; Unix-truncate accepts a file name and a new length. The file is
1679 ;;; truncated to the new length.
1680
1681 (defun unix-truncate (name len)
1682 _N"Unix-truncate truncates the named file to the length (in
1683 bytes) specified by len. NIL and an error number is returned
1684 if the call is unsuccessful."
1685 (declare (type unix-pathname name)
1686 (type (unsigned-byte #+solaris 64 #-solaris 32) len))
1687 #-(and bsd x86)
1688 (void-syscall (#+solaris "truncate64" #-solaris "truncate" c-string int) name len)
1689 #+(and bsd x86)
1690 (void-syscall ("truncate" c-string unsigned-long unsigned-long) name len 0))
1691
1692 (defun unix-ftruncate (fd len)
1693 _N"Unix-ftruncate is similar to unix-truncate except that the first
1694 argument is a file descriptor rather than a file name."
1695 (declare (type unix-fd fd)
1696 (type (unsigned-byte #+solaris 64 #-solaris 32) len))
1697 #-(and bsd x86)
1698 (void-syscall (#+solaris "ftruncate64" #-solaris "ftruncate" int int) fd len)
1699 #+(and bsd x86)
1700 (void-syscall ("ftruncate" int unsigned-long unsigned-long) fd len 0))
1701
1702 (defun unix-symlink (name1 name2)
1703 _N"Unix-symlink creates a symbolic link named name2 to the file
1704 named name1. NIL and an error number is returned if the call
1705 is unsuccessful."
1706 (declare (type unix-pathname name1 name2))
1707 (void-syscall ("symlink" c-string c-string)
1708 (%name->file name1) (%name->file name2)))
1709
1710 ;;; Unix-unlink accepts a name and deletes the directory entry for that
1711 ;;; name and the file if this is the last link.
1712
1713 (defun unix-unlink (name)
1714 _N"Unix-unlink removes the directory entry for the named file.
1715 NIL and an error code is returned if the call fails."
1716 (declare (type unix-pathname name))
1717 (void-syscall ("unlink" c-string) (%name->file name)))
1718
1719 ;;; Unix-write accepts a file descriptor, a buffer, an offset, and the
1720 ;;; length to write. It attempts to write len bytes to the device
1721 ;;; associated with fd from the buffer starting at offset. It returns
1722 ;;; the actual number of bytes written.
1723
1724 (defun unix-write (fd buf offset len)
1725 _N"Unix-write attempts to write a character buffer (buf) of length
1726 len to the file described by the file descriptor fd. NIL and an
1727 error is returned if the call is unsuccessful."
1728 (declare (type unix-fd fd)
1729 (type (unsigned-byte 32) offset len))
1730 (int-syscall ("write" int (* char) int)
1731 fd
1732 (with-alien ((ptr (* char) (etypecase buf
1733 ((simple-array * (*))
1734 (vector-sap buf))
1735 (system-area-pointer
1736 buf))))
1737 (addr (deref ptr offset)))
1738 len))
1739
1740 ;;; Unix-ioctl is used to change parameters of devices in a device
1741 ;;; dependent way.
1742
1743
1744 (defconstant terminal-speeds
1745 '#(0 50 75 110 134 150 200 300 600 #+hpux 900 1200 1800 2400 #+hpux 3600
1746 4800 #+hpux 7200 9600 19200 38400 57600 115200 230400
1747 #+hpux 460800))
1748
1749 ;;; from /usr/include/bsd/sgtty.h (linux)
1750
1751 (defconstant tty-raw #-linux #o40 #+linux 1)
1752 (defconstant tty-crmod #-linux #o20 #+linux 4)
1753 #-(or hpux svr4 bsd linux) (defconstant tty-echo #o10) ;; 8
1754 (defconstant tty-lcase #-linux #o4 #+linux 2)
1755 #-hpux
1756 (defconstant tty-cbreak #-linux #o2 #+linux 64)
1757 #-(or linux hpux)
1758 (defconstant tty-tandem #o1)
1759
1760 #+(or hpux svr4 bsd linux)
1761 (progn
1762 (defmacro def-enum (inc cur &rest names)
1763 (flet ((defform (name)
1764 (prog1 (when name `(defconstant ,name ,cur))
1765 (setf cur (funcall inc cur 1)))))
1766 `(progn ,@(mapcar #'defform names))))
1767
1768 ;; Input modes. Linux: /usr/include/asm/termbits.h
1769 (def-enum ash 1 tty-ignbrk tty-brkint tty-ignpar tty-parmrk tty-inpck
1770 tty-istrip tty-inlcr tty-igncr tty-icrnl #-bsd tty-iuclc
1771 tty-ixon #-bsd tty-ixany tty-ixoff #+bsd tty-ixany
1772 #+hpux tty-ienqak #+bsd nil tty-imaxbel)
1773
1774 ;; output modes
1775 #-bsd (def-enum ash 1 tty-opost tty-olcuc tty-onlcr tty-ocrnl tty-onocr
1776 tty-onlret tty-ofill tty-ofdel)
1777 #+bsd (def-enum ash 1 tty-opost tty-onlcr)
1778
1779 ;; local modes
1780 #-bsd (def-enum ash 1 tty-isig tty-icanon tty-xcase tty-echo tty-echoe
1781 tty-echok tty-echonl tty-noflsh #+irix tty-iexten
1782 #+(or sunos linux) tty-tostop tty-echoctl tty-echoprt
1783 tty-echoke #+(or sunos svr4) tty-defecho tty-flusho
1784 #+linux nil tty-pendin #+irix tty-tostop
1785 #+(or sunos linux) tty-iexten)
1786 #+bsd (def-enum ash 1 tty-echoke tty-echoe tty-echok tty-echo tty-echonl
1787 tty-echoprt tty-echoctl tty-isig tty-icanon nil
1788 tty-iexten)
1789 #+bsd (defconstant tty-tostop #x00400000)
1790 #+bsd (defconstant tty-flusho #x00800000)
1791 #+bsd (defconstant tty-pendin #x20000000)
1792 #+bsd (defconstant tty-noflsh #x80000000)
1793 #+hpux (defconstant tty-tostop #o10000000000)
1794 #+hpux (defconstant tty-iexten #o20000000000)
1795
1796 ;; control modes
1797 (def-enum ash #-bsd #o100 #+bsd #x400 #+hpux nil tty-cstopb
1798 tty-cread tty-parenb tty-parodd tty-hupcl tty-clocal
1799 #+svr4 rcv1en #+svr4 xmt1en #+(or hpux svr4) tty-loblk)
1800
1801 ;; special control characters
1802 #+(or hpux svr4 linux) (def-enum + 0 vintr vquit verase vkill veof
1803 #-linux veol #-linux veol2)
1804 #+bsd (def-enum + 0 veof veol veol2 verase nil vkill nil nil vintr vquit)
1805 #+linux (defconstant veol 11)
1806 #+linux (defconstant veol2 16)
1807
1808 (defconstant tciflush 0)
1809 (defconstant tcoflush 1)
1810 (defconstant tcioflush 2))
1811
1812 #+bsd
1813 (progn
1814 (defconstant vmin 16)
1815 (defconstant vtime 17)
1816 (defconstant vsusp 10)
1817 (defconstant vstart 12)
1818 (defconstant vstop 13)
1819 (defconstant vdsusp 11))
1820
1821 #+hpux
1822 (progn
1823 (defconstant vmin 11)
1824 (defconstant vtime 12)
1825 (defconstant vsusp 13)
1826 (defconstant vstart 14)
1827 (defconstant vstop 15)
1828 (defconstant vdsusp 21))
1829
1830 #+(or hpux bsd linux)
1831 (progn
1832 (defconstant tcsanow 0)
1833 (defconstant tcsadrain 1)
1834 (defconstant tcsaflush 2))
1835
1836 #+(or linux svr4)
1837 (progn
1838 #-linux (defconstant vdsusp 11)
1839 (defconstant vstart 8)
1840 (defconstant vstop 9)
1841 (defconstant vsusp 10)
1842 (defconstant vmin #-linux 4 #+linux 6)
1843 (defconstant vtime 5))
1844
1845 #+(or sunos svr4)
1846 (progn
1847 ;; control modes
1848 (defconstant tty-cbaud #o17)
1849 (defconstant tty-csize #o60)
1850 (defconstant tty-cs5 #o0)
1851 (defconstant tty-cs6 #o20)
1852 (defconstant tty-cs7 #o40)
1853 (defconstant tty-cs8 #o60))
1854
1855 #+bsd
1856 (progn
1857 ;; control modes
1858 (defconstant tty-csize #x300)
1859 (defconstant tty-cs5 #x000)
1860 (defconstant tty-cs6 #x100)
1861 (defconstant tty-cs7 #x200)
1862 (defconstant tty-cs8 #x300))
1863
1864 #+svr4
1865 (progn
1866 (defconstant tcsanow #x540e)
1867 (defconstant tcsadrain #x540f)
1868 (defconstant tcsaflush #x5410))
1869
1870 (eval-when (compile load eval)
1871
1872 #-(or (and svr4 (not irix)) linux)
1873 (progn
1874 (defconstant iocparm-mask #x7f) ; Freebsd: #x1fff ?
1875 (defconstant ioc_void #x20000000)
1876 (defconstant ioc_out #x40000000)
1877 (defconstant ioc_in #x80000000)
1878 (defconstant ioc_inout (logior ioc_in ioc_out)))
1879
1880 #-(or linux (and svr4 (not irix)))
1881 (defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
1882 (let* ((ptype (ecase parm-type
1883 (:void ioc_void)
1884 (:in ioc_in)
1885 (:out ioc_out)
1886 (:inout ioc_inout)))
1887 (code (logior (ash (char-code dev) 8) cmd ptype)))
1888 (when arg
1889 (setf code
1890 `(logior (ash (logand (alien-size ,arg :bytes)
1891 ,iocparm-mask)
1892 16)
1893 ,code)))
1894 `(eval-when (eval load compile)
1895 (defconstant ,name ,code))))
1896
1897 #+(and svr4 (not irix))
1898 (defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
1899 (declare (ignore dev arg parm-type))
1900 `(eval-when (eval load compile)
1901 (defconstant ,name ,(logior (ash (char-code #\t) 8) cmd))))
1902
1903 #+linux
1904 (defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
1905 (declare (ignore arg parm-type))
1906 `(eval-when (eval load compile)
1907 (defconstant ,name ,(logior (ash (- (char-code dev) #x20) 8) cmd))))
1908
1909 )
1910
1911 ;;; TTY ioctl commands.
1912
1913 (define-ioctl-command TIOCGETP #\t #-linux 8 #+linux #x81 (struct sgttyb) :out)
1914 (define-ioctl-command TIOCSETP #\t #-linux 9 #+linux #x82 (struct sgttyb) :in)
1915 (define-ioctl-command TIOCFLUSH #\t #-linux 16 #+linux #x89 int :in)
1916 (define-ioctl-command TIOCSETC #\t #-linux 17 #+linux #x84 (struct tchars) :in)
1917 (define-ioctl-command TIOCGETC #\t #-linux 18 #+linux #x83 (struct tchars) :out)
1918 (define-ioctl-command TIOCGWINSZ #\t #-hpux 104 #+hpux 107 (struct winsize)
1919 :out)
1920 (define-ioctl-command TIOCSWINSZ #\t #-hpux 103 #+hpux 106 (struct winsize)
1921 :in)
1922
1923 (define-ioctl-command TIOCNOTTY #\t #-linux 113 #+linux #x22 nil :void)
1924 #-hpux
1925 (progn
1926 (define-ioctl-command TIOCSLTC #\t #-linux 117 #+linux #x84 (struct ltchars) :in)
1927 (define-ioctl-command TIOCGLTC #\t #-linux 116 #+linux #x85 (struct ltchars) :out)
1928 (define-ioctl-command TIOCSPGRP #\t #-svr4 118 #+svr4 21 int :in)
1929 (define-ioctl-command TIOCGPGRP #\t #-svr4 119 #+svr4 20 int :out))
1930 #+hpux
1931 (progn
1932 (define-ioctl-command TIOCSLTC #\T 23 (struct ltchars) :in)
1933 (define-ioctl-command TIOCGLTC #\T 24 (struct ltchars) :out)
1934 (define-ioctl-command TIOCSPGRP #\T 29 int :in)
1935 (define-ioctl-command TIOCGPGRP #\T 30 int :out)
1936 (define-ioctl-command TIOCSIGSEND #\t 93 nil))
1937
1938 ;;; File ioctl commands.
1939 (define-ioctl-command FIONREAD #\f #-linux 127 #+linux #x1B int :out)
1940
1941
1942 (defun unix-ioctl (fd cmd arg)
1943 _N"Unix-ioctl performs a variety of operations on open i/o
1944 descriptors. See the UNIX Programmer's Manual for more
1945 information."
1946 (declare (type unix-fd fd)
1947 (type (unsigned-byte 32) cmd))
1948 (int-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
1949
1950 #+(or svr4 hpux bsd linux)
1951 (progn
1952 (defun unix-tcgetattr (fd termios)
1953 _N"Get terminal attributes."
1954 (declare (type unix-fd fd))
1955 (void-syscall ("tcgetattr" int (* (struct termios))) fd termios))
1956
1957 (defun unix-tcsetattr (fd opt termios)
1958 _N"Set terminal attributes."
1959 (declare (type unix-fd fd))
1960 (void-syscall ("tcsetattr" int int (* (struct termios))) fd opt termios))
1961
1962 ;; XXX rest of functions in this progn probably are present in linux, but
1963 ;; not verified.
1964 #-bsd
1965 (defun unix-cfgetospeed (termios)
1966 _N"Get terminal output speed."
1967 (multiple-value-bind (speed errno)
1968 (int-syscall ("cfgetospeed" (* (struct termios))) termios)
1969 (if speed
1970 (values (svref terminal-speeds speed) 0)
1971 (values speed errno))))
1972
1973 #+bsd
1974 (defun unix-cfgetospeed (termios)
1975 _N"Get terminal output speed."
1976 (int-syscall ("cfgetospeed" (* (struct termios))) termios))
1977
1978 #-bsd
1979 (defun unix-cfsetospeed (termios speed)
1980 _N"Set terminal output speed."
1981 (let ((baud (or (position speed terminal-speeds)
1982 (error _"Bogus baud rate ~S" speed))))
1983 (void-syscall ("cfsetospeed" (* (struct termios)) int) termios baud)))
1984
1985 #+bsd
1986 (defun unix-cfsetospeed (termios speed)
1987 _N"Set terminal output speed."
1988 (void-syscall ("cfsetospeed" (* (struct termios)) int) termios speed))
1989
1990 #-bsd
1991 (defun unix-cfgetispeed (termios)
1992 _N"Get terminal input speed."
1993 (multiple-value-bind (speed errno)
1994 (int-syscall ("cfgetispeed" (* (struct termios))) termios)
1995 (if speed
1996 (values (svref terminal-speeds speed) 0)
1997 (values speed errno))))
1998
1999 #+bsd
2000 (defun unix-cfgetispeed (termios)
2001 _N"Get terminal input speed."
2002 (int-syscall ("cfgetispeed" (* (struct termios))) termios))
2003
2004 #-bsd
2005 (defun unix-cfsetispeed (termios speed)
2006 _N"Set terminal input speed."
2007 (let ((baud (or (position speed terminal-speeds)
2008 (error _"Bogus baud rate ~S" speed))))
2009 (void-syscall ("cfsetispeed" (* (struct termios)) int) termios baud)))
2010
2011 #+bsd
2012 (defun unix-cfsetispeed (termios speed)
2013 _N"Set terminal input speed."
2014 (void-syscall ("cfsetispeed" (* (struct termios)) int) termios speed))
2015
2016 (defun unix-tcsendbreak (fd duration)
2017 _N"Send break"
2018 (declare (type unix-fd fd))
2019 (void-syscall ("tcsendbreak" int int) fd duration))
2020
2021 (defun unix-tcdrain (fd)
2022 _N"Wait for output for finish"
2023 (declare (type unix-fd fd))
2024 (void-syscall ("tcdrain" int) fd))
2025
2026 (defun unix-tcflush (fd selector)
2027 _N"See tcflush(3)"
2028 (declare (type unix-fd fd))
2029 (void-syscall ("tcflush" int int) fd selector))
2030
2031 (defun unix-tcflow (fd action)
2032 _N"Flow control"
2033 (declare (type unix-fd fd))
2034 (void-syscall ("tcflow" int int) fd action)))
2035
2036 (defun tcsetpgrp (fd pgrp)
2037 _N"Set the tty-process-group for the unix file-descriptor FD to PGRP."
2038 (alien:with-alien ((alien-pgrp c-call:int pgrp))
2039 (unix-ioctl fd
2040 tiocspgrp
2041 (alien:alien-sap (alien:addr alien-pgrp)))))
2042
2043 (defun tcgetpgrp (fd)
2044 _N"Get the tty-process-group for the unix file-descriptor FD."
2045 (alien:with-alien ((alien-pgrp c-call:int))
2046 (multiple-value-bind (ok err)
2047 (unix-ioctl fd
2048 tiocgpgrp
2049 (alien:alien-sap (alien:addr alien-pgrp)))
2050 (if ok
2051 (values alien-pgrp nil)
2052 (values nil err)))))
2053
2054 (defun tty-process-group (&optional fd)
2055 _N"Get the tty-process-group for the unix file-descriptor FD. If not supplied,
2056 FD defaults to /dev/tty."
2057 (if fd
2058 (tcgetpgrp fd)
2059 (multiple-value-bind (tty-fd errno)
2060 (unix-open "/dev/tty" o_rdwr 0)
2061 (cond (tty-fd
2062 (multiple-value-prog1
2063 (tcgetpgrp tty-fd)
2064 (unix-close tty-fd)))
2065 (t
2066 (values nil errno))))))
2067
2068 (defun %set-tty-process-group (pgrp &optional fd)
2069 _N"Set the tty-process-group for the unix file-descriptor FD to PGRP. If not
2070 supplied, FD defaults to /dev/tty."
2071 (let ((old-sigs
2072 (unix-sigblock
2073 (sigmask :sigttou :sigttin :sigtstp :sigchld))))
2074 (declare (type (unsigned-byte 32) old-sigs))
2075 (unwind-protect
2076 (if fd
2077 (tcsetpgrp fd pgrp)
2078 (multiple-value-bind (tty-fd errno)
2079 (unix-open "/dev/tty" o_rdwr 0)
2080 (cond (tty-fd
2081 (multiple-value-prog1
2082 (tcsetpgrp tty-fd pgrp)
2083 (unix-close tty-fd)))
2084 (t
2085 (values nil errno)))))
2086 (unix-sigsetmask old-sigs))))
2087
2088 (defsetf tty-process-group (&optional fd) (pgrp)
2089 _N"Set the tty-process-group for the unix file-descriptor FD to PGRP. If not
2090 supplied, FD defaults to /dev/tty."
2091 `(%set-tty-process-group ,pgrp ,fd))
2092
2093
2094 ;;; Socket options.
2095
2096 #+(or hpux bsd)
2097 (define-ioctl-command SIOCSPGRP #\s 8 int :in)
2098
2099 #+linux
2100 (define-ioctl-command SIOCSPGRP #\s #x8904 int :in)
2101
2102 #+(or hpux bsd linux)
2103 (defun siocspgrp (fd pgrp)
2104 _N"Set the socket process-group for the unix file-descriptor FD to PGRP."
2105 (alien:with-alien ((alien-pgrp c-call:int pgrp))
2106 (unix-ioctl fd
2107 siocspgrp
2108 (alien:alien-sap (alien:addr alien-pgrp)))))
2109
2110 ;;; Unix-exit terminates a program.
2111
2112 (defun unix-exit (&optional (code 0))
2113 _N"Unix-exit terminates the current process with an optional
2114 error code. If successful, the call doesn't return. If
2115 unsuccessful, the call returns NIL and an error number."
2116 (declare (type (signed-byte 32) code))
2117 (void-syscall ("exit" int) code))
2118
2119 ;;; STAT and friends.
2120
2121 (defmacro extract-stat-results (buf)
2122 `(values T
2123 (slot ,buf 'st-dev)
2124 (slot ,buf 'st-ino)
2125 (slot ,buf 'st-mode)
2126 (slot ,buf 'st-nlink)
2127 (slot ,buf 'st-uid)
2128 (slot ,buf 'st-gid)
2129 (slot ,buf 'st-rdev)
2130 (slot ,buf 'st-size)
2131 #-(or svr4 BSD) (slot ,buf 'st-atime)
2132 #+svr4 (slot (slot ,buf 'st-atime) 'tv-sec)
2133 #+BSD (slot (slot ,buf 'st-atime) 'ts-sec)
2134 #-(or svr4 BSD)(slot ,buf 'st-mtime)
2135 #+svr4 (slot (slot ,buf 'st-mtime) 'tv-sec)
2136 #+BSD(slot (slot ,buf 'st-mtime) 'ts-sec)
2137 #-(or svr4 BSD) (slot ,buf 'st-ctime)
2138 #+svr4 (slot (slot ,buf 'st-ctime) 'tv-sec)
2139 #+BSD(slot (slot ,buf 'st-ctime) 'ts-sec)
2140 (slot ,buf 'st-blksize)
2141 (slot ,buf 'st-blocks)))
2142
2143 #-solaris
2144 (progn
2145 (defun unix-stat (name)
2146 _N"Unix-stat retrieves information about the specified
2147 file returning them in the form of multiple values.
2148 See the UNIX Programmer's Manual for a description
2149 of the values returned. If the call fails, then NIL
2150 and an error number is returned instead."
2151 (declare (type unix-pathname name))
2152 (when (string= name "")
2153 (setf name "."))
2154 (with-alien ((buf (struct stat)))
2155 (syscall ("stat" c-string (* (struct stat)))
2156 (extract-stat-results buf)
2157 (%name->file name) (addr buf))))
2158
2159 (defun unix-lstat (name)
2160 _N"Unix-lstat is similar to unix-stat except the specified
2161 file must be a symbolic link."
2162 (declare (type unix-pathname name))
2163 (with-alien ((buf (struct stat)))
2164 (syscall ("lstat" c-string (* (struct stat)))
2165 (extract-stat-results buf)
2166 (%name->file name) (addr buf))))
2167
2168 (defun unix-fstat (fd)
2169 _N"Unix-fstat is similar to unix-stat except the file is specified
2170 by the file descriptor fd."
2171 (declare (type unix-fd fd))
2172 (with-alien ((buf (struct stat)))
2173 (syscall ("fstat" int (* (struct stat)))
2174 (extract-stat-results buf)
2175 fd (addr buf))))
2176 )
2177
2178 ;;; 64-bit versions of stat and friends
2179 #+solaris
2180 (progn
2181 (defun unix-stat (name)
2182 _N"Unix-stat retrieves information about the specified
2183 file returning them in the form of multiple values.
2184 See the UNIX Programmer's Manual for a description
2185 of the values returned. If the call fails, then NIL
2186 and an error number is returned instead."
2187 (declare (type unix-pathname name))
2188 (when (string= name "")
2189 (setf name "."))
2190 (with-alien ((buf (struct stat64)))
2191 (syscall ("stat64" c-string (* (struct stat64)))
2192 (extract-stat-results buf)
2193 (%name->file name) (addr buf))))
2194
2195 (defun unix-lstat (name)
2196 _N"Unix-lstat is similar to unix-stat except the specified
2197 file must be a symbolic link."
2198 (declare (type unix-pathname name))
2199 (with-alien ((buf (struct stat64)))
2200 (syscall ("lstat64" c-string (* (struct stat64)))
2201 (extract-stat-results buf)
2202 (%name->file name) (addr buf))))
2203
2204 (defun unix-fstat (fd)
2205 _N"Unix-fstat is similar to unix-stat except the file is specified
2206 by the file descriptor fd."
2207 (declare (type unix-fd fd))
2208 (with-alien ((buf (struct stat64)))
2209 (syscall ("fstat64" int (* (struct stat64)))
2210 (extract-stat-results buf)
2211 fd (addr buf))))
2212 )
2213
2214
2215 (defconstant rusage_self 0 _N"The calling process.")
2216 (defconstant rusage_children -1 _N"Terminated child processes.")
2217
2218 (declaim (inline unix-fast-getrusage))
2219 (defun unix-fast-getrusage (who)
2220 _N"Like call getrusage, but return only the system and user time, and returns
2221 the seconds and microseconds as separate values."
2222 (declare (values (member t)
2223 (unsigned-byte 31) (mod 1000000)
2224 (unsigned-byte 31) (mod 1000000)))
2225 (with-alien ((usage (struct rusage)))
2226 (syscall* ("getrusage" int (* (struct rusage)))
2227 (values t
2228 (slot (slot usage 'ru-utime) 'tv-sec)
2229 (slot (slot usage 'ru-utime) 'tv-usec)
2230 (slot (slot usage 'ru-stime) 'tv-sec)
2231 (slot (slot usage 'ru-stime) 'tv-usec))
2232 who (addr usage))))
2233
2234 (defun unix-getrusage (who)
2235 _N"Unix-getrusage returns information about the resource usage
2236 of the process specified by who. Who can be either the
2237 current process (rusage_self) or all of the terminated
2238 child processes (rusage_children). NIL and an error number
2239 is returned if the call fails."
2240 (with-alien ((usage (struct rusage)))
2241 (syscall ("getrusage" int (* (struct rusage)))
2242 (values t
2243 (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000)
2244 (slot (slot usage 'ru-utime) 'tv-usec))
2245 (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000)
2246 (slot (slot usage 'ru-stime) 'tv-usec))
2247 (slot usage 'ru-maxrss)
2248 (slot usage 'ru-ixrss)
2249 (slot usage 'ru-idrss)
2250 (slot usage 'ru-isrss)
2251 (slot usage 'ru-minflt)
2252 (slot usage 'ru-majflt)
2253 (slot usage 'ru-nswap)
2254 (slot usage 'ru-inblock)
2255 (slot usage 'ru-oublock)
2256 (slot usage 'ru-msgsnd)
2257 (slot usage 'ru-msgrcv)
2258 (slot usage 'ru-nsignals)
2259 (slot usage 'ru-nvcsw)
2260 (slot usage 'ru-nivcsw))
2261 who (addr usage))))
2262
2263 ;;; Getrusage is not provided in the C library on Solaris 2.4, and is
2264 ;;; rather slow on later versions so the "times" system call is
2265 ;;; provided.
2266 #+(and sparc svr4)
2267 (progn
2268 (def-alien-type nil
2269 (struct tms
2270 (tms-utime #-alpha long #+alpha int) ; user time used
2271 (tms-stime #-alpha long #+alpha int) ; system time used.
2272 (tms-cutime #-alpha long #+alpha int) ; user time, children
2273 (tms-cstime #-alpha long #+alpha int))) ; system time, children
2274
2275 (declaim (inline unix-times))
2276 (defun unix-times ()
2277 _N"Unix-times returns information about the cpu time usage of the process
2278 and its children."
2279 (with-alien ((usage (struct tms)))
2280 (alien-funcall (extern-alien "times" (function int (* (struct tms))))
2281 (addr usage))
2282 (values t
2283 (slot usage 'tms-utime)
2284 (slot usage 'tms-stime)
2285 (slot usage 'tms-cutime)
2286 (slot usage 'tms-cstime))))
2287 ) ; end progn
2288
2289 ;; Requires call to tzset() in main.
2290 ;; Don't use this now: we
2291 #+(or linux svr4)
2292 (progn
2293 (def-alien-variable ("daylight" unix-daylight) int)
2294 (def-alien-variable ("timezone" unix-timezone) time-t)
2295 (def-alien-variable ("altzone" unix-altzone) time-t)
2296 #-irix (def-alien-variable ("tzname" unix-tzname) (array c-string 2))
2297 #+irix (defvar unix-tzname-addr nil)
2298 #+irix (pushnew #'(lambda () (setq unix-tzname-addr nil))
2299 ext:*after-save-initializations*)
2300 #+irix (declaim (notinline fakeout-compiler))
2301 #+irix (defun fakeout-compiler (name dst)
2302 (unless unix-tzname-addr
2303 (setf unix-tzname-addr (system:foreign-symbol-address
2304 name
2305 :flavor :data)))
2306 (deref (sap-alien unix-tzname-addr (array c-string 2)) dst))
2307 (def-alien-routine get-timezone c-call:void
2308 (when c-call:long :in)
2309 (minutes-west c-call:int :out)
2310 (daylight-savings-p alien:boolean :out))
2311 (defun unix-get-minutes-west (secs)
2312 (multiple-value-bind (ignore minutes dst) (get-timezone secs)
2313 (declare (ignore ignore) (ignore dst))
2314 (values minutes))
2315 )
2316 (defun unix-get-timezone (secs)
2317 (multiple-value-bind (ignore minutes dst) (get-timezone secs)
2318 (declare (ignore ignore) (ignore minutes))
2319 (values #-irix (deref unix-tzname (if dst 1 0))
2320 #+irix (fakeout-compiler "tzname" (if dst 1 0)))
2321 ) )
2322 )
2323 (declaim (inline unix-gettimeofday))
2324 (defun unix-gettimeofday ()
2325 _N"If it works, unix-gettimeofday returns 5 values: T, the seconds and
2326 microseconds of the current time of day, the timezone (in minutes west
2327 of Greenwich), and a daylight-savings flag. If it doesn't work, it
2328 returns NIL and the errno."
2329 (with-alien ((tv (struct timeval))
2330 #-svr4 (tz (struct timezone)))
2331 (syscall* ("gettimeofday" (* (struct timeval)) #-svr4 (* (struct timezone)))
2332 (values T
2333 (slot tv 'tv-sec)
2334 (slot tv 'tv-usec)
2335 #-svr4 (slot tz 'tz-minuteswest)
2336 #+svr4 (unix-get-minutes-west (slot tv 'tv-sec))
2337 #-svr4 (slot tz 'tz-dsttime)
2338 #+svr4 (unix-get-timezone (slot tv 'tv-sec))
2339 )
2340 (addr tv)
2341 #-svr4 (addr tz))))
2342
2343 ;;; Unix-utimes changes the accessed and updated times on UNIX
2344 ;;; files. The first argument is the filename (a string) and
2345 ;;; the second argument is a list of the 4 times- accessed and
2346 ;;; updated seconds and microseconds.
2347
2348 #-hpux
2349 (defun unix-utimes (file atime-sec atime-usec mtime-sec mtime-usec)
2350 _N"Unix-utimes sets the 'last-accessed' and 'last-updated'
2351 times on a specified file. NIL and an error number is
2352 returned if the call is unsuccessful."
2353 (declare (type unix-pathname file)
2354 (type (alien unsigned-long)
2355 atime-sec atime-usec
2356 mtime-sec mtime-usec))
2357 (with-alien ((tvp (array (struct timeval) 2)))
2358 (setf (slot (deref tvp 0) 'tv-sec) atime-sec)
2359 (setf (slot (deref tvp 0) 'tv-usec) atime-usec)
2360 (setf (slot (deref tvp 1) 'tv-sec) mtime-sec)
2361 (setf (slot (deref tvp 1) 'tv-usec) mtime-usec)
2362 (void-syscall ("utimes" c-string (* (struct timeval)))
2363 file
2364 (cast tvp (* (struct timeval))))))
2365
2366 ;;; Unix-setreuid sets the real and effective user-id's of the current
2367 ;;; process to the arguments "ruid" and "euid", respectively. Usage is
2368 ;;; restricted for anyone but the super-user. Setting either "ruid" or
2369 ;;; "euid" to -1 makes the system use the current id instead.
2370
2371 #-(or svr4 hpux)
2372 (defun unix-setreuid (ruid euid)
2373 _N"Unix-setreuid sets the real and effective user-id's of the current
2374 process to the specified ones. NIL and an error number is returned
2375 if the call fails."
2376 (void-syscall ("setreuid" int int) ruid euid))
2377
2378 ;;; Unix-setregid sets the real and effective group-id's of the current
2379 ;;; process to the arguments "rgid" and "egid", respectively. Usage is
2380 ;;; restricted for anyone but the super-user. Setting either "rgid" or
2381 ;;; "egid" to -1 makes the system use the current id instead.
2382
2383 #-(or svr4 hpux)
2384 (defun unix-setregid (rgid egid)
2385 _N"Unix-setregid sets the real and effective group-id's of the current
2386 process process to the specified ones. NIL and an error number is
2387 returned if the call fails."
2388 (void-syscall ("setregid" int int) rgid egid))
2389
2390 (def-alien-routine ("getpid" unix-getpid) int
2391 _N"Unix-getpid returns the process-id of the current process.")
2392
2393 (def-alien-routine ("getppid" unix-getppid) int
2394 _N"Unix-getppid returns the process-id of the parent of the current process.")
2395
2396 (def-alien-routine ("getgid" unix-getgid) int
2397 _N"Unix-getgid returns the real group-id of the current process.")
2398
2399 (def-alien-routine ("getegid" unix-getegid) int
2400 _N"Unix-getegid returns the effective group-id of the current process.")
2401
2402 ;;; Unix-getpgrp returns the group-id associated with the
2403 ;;; current process.
2404
2405 (defun unix-getpgrp ()
2406 _N"Unix-getpgrp returns the group-id of the calling process."
2407 (int-syscall ("getpgrp")))
2408
2409 ;;; Unix-setpgid sets the group-id of the process specified by
2410 ;;; "pid" to the value of "pgrp". The process must either have
2411 ;;; the same effective user-id or be a super-user process.
2412
2413 ;;; setpgrp(int int)[freebsd] is identical to setpgid and is retained
2414 ;;; for backward compatibility. setpgrp(void)[solaris] is being phased
2415 ;;; out in favor of setsid().
2416
2417 (defun unix-setpgrp (pid pgrp)