Added and removed some WITH-STANDARD-IO-SYNTAX.
[com-informatimago:com-informatimago.git] / clisp / susv3-xsi.lisp
1 ;;;; -*- coding:utf-8 -*-
2 ;;;;****************************************************************************
3 ;;;;FILE:               susv3-xsi.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    This packages exports SUSV3 XSI functions.
10 ;;;;    This is the CLISP specific implementation of the SUSV3 XSI API.
11 ;;;;
12 ;;;;
13 ;;;;    The Open Group Base Specifications Issue 6
14 ;;;;    IEEE Std 1003.1, 2003 Edition
15 ;;;;
16 ;;;;    http://www.opengroup.org/onlinepubs/007904975/index.html
17 ;;;;
18 ;;;;
19 ;;;;    Implemented:
20 ;;;;        ftw
21 ;;;;        msgget/msgctl/msgsnd/msgrcv
22 ;;;;        shmget/shmctl/shmat/shmdt
23 ;;;;
24 ;;;;AUTHORS
25 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
26 ;;;;MODIFICATIONS
27 ;;;;    2004-11-29 <PJB> Added IPC.
28 ;;;;    2003-06-18 <PJB> Created (FTW).
29 ;;;;BUGS
30 ;;;;    Actually, we should include the features only if it's proven to exist
31 ;;;;    on the current system. At run-time.
32 ;;;;
33 ;;;;    The type of arguments and results of FFI function should be pure
34 ;;;;    Common-Lisp objects. We shouldn't need to do any FFI stuff outside 
35 ;;;;    of here.
36 ;;;;
37 ;;;;LEGAL
38 ;;;;    GPL
39 ;;;;    
40 ;;;;    Copyright Pascal J. Bourguignon 2004 - 2004
41 ;;;;    
42 ;;;;    This program is free software; you can redistribute it and/or
43 ;;;;    modify it under the terms of the GNU General Public License
44 ;;;;    as published by the Free Software Foundation; either version
45 ;;;;    2 of the License, or (at your option) any later version.
46 ;;;;    
47 ;;;;    This program is distributed in the hope that it will be
48 ;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
49 ;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
50 ;;;;    PURPOSE.  See the GNU General Public License for more details.
51 ;;;;    
52 ;;;;    You should have received a copy of the GNU General Public
53 ;;;;    License along with this program; if not, write to the Free
54 ;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
55 ;;;;    Boston, MA 02111-1307 USA
56 ;;;;****************************************************************************
57
58 (in-package "COMMON-LISP-USER")
59 (DECLAIM (DECLARATION ALSO-USE-PACKAGES))
60 (declaim (ALSO-USE-PACKAGES "FFI" "LINUX"))
61 (eval-when (:compile-toplevel :load-toplevel :execute) (require "linux"))
62 (defPACKAGE "COM.INFORMATIMAGO.CLISP.SUSV3-XSI"
63   (:DOCUMENTATION "This packages exports SUSV3 XSI functions.
64     This is the CLISP specific implementation of the SUSV3 XSI API.")
65   (:use "COMMON-LISP"
66         "COM.INFORMATIMAGO.CLISP.SUSV3")
67   (:EXPORT 
68    ;; FTW
69    "+FTW-F+" "+FTW-D+" "+FTW-DNR+" "+FTW-DP+" "+FTW-NS+" "+FTW-SL+"
70    "+FTW-SLN+" "+FTW-PHYS+" "+FTW-MOUNT+" "+FTW-DEPTH+" "+FTW-CHDIR+"
71    "FTW" "FTW-FILTER" "NFTW-FILTER" "FTW" "+FTW-F+" "+FTW-D+" "+FTW-DNR+"
72    "+FTW-DP+" "+FTW-NS+" "+FTW-SL+" "+FTW-SLN+"
73    ;; IPC:
74    "IPC_CREAT" "IPC_EXCL" "IPC_NOWAIT" "IPC_RMID" "IPC_SET" "IPC_STAT"
75    "IPC_INFO" "IPC_PRIVATE" "IPC_PERM" "FTOK" 
76    "MSG_NOERROR" "MSG_EXCEPT" "MSGQNUM_T" "MSGLEN_T" "MSQID_DS"
77    "MSG_STAT" "MSG_INFO" "MSGINFO"
78    "MSGGET" "MSGCTL" "MSGSND" "MSGRCV"
79    "+MAX-MTEXT-SIZE+" "MSGBUF" "MAKE-MSGBUF" 
80    "SHM_R" "SHM_W" "SHM_RDONLY" "SHM_RND" "SHM_REMAP" "SHM_LOCK"
81    "SHM_UNLOCK" "GETPAGESIZE" "SHMLBA" "SHM_STAT" "SHM_INFO" "SHM_DEST" 
82    "SHM_LOCKED" "SHM_HUGETLB" "SHMID_DS" "SHMGET" "SHMCTL" "SHMAT" "SHMDT"
83    "SEM_UNDO" "GETPID" "GETVAL" "GETALL" "GETNCNT" "GETZCNT" "SETVAL"
84    "SETALL" "SEMMNI" "SEMMSL" "SEMMNS" "SEMOPM" "SEMVMX" "SEMAEM"
85    "SEMID_DS" "SEM_STAT" "SEM_INFO" "SEMINFO" "SEMBUF" 
86    "SEMGET" "SEMCTL" "SEMOP"
87    ;; // WARNING // WARNING // WARNING // WARNING // WARNING // WARNING // 
88    ;; The following are readers, not accessors!!!
89    ;; // WARNING // WARNING // WARNING // WARNING // WARNING // WARNING // 
90    "MSGBUF-MTYPE" "MSGBUF-MTEXT" "IPC_PERMKEY" "IPC_PERMUID"
91    "IPC_PERMGID" "IPC_PERMCUID" "IPC_PERMCGID" "IPC_PERMMODE"
92    "IPC_PERMSEQ" "MSGQID_DS-MSG_PERM" "MSGQID_DS-MSG_STIME"
93    "MSQID_DS-MSG_RTIME" "MSQID_DS-MSG_CTIME" "MSQID_DS-MSG_CBYTES"
94    "MSQID_DS-MSG_QNUM" "MSQID_DS-MSG_QBYTES" "MSQID_DS-MSG_LSPID"
95    "MSQID_DS-MSG_LRPID" "MSGINFO-MSGPOOL" "MSGINFO-MSGMAP"
96    "MSGINFO-MSGMAX" "MSGINFO-MSGMNB" "MSGINFO-MSGMNI" "MSGINFO-MSGSSZ"
97    "MSGINFO-MSGTQL" "MSGINFO-MSGSEG"
98    "SHMID_DS-SHM_PERM" "SHMID_DS-SHM_SEGSZ"
99    "SHMID_DS-SHM_ATIME" "SHMID_DS-SHM_DTIME" "SHMID_DS-SHM_CTIME"
100    "SHMID_DS-SHM_CPID" "SHMID_DS-SHM_LPID" "SHMID_DS-SHM_NATTCH"
101    "SEMID_DS-SEM_PERM" "SEMID_DS-SEM_OTIME" "SEMID_DS-SEM_CTIME"
102    "SEMID_DS-SEM_NSEMS" 
103    "SEMINFO-SEMMAP" "SEMINFO-SEMMNI" "SEMINFO-SEMMNS"
104    "SEMINFO-SEMMNU" "SEMINFO-SEMMSL" "SEMINFO-SEMOPM" "SEMINFO-SEMUME"
105    "SEMINFO-SEMUSZ" "SEMINFO-SEMVMX" "SEMINFO-SEMAEM"
106    "SEMBUF-SEM_NUM" "SEMBUF-SEM_OP" "SEMBUF-SEM_FLG" ))
107 (in-package "COM.INFORMATIMAGO.CLISP.SUSV3-XSI")
108
109
110 (eval-when (:compile-toplevel :load-toplevel :execute)
111   ;; TODO: Actually, we should include the features only if it's proven to exist on the current system. At run-time.
112   (pushnew :susv3-xsi *features*))
113
114
115 (eval-when (:compile-toplevel :load-toplevel :execute)
116   (defparameter +libc+ "/lib/libc.so.6"))
117
118
119
120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
121 ;; FTW.H
122 ;;
123 ;; NOTE: WE DON'T USE THE LIBC IMPLEMENTATION OF FTW;
124 ;;       WE IMPLEMENT IT IN LISP USING SUSV3:DIRENT AND SUSV3:STAT.
125 ;;       ANOTHER IMPLEMENTATION COULD USE THE C VERSION (BUT WOULD HAVE
126 ;;       TO USE C-TO-LISP CALLBACKS!
127 ;;
128
129
130 (DEFCONSTANT +FTW-F+   0 "File.")
131 (DEFCONSTANT +FTW-D+   1 "Directory.")
132 (DEFCONSTANT +FTW-DNR+ 2 "Directory without read permission.")
133 (DEFCONSTANT +FTW-DP+  3 "Directory with subdirectories visited.")
134 (DEFCONSTANT +FTW-NS+  4 "Unknown type; stat() failed.")
135 (DEFCONSTANT +FTW-SL+  5 "Symbolic link.")
136 (DEFCONSTANT +FTW-SLN+ 6 "Symbolic link that names a nonexistent file.")
137
138
139 (DEFCONSTANT +FTW-PHYS+ 1
140   "Physical walk, does not follow symbolic links. Otherwise, NFTW
141 follows links but does not walk down any path that crosses itself.")
142
143 (DEFCONSTANT +FTW-MOUNT+ 2 "The walk does not cross a mount point.")
144 (DEFCONSTANT +FTW-DEPTH+ 4
145   "All subdirectories are visited before the directory itself.")
146 (DEFCONSTANT +FTW-CHDIR+ 8
147   "The walk changes to each directory before reading it.")
148
149
150 (DEFSTRUCT FTW
151   (BASE  0 :TYPE INTEGER)
152   (LEVEL 0 :TYPE INTEGER))
153
154
155 (DEFTYPE FTW-FILTER  ()
156   '(FUNCTION (SIMPLE-STRING STAT INTEGER)     INTEGER))
157 (DEFTYPE NFTW-FILTER ()
158   '(FUNCTION (SIMPLE-STRING STAT INTEGER FTW) INTEGER))
159
160
161 (declaim
162  (FTYPE (FUNCTION (SIMPLE-STRING FTW-FILTER  INTEGER)         INTEGER) FTW)
163  (FTYPE (FUNCTION (SIMPLE-STRING NFTW-FILTER INTEGER INTEGER) INTEGER) NFTW))
164
165
166 ;; ISSUE:  SHOULD THE FILTER RETURN NIL/T OR ZEROP/NOT ZEROP?
167 ;;         AS DEFINED BY SUSV3, ZEROP/NOT ZEROP ALLOW IT TO RETURN
168 ;;         A USEFUL VALUE THRU FTW.
169 ;;
170 ;; ISSUE:  SHOULD THE FILTER BE ALLOWED TO RETURN NIL/NOT NULL?
171 ;;         THAT WOULD BE EVEN MORE USEFUL!
172 ;;
173 ;; ISSUE:  SPECIFY WHAT HAPPENS WHEN A CONDITION OCCURS IN THE FILTER
174 ;;         --> THE FILTER IS ONLY UNWIND-PROTECTED.
175 ;;
176 ;; ISSUE:  SPECIFY THAT FILTER CAN RECEIVE A NIL STAT RATHER THAN AN
177 ;;         UNDEFINED ONE. OR NOT?
178 ;;
179 ;; ISSUE:  specify that ftw and nfw must not give "." and ".." to the filter
180 ;;         (but only when "." is the starting path). (This is underspecified
181 ;;         in SUSv3).
182
183
184 (DEFUN FTW (PATH FILTER NDIRS)
185   "
186 URL:        http://www.opengroup.org/onlinepubs/007904975/functions/ftw.html
187 "
188   (DECLARE (TYPE (INTEGER 1 #|+OPEN-MAX+|#) NDIRS))
189   (declare (ignore ndirs))
190   ;; We'll have always only one DIR-STREAM open: we keep the list of
191   ;; subdirectories in memory and process them after having read the directory.
192   (LET ((DIR-STREAM (OPENDIR PATH)))
193     (UNWIND-PROTECT
194          (DO* ((ENTRY (READDIR DIR-STREAM) (READDIR DIR-STREAM))
195                (DIRECTORIES '())
196                SUBPATH STAT FLAG
197                (RESULT 0))
198               ((OR (NULL ENTRY) (/= 0 RESULT)) DIRECTORIES)
199            (UNLESS (OR (STRING= (DIRENT-NAME ENTRY) "..")
200                        (STRING= (DIRENT-NAME ENTRY) "."))
201              (SETQ SUBPATH (CONCATENATE 'STRING PATH "/"
202                                         (DIRENT-NAME ENTRY)))
203              (HANDLER-CASE (SETQ STAT (LSTAT SUBPATH))
204                (T () (SETQ STAT NIL)))
205              (COND
206                ((NULL STAT)
207                 (SETQ FLAG +FTW-NS+))
208                ((S-ISREG (STAT-MODE STAT))
209                 (SETQ FLAG +FTW-F+))
210                ((S-ISDIR (STAT-MODE STAT))
211                 (PUSH SUBPATH DIRECTORIES)
212                 (SETQ FLAG +FTW-F+))
213                ((S-ISLNK (STAT-MODE STAT))
214                 (HANDLER-CASE (SETQ STAT (STAT SUBPATH)
215                                     FLAG +FTW-SL+)))
216                (T () (SETQ STAT NIL
217                            FLAG +FTW-SLN+)))
218              (SETQ RESULT
219                    (HANDLER-CASE
220                        (funcall FILTER (DIRENT-NAME ENTRY) STAT FLAG)
221                      (T () -1)))))
222       (CLOSEDIR DIR-STREAM))))
223
224     
225 (DEFCONSTANT +FTW-F+   0 "File.")
226 (DEFCONSTANT +FTW-D+   1 "Directory.")
227 (DEFCONSTANT +FTW-DNR+ 2 "Directory without read permission.")
228 (DEFCONSTANT +FTW-DP+  3 "Directory with subdirectories visited.")
229 (DEFCONSTANT +FTW-NS+  4 "Unknown type; stat() failed.")
230 (DEFCONSTANT +FTW-SL+  5 "Symbolic link.")
231 (DEFCONSTANT +FTW-SLN+ 6 "Symbolic link that names a nonexistent file.")
232
233
234 ;; int ftw(const char *,int (*)(const char *,const struct stat *,int),int)
235 ;; int nftw(const char *,int (*)(const char *,const struct stat *, int,struct FTW*),int,int)
236
237
238 ;; (DEFUN FIND ()
239 ;;   (DO* ((DIR-STREAM (OPENDIR "/tmp"))
240 ;;         (ENTRY (READDIR DIR-STREAM) (READDIR DIR-STREAM)))
241 ;;       ((NULL ENTRY))
242 ;;     (FORMAT T "entry: ~8D ~S~%" (DIRENT-INO ENTRY) (DIRENT-NAME ENTRY))))
243
244
245
246 ;;----------------------------------------------------------------------
247 ;; ipc
248 ;;----------------------------------------------------------------------
249
250 (defconstant IPC_CREAT   #o01000 "Create key if key does not exist.")
251 (defconstant IPC_EXCL    #o02000 "Fail if key exists.")
252 (defconstant IPC_NOWAIT  #o04000 "Return error on wait.")
253
254 ;; Control commands for `msgctl', `semctl', and `shmctl'. 
255 (defconstant IPC_RMID    0       "Remove identifier.")
256 (defconstant IPC_SET     1       "Set `ipc_perm' options.")
257 (defconstant IPC_STAT    2       "Get `ipc_perm' options.")
258 (defconstant IPC_INFO    3       "See ipcs.")
259
260 (defconstant IPC_PRIVATE 0 "Private key.")
261
262
263 (ffi:def-c-struct ipc_perm
264   (key     linux:|key_t|)               ; Key.
265   (uid     linux:|uid_t|)               ; Owner's user ID. 
266   (gid     linux:|gid_t|)               ; Owner's group ID.
267   (cuid    linux:|uid_t|)               ; Creator's user ID.
268   (cgid    linux:|gid_t|)               ; Creator's group ID.
269   (mode    ffi:ushort)                  ; Read/write permission.
270   (pad1    ffi:ushort)
271   (seq     ffi:ushort)                  ; Sequence number.
272   (pad2    ffi:ushort)
273   (unused1 ffi:ulong)
274   (unused2 ffi:ulong))
275
276
277 (ffi:def-call-out ftok (:name "ftok")
278   (:arguments (pathname ffi:c-string) (proj-id ffi:int))
279   (:return-type linux:|key_t|)
280   (:library #.+libc+) (:language :stdc))
281
282
283 ;;----------------------------------------------------------------------
284 ;; msg
285 ;;----------------------------------------------------------------------
286
287 (defconstant MSG_NOERROR  #o010000 "no error if message is too big")
288 (defconstant MSG_EXCEPT   #o020000 "recv any msg except of specified type")
289
290 ;; Types used in the structure definition.  
291 (ffi:def-c-type msgqnum_t ffi:ulong)
292 (ffi:def-c-type msglen_t  ffi:ulong)
293
294
295 ;; Structure of record for one message inside the kernel.
296 ;; The type `struct msg' is opaque.
297 (ffi:def-c-struct msqid_ds
298   (msg_perm    ipc_perm)   ; structure describing operation permission
299   (msg_stime   linux:|time_t|)          ; time of last msgsnd command 
300   (__unused1   ffi:ulong)
301   (msg_rtime   linux:|time_t|)          ; time of last msgrcv command 
302   (__unused2   ffi:ulong)
303   (msg_ctime   linux:|time_t|)          ; time of last change
304   (__unused3   ffi:ulong)
305   (msg_cbytes  ffi:ulong)          ;  current number of bytes on queue
306   (msg_qnum    msgqnum_t)      ; number of messages currently on queue
307   (msg_qbytes  msglen_t)        ; max number of bytes allowed on queue
308   (msg_lspid   linux:|pid_t|)           ; pid of last msgsnd()
309   (msg_lrpid   linux:|pid_t|)           ; pid of last msgrcv()
310   (__unused4   ffi:ulong)
311   (__unused5   ffi:ulong))
312
313 ;; ipcs ctl commands
314 (defconstant MSG_STAT 11)
315 (defconstant MSG_INFO 12)
316
317
318 ;; buffer for msgctl calls IPC_INFO, MSG_INFO 
319 (ffi:def-c-struct msginfo
320   (msgpool ffi:int)
321   (msgmap  ffi:int)
322   (msgmax  ffi:int)
323   (msgmnb  ffi:int)
324   (msgmni  ffi:int)
325   (msgssz  ffi:int)
326   (msgtql  ffi:int)
327   (msgseg  ffi:ushort))
328
329
330 (defstruct msgbuf
331   (mtype 0   :type integer)
332   (mtext #() :type (vector (unsigned-byte 8) *)))
333
334
335 (ffi:def-call-out msgget (:name "msgget")
336   (:arguments (key linux:|key_t|) (msgflg ffi:int))
337   (:return-type ffi:int)
338   (:library #.+libc+) (:language :stdc))
339
340
341 (ffi:def-call-out msgctl (:name "msgctl")
342   (:arguments (msqid ffi:int) (cmd ffi:int) (buf pointer))
343   ;; We cannot use (ffi:c-ptr msqid_ds) because in that case
344   ;; it would not be copied back as output parameter.
345   (:return-type ffi:int)
346   (:library #.+libc+) (:language :stdc))
347
348
349 (ffi:def-call-out msgsnd (:name "msgsnd")
350   (:arguments (msqid ffi:int) (msgbuf pointer) (msgsz ffi:size_t)
351               (msgflg ffi:int))
352   (:return-type ffi:int)
353   (:library #.+libc+) (:language :stdc))
354
355
356 (ffi:def-call-out msgrcv (:name "msgrcv")
357   (:arguments (msqid ffi:int) (msgbuf pointer) (msgsz ffi:size_t)
358               (msgtyp ffi:long) (msgflg ffi:int))
359   (:return-type ffi:ssize_t)
360   (:library #.+libc+) (:language :stdc))
361
362
363 ;;----------------------------------------------------------------------
364 ;; shm
365 ;;----------------------------------------------------------------------
366
367
368 ;; Permission flag for shmget. 
369 (defconstant SHM_R #o0400 "or S_IRUGO from <linux/stat.h> *")
370 (defconstant SHM_W #o0200 "or S_IWUGO from <linux/stat.h> *")
371
372 ;; Flags for `shmat'. 
373 (defconstant SHM_RDONLY #o010000 "attach read-only else read-write *")
374 (defconstant SHM_RND    #o020000 "round attach address to SHMLBA *")
375 (defconstant SHM_REMAP  #o040000 "take-over region on attach *")
376
377 ;; Commands for `shmctl'.  
378 (defconstant SHM_LOCK   11 "lock segment (root only) *")
379 (defconstant SHM_UNLOCK 12 "unlock segment (root only) *")
380
381
382 (ffi:def-call-out getpagesize (:name "getpagesize")
383   (:arguments)
384   (:return-type ffi:int)
385   (:library #.+libc+) (:language :stdc))
386
387
388 (defun SHMLBA () 
389   "Segment low boundary address multiple. "
390   (getpagesize))
391
392
393 (ffi:def-c-type shmatt_t ffi:ulong)
394 ;; Type to count number of attaches. 
395
396
397
398 (ffi:def-c-struct shmid_ds
399   ;; Data structure describing a set of semaphores.
400   (shm_perm    ipc_perm)   ; structure describing operation permission
401   (shm_segsz   ffi:size_t)          ;  size of segment in bytes 
402   (shm_atime   linux:|time_t|)          ;  time of last shmat() 
403   (__unused1   ffi:ulong)               ; 
404   (shm_dtime   linux:|time_t|)          ;  time of last shmdt() 
405   (__unused2   ffi:ulong)               ; 
406   (shm_ctime   linux:|time_t|)       ;time of last change by shmctl() 
407   (__unused3   ffi:ulong)               ; 
408   (shm_cpid    linux:|pid_t|)           ;  pid of creator 
409   (shm_lpid    linux:|pid_t|)           ;  pid of last shmop 
410   (shm_nattch  shmatt_t)                ; number of current attaches 
411   (__unused4   ffi:ulong)               ; 
412   (__unused5   ffi:ulong))
413
414 (ffi:def-c-struct shminfo
415   (shmmax     ffi:ulong)
416   (shmmin     ffi:ulong)
417   (shmmni     ffi:ulong)
418   (shmseg     ffi:ulong)
419   (shmall     ffi:ulong)
420   (__unused1  ffi:ulong)
421   (__unused2  ffi:ulong)
422   (__unused3  ffi:ulong)
423   (__unused4  ffi:ulong))
424
425
426 (ffi:def-c-struct shm_info
427   (used_ids ffi:int)                    ; 
428   (shm_tot ffi:ulong)                   ; total allocated shm
429   (shm_rss ffi:ulong)                   ; total resident shm*
430   (shm_swp ffi:ulong)                   ; total swapped shm
431   (swap_attempts ffi:ulong)             ; 
432   (swap_successes ffi:ulong))
433
434
435  
436 (ffi:def-call-out shmget (:name "shmget")
437   ;; Get shared memory segment.
438   (:arguments (key linux:|key_t|) (size ffi:size_t) (shmflg ffi:int))
439   (:return-type ffi:int)
440   (:library #.+libc+) (:language :stdc))
441
442
443 (ffi:def-call-out shmctl (:name "shmctl")
444   ;; Shared memory control operation. 
445   (:arguments (shmid ffi:int) (cmd ffi:int) (buf pointer))
446   (:return-type ffi:int)
447   (:library #.+libc+) (:language :stdc))
448
449
450 (ffi:def-call-out shmat (:name "shmat")
451   ;; Attach shared memory segment. 
452   (:arguments (shmid ffi:int) (shmaddr pointer) (shmflg ffi:int))
453   (:return-type ffi:int)
454   (:library #.+libc+) (:language :stdc))
455
456
457 (ffi:def-call-out shmdt (:name "shmdt")
458   ;; Detach shared memory segment.
459   (:arguments (shmaddr pointer))
460   (:return-type ffi:int)
461   (:library #.+libc+) (:language :stdc))
462
463
464 ;;----------------------------------------------------------------------
465 ;; sem
466 ;;----------------------------------------------------------------------
467
468
469 ;; Flags for `semop'.  
470 (defconstant SEM_UNDO   #x1000 "undo the operation on exit")
471
472 ;; Commands for `semctl'.  
473 (defconstant  GETPID          11 "get sempid")
474 (defconstant  GETVAL          12 "get semval")
475 (defconstant  GETALL          13 "get all semval's")
476 (defconstant  GETNCNT         14 "get semncnt")
477 (defconstant  GETZCNT         15 "get semzcnt")
478 (defconstant  SETVAL          16 "set semval")
479 (defconstant  SETALL          17 "set all semval's")
480
481 (defconstant SEMMNI  128         "<= IPCMNI  max # of semaphore identifiers")
482 (defconstant SEMMSL  250         "<= 8 000 max num of semaphores per id")
483 (defconstant SEMMNS  32000 #|(* SEMMNI SEMMSL)|#
484   "<= INT_MAX max # of semaphores in system")
485 (defconstant SEMOPM  32          "<= 1 000 max num of ops per semop call")
486 (defconstant SEMVMX  32767       "<= 32767 semaphore maximum value")
487 (defconstant SEMAEM  32767 #|SEMVMX|#   "adjust on exit max value")
488
489
490 (ffi:def-c-struct semid_ds
491   ;; Data structure describing a set of semaphores.  
492   (sem_perm ipc_perm)                   ; operation permission struct 
493   (sem_otime linux:|time_t|)            ; last semop() time 
494   (__unused1 ffi:ulong)
495   (sem_ctime linux:|time_t|)          ; last time changed by semctl() 
496   (__unused2 ffi:ulong)
497   (sem_nsems ffi:ulong)                 ; number of semaphores in set 
498   (__unused3 ffi:ulong)
499   (__unused4 ffi:ulong))
500
501
502 ;;    The user should define a union like the following to use it for arguments
503 ;;    for `semctl'.
504 ;; 
505 ;;    union semun
506 ;;    {
507 ;;      int val;                           <= value for SETVAL
508 ;;      struct semid_ds *buf;              <= buffer for IPC_STAT & IPC_SET
509 ;;      unsigned short int *array;         <= array for GETALL & SETALL
510 ;;      struct seminfo *__buf;             <= buffer for IPC_INFO
511 ;;    };
512 ;; 
513 ;;    Previous versions of this file used to define this union but this is
514 ;;    incorrect.  One can test the macro _SEM_SEMUN_UNDEFINED to see whether
515 ;;    one must define the union or not.  
516
517 ;; ipcs ctl cmds 
518 (defconstant SEM_STAT 18)
519 (defconstant SEM_INFO 19)
520
521 (ffi:def-c-struct seminfo
522   (semmap ffi:int)
523   (semmni ffi:int)
524   (semmns ffi:int)
525   (semmnu ffi:int)
526   (semmsl ffi:int)
527   (semopm ffi:int)
528   (semume ffi:int)
529   (semusz ffi:int)
530   (semvmx ffi:int)
531   (semaem ffi:int))
532
533
534
535 (ffi:def-c-struct sembuf
536   ;; Structure used for argument to `semop' to describe operations. 
537   (sem_num ffi:ushort)                  ; semaphore number 
538   (sem_op ffi:short)                    ; semaphore operation 
539   (sem_flg ffi:short)                   ; operation flag
540   )
541
542
543 (ffi:def-call-out semget (:name "semget")
544   ;; Get semaphore. 
545   (:arguments (key linux:|key_t|) (nsems ffi:int) (semflg ffi:int))
546   (:return-type ffi:int)
547   (:library #.+libc+) (:language :stdc))
548
549
550 (ffi:def-call-out semctl (:name "semctl")
551   ;; Semaphore control operation.
552   (:arguments (semid ffi:int) (semnum ffi:int) (cmt ffi:int) (arg pointer))
553   (:return-type ffi:int)
554   (:library #.+libc+) (:language :stdc))
555
556
557 (ffi:def-call-out semop (:name "semop")
558   ;; Operate on semaphore. 
559   (:arguments (semid ffi:int) (sops pointer) (nsops ffi:size_t))
560   (:return-type ffi:int)
561   (:library #.+libc+) (:language :stdc))
562
563
564 ;;;; THE END ;;;;