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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5