Newer
Older
;;; -*- Package: UNIX -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/unix.lisp,v 1.9 1992/02/13 15:57:08 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; This file contains the UNIX low-level support.
;;;
(in-package "UNIX")
(use-package "ALIEN")
(use-package "C-CALL")
(use-package "SYSTEM")
(use-package "EXT")
(export '(
daddr-t caddr-t ino-t swblk-t size-t time-t dev-t off-t uid-t gid-t
timeval tv-sec tv-usec timezone tz-minuteswest tz-dsttime
itimerval it-interval it-value tchars t-intrc t-quitc t-startc
t-stopc t-eofc t-brkc t-suspc t-dsuspc t-rprntc t-flushc
t-werasc t-lnextc sgttyb sg-ispeed sg-ospeed sg-erase sg-kill
sg-flags winsize ws-row ws-col ws-xpixel ws-ypixel
direct d-off d-ino d-reclen d-namlen d-name
stat st-dev st-mode st-nlink st-uid st-gid st-rdev st-size
st-atime st-mtime st-ctime st-blksize st-blocks
s-ifmt s-ifdir s-ifchr s-ifblk s-ifreg s-iflnk s-ifsock
s-isuid s-isgid s-isvtx s-iread s-iwrite s-iexec
ruseage ru-utime ru-stime ru-maxrss ru-ixrss ru-idrss
ru-isrss ru-minflt ru-majflt ru-nswap ru-inblock ru-oublock
ru-msgsnd ru-msgrcv ru-nsignals ru-nvcsw ru-nivcsw
rlimit rlim-cur rlim-max sigcontext sc-onstack sc-mask sc-pc
unix-errno get-unix-error-msg
unix-pathname unix-file-mode unix-fd unix-pid unix-uid unix-gid
unix-access r_ok w_ok x_ok f_ok unix-chdir unix-chmod setuidexec
setgidexec savetext readown writeown execown readgrp writegrp
execgrp readoth writeoth execoth unix-fchmod unix-chown unix-fchown
unix-getdtablesize unix-close unix-creat unix-dup unix-dup2
unix-fcntl f-dupfd f-getfd f-setfd f-getfl f-setfl f-getown f-setown
fndelay fappend fasync fcreat ftrunc fexcl unix-link unix-lseek
l_set l_incr l_xtnd unix-mkdir unix-open o_rdonly o_wronly o_rdwr
o_append o_creat o_trunc o_excl unix-pipe unix-read unix-readlink
unix-rename unix-rmdir unix-select unix-sync unix-fsync unix-truncate
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
unix-ftruncate unix-symlink unix-unlink unix-write unix-ioctl
terminal-speeds tty-raw tty-crmod tty-echo tty-lcase tty-cbreak
tty-tandem TIOCGETP TIOCSETP TIOCFLUSH TIOCSETC TIOCGETC TIOCSLTC
TIOCGLTC TIOCNOTTY TIOCSPGRP TIOCGPGRP TIOCGWINSZ TIOCSWINSZ
KBDCGET KBDCSET KBDCRESET KBDCRST KBDCSSTD KBDSGET KBDGCLICK
KBDSCLICK FIONREAD unix-exit unix-stat unix-lstat unix-fstat
unix-getrusage rusage_self rusage_children unix-gettimeofday
unix-utimes unix-setreuid unix-setregid unix-getpid unix-getppid
unix-getgid unix-getegid unix-getpgrp unix-setpgrp unix-getuid
unix-getpagesize unix-gethostname unix-gethostid unix-fork
unix-current-directory unix-isatty unix-ttyname unix-execve
unix-socket unix-connect unix-bind unix-listen unix-accept
unix-recv unix-send))
(pushnew :unix *features*)
;;;; Common machine independent structures.
;;; From sys/types.h
(def-alien-type daddr-t long)
(def-alien-type caddr-t (* char))
(def-alien-type ino-t unsigned-long)
(def-alien-type swblk-t long)
(def-alien-type size-t long)
(def-alien-type time-t long)
(def-alien-type dev-t short)
(def-alien-type off-t long)
(def-alien-type uid-t unsigned-short)
(def-alien-type gid-t unsigned-short)
(defconstant FD-SETSIZE 256)
(def-alien-type nil
(struct fd-set
(fds-bits (array unsigned-long #.(/ fd-setsize 32)))))
(defmacro fd-set (offset fd-set)
(let ((word (gensym))
(bit (gensym))
(temp (gensym)))
`(multiple-value-bind (,word ,bit) (floor ,offset 32)
(let ((,temp (deref (slot ,fd-set 'fds-bits) ,word)))
(setf (ldb (byte 1 ,bit) ,temp) 1)
(setf (deref (slot ,fd-set 'fds-bits) ,word) ,temp)))))
(defmacro fd-clr (offset fd-set)
(let ((word (gensym))
(bit (gensym))
(temp (gensym)))
`(multiple-value-bind (,word ,bit) (floor ,offset 32)
(let ((,temp (deref (slot ,fd-set 'fds-bits) ,word)))
(setf (ldb (byte 1 ,bit) ,temp) 0)
(setf (deref (slot ,fd-set 'fds-bits) ,word) ,temp)))))
(defmacro fd-isset (offset fd-set)
(let ((word (gensym))
(bit (gensym)))
`(multiple-value-bind (,word ,bit) (floor ,offset 32)
(logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
(defmacro fd-zero (fd-set)
`(dotimes (index (/ fd-setsize 32))
(setf (deref (slot ,fd-set 'fds-bits) index) 0)))
;;; From sys/time.h
(def-alien-type nil
(struct timeval
(tv-sec unsigned-long) ; seconds
(tv-usec unsigned-long))) ; and microseconds
(def-alien-type nil
(struct timezone
(tz-minuteswest int) ; minutes west of Greenwich
(tz-dsttime ; type of dst correction
(enum nil :none :usa :aust :wet :met :eet :can))))
(def-alien-type nil
(struct itimerval
(it-interval (struct timeval)) ; timer interval
(it-value (struct timeval)))) ; current value
;;; From ioctl.h
(def-alien-type nil
(struct tchars
(t-intrc char) ; interrupt
(t-quitc char) ; quit
(t-startc char) ; start output
(t-stopc char) ; stop output
(t-eofc char) ; end-of-file
(t-brkc char))) ; input delimiter (like nl)
(def-alien-type nil
(struct ltchars
(t-suspc char) ; stop process signal
(t-dsuspc char) ; delayed stop process signal
(t-rprntc char) ; reprint line
(t-flushc char) ; flush output (toggles)
(t-werasc char) ; word erase
(t-lnextc char))) ; literal next character
(def-alien-type nil
(struct sgttyb
(sg-ispeed char) ; input speed.
(sg-ospeed char) ; output speed
(sg-erase char) ; erase character
(sg-kill char) ; kill character
(sg-flags short))) ; mode flags
(def-alien-type nil
(struct winsize
(ws-row unsigned-short) ; rows, in characters
(ws-col unsigned-short) ; columns, in characters
(ws-xpixel unsigned-short) ; horizontal size, pixels
(ws-ypixel unsigned-short))) ; veritical size, pixels
;;; From sys/dir.h
(def-alien-type nil
(struct direct
#+sunos (d-off long) ; offset of next disk directory entry
(d-ino unsigned-long) ; inode number of entry
(d-reclen unsigned-short) ; length of this record
(d-namlen unsigned-short) ; length of string in d-name
(d-name (array char 256)))) ; name must be no longer than this
;;; From sys/stat.h
(def-alien-type nil
(struct stat
(st-dev dev-t)
(st-ino ino-t)
(st-mode unsigned-short)
(st-nlink short)
(st-uid uid-t)
(st-gid gid-t)
(st-rdev dev-t)
(st-size off-t)
(st-atime time-t)
(st-spare1 int)
(st-mtime time-t)
(st-spare2 int)
(st-ctime time-t)
(st-spare3 int)
(st-blksize long)
(st-blocks long)
(st-spare4 (array long 2))))
(defconstant s-ifmt #o0170000)
(defconstant s-ifdir #o0040000)
(defconstant s-ifchr #o0020000)
(defconstant s-ifblk #o0060000)
(defconstant s-ifreg #o0100000)
(defconstant s-iflnk #o0120000)
(defconstant s-ifsock #o0140000)
(defconstant s-isuid #o0004000)
(defconstant s-isgid #o0002000)
(defconstant s-isvtx #o0001000)
(defconstant s-iread #o0000400)
(defconstant s-iwrite #o0000200)
(defconstant s-iexec #o0000100)
;;; From sys/resource.h
(def-alien-type nil
(struct rusage
(ru-utime (struct timeval)) ; user time used
(ru-stime (struct timeval)) ; system time used.
(ru-maxrss long)
(ru-ixrss long) ; integral sharded memory size
(ru-idrss long) ; integral unsharded data "
(ru-isrss long) ; integral unsharded stack "
(ru-minflt long) ; page reclaims
(ru-majflt long) ; page faults
(ru-nswap long) ; swaps
(ru-inblock long) ; block input operations
(ru-oublock long) ; block output operations
(ru-msgsnd long) ; messages sent
(ru-msgrcv long) ; messages received
(ru-nsignals long) ; signals received
(ru-nvcsw long) ; voluntary context switches
(ru-nivcsw long))) ; involuntary "
(def-alien-type nil
(struct rlimit
(rlim-cur int) ; current (soft) limit
(rlim-max int))) ; maximum value for rlim-cur
;;;; Errno stuff.
(eval-when (compile eval)
(defparameter *compiler-unix-errors* nil)
(defmacro def-unix-error (name number description)
`(progn
(eval-when (compile eval)
(push (cons ,number ,description) *compiler-unix-errors*))
(defconstant ,name ,number ,description)
(export ',name)))
(defmacro emit-unix-errors ()
(let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*)))
(array (make-array (1+ max) :initial-element nil)))
(dolist (error *compiler-unix-errors*)
(setf (svref array (car error)) (cdr error)))
`(progn
(defvar *unix-errors* ',array)
(proclaim '(simple-vector *unix-errors*)))))
) ;eval-when
;;;
;;; From <errno.h>
;;;
(def-unix-error ESUCCESS 0 "Successful")
(def-unix-error EPERM 1 "Not owner")
(def-unix-error ENOENT 2 "No such file or directory")
(def-unix-error ESRCH 3 "No such process")
(def-unix-error EINTR 4 "Interrupted system call")
(def-unix-error EIO 5 "I/O error")
(def-unix-error ENXIO 6 "No such device or address")
(def-unix-error E2BIG 7 "Arg list too long")
(def-unix-error ENOEXEC 8 "Exec format error")
(def-unix-error EBADF 9 "Bad file number")
(def-unix-error ECHILD 10 "No children")
(def-unix-error EAGAIN 11 "No more processes")
(def-unix-error ENOMEM 12 "Not enough core")
(def-unix-error EACCES 13 "Permission denied")
(def-unix-error EFAULT 14 "Bad address")
(def-unix-error ENOTBLK 15 "Block device required")
(def-unix-error EBUSY 16 "Mount device busy")
(def-unix-error EEXIST 17 "File exists")
(def-unix-error EXDEV 18 "Cross-device link")
(def-unix-error ENODEV 19 "No such device")
(def-unix-error ENOTDIR 20 "Not a director")
(def-unix-error EISDIR 21 "Is a directory")
(def-unix-error EINVAL 22 "Invalid argument")
(def-unix-error ENFILE 23 "File table overflow")
(def-unix-error EMFILE 24 "Too many open files")
(def-unix-error ENOTTY 25 "Not a typewriter")
(def-unix-error ETXTBSY 26 "Text file busy")
(def-unix-error EFBIG 27 "File too large")
(def-unix-error ENOSPC 28 "No space left on device")
(def-unix-error ESPIPE 29 "Illegal seek")
(def-unix-error EROFS 30 "Read-only file system")
(def-unix-error EMLINK 31 "Too many links")
(def-unix-error EPIPE 32 "Broken pipe")
;;;
;;; Math
(def-unix-error EDOM 33 "Argument too large")
(def-unix-error ERANGE 34 "Result too large")
;;;
;;; non-blocking and interrupt i/o
(def-unix-error EWOULDBLOCK 35 "Operation would block")
(def-unix-error EDEADLK 35 "Operation would block") ; Ditto
(def-unix-error EINPROGRESS 36 "Operation now in progress")
(def-unix-error EALREADY 37 "Operation already in progress")
;;;
;;; ipc/network software
(def-unix-error ENOTSOCK 38 "Socket operation on non-socket")
(def-unix-error EDESTADDRREQ 39 "Destination address required")
(def-unix-error EMSGSIZE 40 "Message too long")
(def-unix-error EPROTOTYPE 41 "Protocol wrong type for socket")
(def-unix-error ENOPROTOOPT 42 "Protocol not available")
(def-unix-error EPROTONOSUPPORT 43 "Protocol not supported")
(def-unix-error ESOCKTNOSUPPORT 44 "Socket type not supported")
(def-unix-error EOPNOTSUPP 45 "Operation not supported on socket")
(def-unix-error EPFNOSUPPORT 46 "Protocol family not supported")
(def-unix-error EAFNOSUPPORT 47 "Address family not supported by protocol family")
(def-unix-error EADDRINUSE 48 "Address already in use")
(def-unix-error EADDRNOTAVAIL 49 "Can't assign requested address")
;;;
;;; operational errors
(def-unix-error ENETDOWN 50 "Network is down")
(def-unix-error ENETUNREACH 51 "Network is unreachable")
(def-unix-error ENETRESET 52 "Network dropped connection on reset")
(def-unix-error ECONNABORTED 53 "Software caused connection abort")
(def-unix-error ECONNRESET 54 "Connection reset by peer")
(def-unix-error ENOBUFS 55 "No buffer space available")
(def-unix-error EISCONN 56 "Socket is already connected")
(def-unix-error ENOTCONN 57 "Socket is not connected")
(def-unix-error ESHUTDOWN 58 "Can't send after socket shutdown")
(def-unix-error ETOOMANYREFS 59 "Too many references: can't splice")
(def-unix-error ETIMEDOUT 60 "Connection timed out")
(def-unix-error ECONNREFUSED 61 "Connection refused")
;;;
(def-unix-error ELOOP 62 "Too many levels of symbolic links")
(def-unix-error ENAMETOOLONG 63 "File name too long")
;;;
(def-unix-error EHOSTDOWN 64 "Host is down")
(def-unix-error EHOSTUNREACH 65 "No route to host")
(def-unix-error ENOTEMPTY 66 "Directory not empty")
;;;
;;; quotas & resource
(def-unix-error EPROCLIM 67 "Too many processes")
(def-unix-error EUSERS 68 "Too many users")
(def-unix-error EDQUOT 69 "Disc quota exceeded")
;;;
;;; CMU RFS
(def-unix-error ELOCAL 126 "namei should continue locally")
(def-unix-error EREMOTE 127 "namei was handled remotely")
;;;
;;; VICE
(def-unix-error EVICEERR 70 "Remote file system error ")
(def-unix-error EVICEOP 71 "syscall was handled by Vice")
;;;
;;; Mach Emulation
(def-unix-error ERESTART 72 "Mach Emulation Error (?)")
;;;
;;; And now for something completely different ...
(emit-unix-errors)
(def-alien-variable ("errno" unix-errno) int)
;;; GET-UNIX-ERROR-MSG -- public.
;;;
(defun get-unix-error-msg (&optional (error-number unix-errno))
"Returns a string describing the error number which was returned by a
UNIX system call."
(declare (type integer error-number))
(if (array-in-bounds-p *unix-errors* error-number)
(svref *unix-errors* error-number)
(format nil "Unknown error [~d]" error-number)))
;;;; Lisp types used by syscalls.
(deftype unix-pathname () 'simple-string)
(deftype unix-file-mode () '(unsigned-byte 16))
(deftype unix-fd () `(integer 0 ,most-positive-fixnum))
(deftype unix-pid () '(unsigned-byte 16))
(deftype unix-uid () '(unsigned-byte 16))
(deftype unix-gid () '(unsigned-byte 16))
;;;; System calls.
(defmacro syscall ((name &rest arg-types) success-form &rest args)
`(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
,@args)))
(if (minusp result)
(values nil unix-errno)
,success-form)))
(defmacro void-syscall ((name &rest arg-types) &rest args)
`(syscall (,name ,@arg-types) (values t 0) ,@args))
(defmacro int-syscall ((name &rest arg-types) &rest args)
`(syscall (,name ,@arg-types) (values result 0) ,@args))
;;; Unix-access accepts a path and a mode. It returns two values the
;;; first is T if the file is accessible and NIL otherwise. The second
;;; only has meaning in the second case and is the unix errno value.
(defconstant r_ok 4 "Test for read permission")
(defconstant w_ok 2 "Test for write permission")
(defconstant x_ok 1 "Test for execute permission")
(defconstant f_ok 0 "Test for presence of file")
(defun unix-access (path mode)
"Given a file path (a string) and one of four constant modes,
unix-access returns T if the file is accessible with that
mode and NIL if not. It also returns an errno value with
NIL which determines why the file was not accessible.
The access modes are:
r_ok Read permission.
w_ok Write permission.
x_ok Execute permission.
f_ok Presence of file."
(declare (type unix-pathname path)
(type (mod 8) mode))
(void-syscall ("access" c-string int) path mode))
;;; Unix-chdir accepts a directory name and makes that the
;;; current working directory.
(defun unix-chdir (path)
"Given a file path string, unix-chdir changes the current working
directory to the one specified."
(declare (type unix-pathname path))
(void-syscall ("chdir" c-string) path))
;;; Unix-chmod accepts a path and a mode and changes the mode to the new mode.
(defconstant setuidexec #o4000 "Set user ID on execution")
(defconstant setgidexec #o2000 "Set group ID on execution")
(defconstant savetext #o1000 "Save text image after execution")
(defconstant readown #o400 "Read by owner")
(defconstant writeown #o200 "Write by owner")
(defconstant execown #o100 "Execute (search directory) by owner")
(defconstant readgrp #o40 "Read by group")
(defconstant writegrp #o20 "Write by group")
(defconstant execgrp #o10 "Execute (search directory) by group")
(defconstant readoth #o4 "Read by others")
(defconstant writeoth #o2 "Write by others")
(defconstant execoth #o1 "Execute (search directory) by others")
(defun unix-chmod (path mode)
"Given a file path string and a constant mode, unix-chmod changes the
permission mode for that file to the one specified. The new mode
can be created by logically OR'ing the following:
setuidexec Set user ID on execution.
setgidexec Set group ID on execution.
savetext Save text image after execution.
readown Read by owner.
writeown Write by owner.
execown Execute (search directory) by owner.
readgrp Read by group.
writegrp Write by group.
execgrp Execute (search directory) by group.
readoth Read by others.
writeoth Write by others.
execoth Execute (search directory) by others.
It returns T on successfully completion; NIL and an error number
otherwise."
(declare (type unix-pathname path)
(type unix-file-mode mode))
(void-syscall ("chmod" c-string int) path mode))
;;; Unix-fchmod accepts a file descriptor ("fd") and a file protection mode
;;; ("mode") and changes the protection of the file described by "fd" to
;;; "mode".
(defun unix-fchmod (fd mode)
"Given an integer file descriptor and a mode (the same as those
used for unix-chmod), unix-fchmod changes the permission mode
for that file to the one specified. T is returned if the call
was successful."
(declare (type unix-fd fd)
(type unix-file-mode mode))
(void-syscall ("fchmod" int int) fd mode))
(defun unix-chown (path uid gid)
"Given a file path, an integer user-id, and an integer group-id,
unix-chown changes the owner of the file and the group of the
file to those specified. Either the owner or the group may be
left unchanged by specifying them as -1. Note: Permission will
fail if the caller is not the superuser."
(declare (type unix-pathname path)
(type (or unix-uid (integer -1 -1)) uid)
(type (or unix-gid (integer -1 -1)) gid))
(void-syscall ("chown" c-string int int) path uid gid))
;;; Unix-fchown is exactly the same as unix-chown except that the file
;;; is specified by a file-descriptor ("fd") instead of a pathname.
(defun unix-fchown (fd uid gid)
"Unix-fchown is like unix-chown, except that it accepts an integer
file descriptor instead of a file path name."
(declare (type unix-fd fd)
(type (or unix-uid (integer -1 -1)) uid)
(type (or unix-gid (integer -1 -1)) gid))
(void-syscall ("fchown" int int int) fd uid gid))
;;; Returns the maximum size (i.e. the number of array elements
;;; of the file descriptor table.
(defun unix-getdtablesize ()
"Unix-getdtablesize returns the maximum size of the file descriptor
table. (i.e. the maximum number of descriptors that can exist at
one time.)"
(int-syscall ("getdtablesize")))
;;; Unix-close accepts a file descriptor and attempts to close the file
;;; associated with it.
(defun unix-close (fd)
"Unix-close takes an integer file descriptor as an argument and
closes the file associated with it. T is returned upon successful
completion, otherwise NIL and an error number."
(declare (type unix-fd fd))
(void-syscall ("close" int) fd))
;;; Unix-creat accepts a file name and a mode. It creates a new file
;;; with name and sets it mode to mode (as for chmod).
(defun unix-creat (name mode)
"Unix-creat accepts a file name and a mode (same as those for
unix-chmod) and creates a file by that name with the specified
permission mode. It returns T on success, or NIL and an error
number otherwise."
(declare (type unix-pathname name)
(type unix-file-mode mode))
(void-syscall ("creat" c-string int) name mode))
;;; Unix-dup returns a duplicate copy of the existing file-descriptor
;;; passed as an argument.
(defun unix-dup (fd)
"Unix-dup duplicates an existing file descriptor (given as the
argument) and returns T and the value for the duplicate if
successful."
(declare (type unix-fd fd))
(int-syscall ("dup" int) fd))
;;; Unix-dup2 makes the second file-descriptor describe the same file
;;; as the first. If the second file-descriptor points to an open
;;; file, it is first closed. In any case, the second should have a
;;; value which is a valid file-descriptor.
(defun unix-dup2 (fd1 fd2)
"Unix-dup2 duplicates an existing file descriptor just as unix-dup
does only the new value of the duplicate descriptor may be requested
through the second argument. If a file already exists with the
requested descriptor number, it will be closed and the number
assigned to the duplicate."
(declare (type unix-fd fd1 fd2))
(void-syscall ("dup2" int int) fd1 fd2))
;;; Unix-fcntl takes a file descriptor, an integer command
;;; number, and optional command arguments. It performs
;;; operations on the associated file and/or returns inform-
;;; ation about the file.
;;; Operations performed on file descriptors:
(defconstant F-DUPFD 0 "Duplicate a file descriptor")
(defconstant F-GETFD 1 "Get file desc. flags")
(defconstant F-SETFD 2 "Set file desc. flags")
(defconstant F-GETFL 3 "Get file flags")
(defconstant F-SETFL 4 "Set file flags")
(defconstant F-GETOWN 5 "Get owner")
(defconstant F-SETOWN 6 "Set owner")
;;; File flags for F-GETFL and F-SETFL:
(defconstant FNDELAY #o0004 "Non-blocking reads")
(defconstant FAPPEND #o0010 "Append on each write")
(defconstant FASYNC #o0100 "Signal pgrp when data ready")
(defconstant FCREAT #o1000 "Create if nonexistant")
(defconstant FTRUNC #o2000 "Truncate to zero length")
(defconstant FEXCL #o4000 "Error if already created")
(defun unix-fcntl (fd cmd arg)
"Unix-fcntl manipulates file descriptors according to the
argument CMD which can be one of the following:
F-DUPFD Duplicate a file descriptor.
F-GETFD Get file descriptor flags.
F-SETFD Set file descriptor flags.
F-GETFL Get file flags.
F-SETFL Set file flags.
F-GETOWN Get owner.
F-SETOWN Set owner.
The flags that can be specified for F-SETFL are:
FNDELAY Non-blocking reads.
FAPPEND Append on each write.
FASYNC Signal pgrp when data ready.
FCREAT Create if nonexistant.
FTRUNC Truncate to zero length.
FEXCL Error if already created.
"
(declare (type unix-fd fd)
(type (integer 0 6) cmd)
(type (unsigned-byte 16) arg))
(int-syscall ("fcntl" int int int) fd cmd arg))
;;; Unix-link creates a hard link from name2 to name1.
(defun unix-link (name1 name2)
"Unix-link creates a hard link from the file with name1 to the
file with name2."
(declare (type unix-pathname name1 name2))
(void-syscall ("link" c-string c-string) name1 name2))
;;; Unix-lseek accepts a file descriptor, an offset, and whence value.
(defconstant l_set 0 "set the file pointer")
(defconstant l_incr 1 "increment the file pointer")
(defconstant l_xtnd 2 "extend the file size")
(defun unix-lseek (fd offset whence)
"Unix-lseek accepts a file descriptor and moves the file pointer ahead
a certain offset for that file. Whence can be any of the following:
l_set Set the file pointer.
l_incr Increment the file pointer.
l_xtnd Extend the file size.
"
(declare (type unix-fd fd)
(type (unsigned-byte 32) offset)
(type (integer 0 2) whence))
(int-syscall ("lseek" int off-t int) fd offset whence))
;;; Unix-mkdir accepts a name and a mode and attempts to create the
;;; corresponding directory with mode mode.
(defun unix-mkdir (name mode)
"Unix-mkdir creates a new directory with the specified name and mode.
(Same as those for unix-fchmod.) It returns T upon success, otherwise
NIL and an error number."
(declare (type unix-pathname name)
(type unix-file-mode mode))
(void-syscall ("mkdir" c-string int) name mode))
;;; Unix-open accepts a pathname (a simple string), flags, and mode and
;;; attempts to open file with name pathname.
(defconstant o_rdonly 0 "Read-only flag.")
(defconstant o_wronly 1 "Write-only flag.")
(defconstant o_rdwr 2 "Read-write flag.")
(defconstant o_append #o10 "Append flag.")
(defconstant o_creat #o1000 "Create if nonexistant flag.")
(defconstant o_trunc #o2000 "Truncate flag.")
(defconstant o_excl #o4000 "Error if already exists.")
(defun unix-open (path flags mode)
"Unix-open opens the file whose pathname is specified by path
for reading and/or writing as specified by the flags argument.
The flags argument can be:
o_rdonly Read-only flag.
o_wronly Write-only flag.
o_rdwr Read-and-write flag.
o_append Append flag.
o_creat Create-if-nonexistant flag.
o_trunc Truncate-to-size-0 flag.
If the o_creat flag is specified, then the file is created with
a permission of argument mode if the file doesn't exist. An
integer file descriptor is returned by unix-open."
(declare (type unix-pathname path)
(type (unsigned-byte 16) flags)
(type unix-file-mode mode))
(int-syscall ("open" c-string int int) path flags mode))
(defun unix-pipe ()
"Unix-pipe sets up a unix-piping mechanism consisting of
an input pipe and an output pipe. Unix-Pipe returns two
values: if no error occurred the first value is the pipe
to be read from and the second is can be written to. If
an error occurred the first value is NIL and the second
the unix error code."
(with-alien ((fds (array int 2)))
(syscall ("pipe" (* int))
(values (deref fds 0) (deref fds 1))
(cast fds (* int)))))
;;; Unix-read accepts a file descriptor, a buffer, and the length to read.
;;; It attempts to read len bytes from the device associated with fd
;;; and store them into the buffer. It returns the actual number of
;;; bytes read.
(defun unix-read (fd buf len)
"Unix-read attempts to read from the file described by fd into
the buffer buf until it is full. Len is the length of the buffer.
The number of bytes actually read is returned or NIL and an error
number if an error occured."
(declare (type unix-fd fd)
(type (unsigned-byte 32) len))
#+sunos
;; Note: Under sunos we touch each page before doing the read to give
;; the segv handler a chance to fix the permissions. Otherwise,
;; read will return EFAULT. This also bypasses a bug in 4.1.1 in which
;; read fails with EFAULT if the page has never been touched even if
;; the permissions are okay.
(without-gcing
(let* ((page-size (get-page-size))
(1-page-size (1- page-size))
(sap (etypecase buf
(system-area-pointer buf)
(vector (vector-sap buf))))
(end (sap+ sap len)))
(declare (type (and fixnum unsigned-byte) page-size 1-page-size)
(type system-area-pointer sap end)
(optimize (speed 3) (safety 0)))
(do ((sap (int-sap (logand (the (unsigned-byte 32)
(+ (sap-int sap) 1-page-size))
(logxor 1-page-size (ldb (byte 32 0) -1))))
(sap+ sap page-size)))
(declare (type system-area-pointer sap))
(setf (sap-ref-8 sap 0) (sap-ref-8 sap 0)))))
(int-syscall ("read" int (* char) int) fd buf len))
(defun unix-readlink (path)
"Unix-readlink invokes the readlink system call on the file name
specified by the simple string path. It returns up to two values:
the contents of the symbolic link if the call is successful, or
NIL and the Unix error number."
(declare (type unix-pathname path))
(with-alien ((buf (array char 1024)))
(syscall ("readlink" c-string (* char) int)
(let ((string (make-string result)))
(kernel:copy-from-system-area
(alien-sap buf) 0
string (* vm:vector-data-offset vm:word-bits)
(* result vm:byte-bits))
string)
path (cast buf (* char)) 1024)))
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
;;; Unix-rename accepts two files names and renames the first to the second.
(defun unix-rename (name1 name2)
"Unix-rename renames the file with string name1 to the string
name2. NIL and an error code is returned if an error occured."
(declare (type unix-pathname name1 name2))
(void-syscall ("rename" c-string c-string) name1 name2))
;;; Unix-rmdir accepts a name and removes the associated directory.
(defun unix-rmdir (name)
"Unix-rmdir attempts to remove the directory name. NIL and
an error number is returned if an error occured."
(declare (type unix-pathname name))
(void-syscall ("rmdir" c-string) name))
;;; Unix-select accepts sets of file descriptors and waits for an event
;;; to happen on one of them or to time out.
(defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
"Unix-select examines the sets of descriptors passed as arguments
to see if they are ready for reading and writing. See the UNIX
Programmers Manual for more information."
(with-alien ((tv (struct timeval))
(rdf (struct fd-set))
(wrf (struct fd-set))
(xpf (struct fd-set)))
(when to-secs
(setf (slot tv 'tv-sec) to-secs)
(setf (slot tv 'tv-usec) to-usecs))
(fd-zero rdf) (fd-zero wrf) (fd-zero xpf)
(dotimes (index (ceiling nfds 32))
(macrolet ((frob (lisp-var alien-var)
`(setf (deref (slot ,alien-var 'fds-bits) index)
(ldb (byte 32 0) ,lisp-var)
,lisp-var (ash -32 ,lisp-var))))
(frob rdfds rdf)
(frob wrfds wrf)
(frob xpfds xpf)))
(macrolet ((frob (lispvar alienvar)
`(if (zerop ,lispvar)
(int-sap 0)
(addr ,alienvar))))
(syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
(* (struct fd-set)) (* (struct timeval)))
(let ((rdfds 0) (wrfds 0) (xpfds 0))
(do ((index (1- (ceiling nfds 32)) (1- index)))
((minusp index))
(macrolet ((frob (lisp-var alien-var)
`(setf ,lisp-var
(logior (ash ,lisp-var 32)
(deref (slot ,alien-var
'fds-bits)
index)))))
(frob rdfds rdf)
(frob wrfds wrf)
(frob xpfds xpf)))
(values result rdfds wrfds xpfds))
nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf)
(if to-secs (addr tv) (int-sap 0))))))
;;; Unix-sync writes all information in core memory which has been modified
;;; to permanent storage (i.e. disk).
(defun unix-sync ()
"Unix-sync writes all information in core memory which has been
modified to disk. It returns NIL and an error code if an error
occured."
(void-syscall ("sync")))
;;; Unix-fsync writes the core-image of the file described by "fd" to
;;; permanent storage (i.e. disk).
(defun unix-fsync (fd)
"Unix-fsync writes the core image of the file described by
fd to disk."
(declare (type unix-fd fd))
(void-syscall ("fsync" int) fd))
;;; Unix-truncate accepts a file name and a new length. The file is
;;; truncated to the new length.
(defun unix-truncate (name len)
"Unix-truncate truncates the named file to the length (in
bytes) specified by len. NIL and an error number is returned
if the call is unsuccessful."
(declare (type unix-pathname name)
(type (unsigned-byte 32) len))
(void-syscall ("truncate" c-string int) name len))
(defun unix-ftruncate (fd len)
"Unix-ftruncate is similar to unix-truncate except that the first
argument is a file descriptor rather than a file name."
(declare (type unix-fd fd)
(type (unsigned-byte 32) len))
(void-syscall ("ftruncate" int int) fd len))
(defun unix-symlink (name1 name2)
"Unix-symlink creates a symbolic link named name2 to the file
named name1. NIL and an error number is returned if the call
is unsuccessful."
(declare (type unix-pathname name1 name2))
(void-syscall ("symlink" c-string c-string) name1 name2))
;;; Unix-unlink accepts a name and deletes the directory entry for that
;;; name and the file if this is the last link.
(defun unix-unlink (name)
"Unix-unlink removes the directory entry for the named file.
NIL and an error code is returned if the call fails."
(declare (type unix-pathname name))
(void-syscall ("unlink" c-string) name))
;;; Unix-write accepts a file descriptor, a buffer, an offset, and the
;;; length to write. It attempts to write len bytes to the device
;;; associated with fd from the the buffer starting at offset. It returns
;;; the actual number of bytes written.
(defun unix-write (fd buf offset len)
"Unix-write attempts to write a character buffer (buf) of length
len to the file described by the file descriptor fd. NIL and an
error is returned if the call is unsuccessful."
(declare (type unix-fd fd)
(type (unsigned-byte 32) offset len))
(int-syscall ("write" int (* char) int)
fd
(with-alien ((ptr (* char) buf))
(addr (deref ptr offset)))
len))
;;; Unix-ioctl is used to change parameters of devices in a device
;;; dependent way.
(defconstant terminal-speeds
'#(nil 50 75 110 nil 150 200 300 600 1200 1800 2400 4800 9600 nil nil))
(defconstant tty-raw #o40)
(defconstant tty-crmod #o20)
(defconstant tty-echo #o10)
(defconstant tty-lcase #o4)
(defconstant tty-cbreak #o2)
(defconstant tty-tandem #o1)
(eval-when (compile load eval)
(defconstant iocparm-mask #x7f)
(defconstant ioc_void #x20000000)
(defconstant ioc_out #x40000000)
(defconstant ioc_in #x80000000)
(defconstant ioc_inout (logior ioc_in ioc_out))
(defmacro define-ioctl-command (name dev cmd arg &optional (parm-type :void))
(:inout ioc_inout)))
(code (logior (ash (char-code dev) 8) cmd ptype)))
(when arg
(setf code
`(logior (ash (logand (alien-size ,arg :bytes)
,iocparm-mask)
16)
,code)))
(define-ioctl-command TIOCGETP #\t 8 (struct sgttyb) :out)
(define-ioctl-command TIOCSETP #\t 9 (struct sgttyb) :in)
(define-ioctl-command TIOCFLUSH #\t 16 int :in)
(define-ioctl-command TIOCSETC #\t 17 (struct tchars) :in)
(define-ioctl-command TIOCGETC #\t 18 (struct tchars) :out)
(define-ioctl-command TIOCGWINSZ #\t 104 (struct winsize) :out)
(define-ioctl-command TIOCSWINSZ #\t 103 (struct winsize) :in)
(define-ioctl-command TIOCSLTC #\t 117 (struct ltchars) :in)
(define-ioctl-command TIOCGLTC #\t 116 (struct ltchars) :out)
(define-ioctl-command TIOCSPGRP #\t 118 int :in)
(define-ioctl-command TIOCGPGRP #\t 119 int :out)
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(defun unix-ioctl (fd cmd arg)
"Unix-ioctl performs a variety of operations on open i/o
descriptors. See the UNIX Programmer's Manual for more
information."
(declare (type unix-fd fd)
(type (unsigned-byte 32) cmd))
(void-syscall ("ioctl" int int (* char)) fd cmd arg))
;;; Unix-exit terminates a program.
(defun unix-exit (&optional (code 0))
"Unix-exit terminates the current process with an optional
error code. If successful, the call doesn't return. If
unsuccessful, the call returns NIL and an error number."
(declare (type (signed-byte 32) code))
(void-syscall ("exit" int) code))
;;; STAT and friends.
(defmacro extract-stat-results (buf)
`(values T
(slot ,buf 'st-dev)
(slot ,buf 'st-ino)
(slot ,buf 'st-mode)
(slot ,buf 'st-nlink)
(slot ,buf 'st-uid)
(slot ,buf 'st-gid)
(slot ,buf 'st-rdev)
(slot ,buf 'st-size)
(slot ,buf 'st-atime)
(slot ,buf 'st-mtime)
(slot ,buf 'st-ctime)
(slot ,buf 'st-blksize)
(slot ,buf 'st-blocks)))
(defun unix-stat (name)
"Unix-stat retrieves information about the specified
file returning them in the form of multiple values.
See the UNIX Programmer's Manual for a description
of the values returned. If the call fails, then NIL
and an error number is returned instead."
(declare (type unix-pathname name))
(with-alien ((buf (struct stat)))
(syscall ("stat" c-string (* (struct stat)))
(extract-stat-results buf)
name (addr buf))))
(defun unix-lstat (name)
"Unix-lstat is similar to unix-stat except the specified
file must be a symbolic link."
(declare (type unix-pathname name))