← Back to branch summary

~ubuntu-branches/debian/squeeze/cmucl/squeeze

« back to all changes in this revision

Viewing changes to src/code/unix-glibc2.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2009-02-18 05:50:05 UTC
  • mfrom: (0.2.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20090218055005-kt6ookdcasemovhl
Tags: 19e-20080501-2
* fix brown bag bug: use cmucl in script, not lisp
* New version should Fixes: #483331 because of asm change

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/code/unix-glibc2.lisp
5
5
;;; Carnegie Mellon University, and has been placed in the public domain.
6
6
;;;
7
7
(ext:file-comment
8
 
  "$Header: /project/cmucl/cvsroot/src/code/unix-glibc2.lisp,v 1.36 2005/10/10 20:31:13 rtoy Exp $")
 
8
  "$Header: /project/cmucl/cvsroot/src/code/unix-glibc2.lisp,v 1.43 2007/11/14 17:20:46 rtoy Exp $")
9
9
;;;
10
10
;;; **********************************************************************
11
11
;;;
81
81
          prot_read prot_write prot_exec prot_none
82
82
          map_shared map_private map_fixed map_anonymous
83
83
          ms_async ms_sync ms_invalidate
84
 
          unix-mmap unix-munmap unix-msync
 
84
          unix-mmap unix-munmap unix-msync unix-mprotect
85
85
          unix-pathname unix-file-mode unix-fd unix-pid unix-uid unix-gid
86
86
          unix-setitimer unix-getitimer
87
87
          unix-access r_ok w_ok x_ok f_ok unix-chdir unix-chmod setuidexec
245
245
(defconstant ms_sync 4)
246
246
(defconstant ms_invalidate 2)
247
247
 
 
248
;; The return value from mmap that means mmap failed.
 
249
(defconstant map_failed (int-sap (1- (ash 1 vm:word-bits))))
 
250
 
248
251
(defun unix-mmap (addr length prot flags fd offset)
249
252
  (declare (type (or null system-area-pointer) addr)
250
253
           (type (unsigned-byte 32) length)
252
255
           (type (unsigned-byte 32) flags)
253
256
           (type (or null unix-fd) fd)
254
257
           (type (signed-byte 32) offset))
255
 
  (syscall ("mmap" system-area-pointer size-t int int int off-t)
256
 
           (sys:int-sap result)
257
 
           (or addr +null+) length prot flags (or fd -1) offset))
 
258
  ;; Can't use syscall, because the address that is returned could be
 
259
  ;; "negative".  Hence we explicitly check for mmap returning
 
260
  ;; MAP_FAILED.
 
261
  (let ((result
 
262
         (alien-funcall (extern-alien "mmap" (function system-area-pointer
 
263
                                                       system-area-pointer
 
264
                                                       size-t int int int off-t))
 
265
                        (or addr +null+) length prot flags (or fd -1) offset)))
 
266
    (if (sap= result map_failed)
 
267
        (values nil (unix-errno))
 
268
        (values result 0))))
258
269
 
259
270
(defun unix-munmap (addr length)
260
271
  (declare (type system-area-pointer addr)
267
278
           (type (signed-byte 32) flags))
268
279
  (syscall ("msync" system-area-pointer size-t int) t addr length flags))
269
280
 
 
281
(defun unix-mprotect (addr length prot)
 
282
  (declare (type system-area-pointer addr)
 
283
           (type (unsigned-byte 32) length)
 
284
           (type (integer 1 7) prot))
 
285
  (syscall ("mprotect" system-area-pointer size-t int)
 
286
           t addr length prot))
 
287
  
270
288
;;;; Lisp types used by syscalls.
271
289
 
272
290
(deftype unix-pathname () 'simple-string)
314
332
 
315
333
 
316
334
;;;; System calls.
317
 
(def-alien-variable ("errno" unix-internal-errno) int)
318
 
 
319
 
;;; later...
320
 
(defun unix-get-errno ())
321
 
 
322
 
(defun unix-errno () (unix-get-errno) unix-internal-errno)
323
 
(defun (setf unix-errno) (newvalue) (setf unix-internal-errno newvalue))
 
335
 
 
336
(def-alien-routine ("os_get_errno" unix-get-errno) int)
 
337
(def-alien-routine ("os_set_errno" unix-set-errno) int (newvalue int))
 
338
(defun unix-errno () (unix-get-errno))
 
339
(defun (setf unix-errno) (newvalue) (unix-set-errno newvalue))
324
340
 
325
341
;;; GET-UNIX-ERROR-MSG -- public.
326
342
;;; 
334
350
      (format nil "Unknown error [~d]" error-number)))
335
351
 
336
352
(defmacro syscall ((name &rest arg-types) success-form &rest args)
337
 
  `(locally
338
 
    (declare (optimize (ext::float-accuracy 0)))
339
 
    (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
340
 
                                 ,@args)))
341
 
      (if (minusp result)
342
 
          (values nil (unix-errno))
343
 
          ,success-form))))
 
353
  `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
 
354
                                ,@args)))
 
355
     (if (minusp result)
 
356
         (values nil (unix-errno))
 
357
         ,success-form)))
344
358
 
345
359
;;; Like syscall, but if it fails, signal an error instead of returning error
346
360
;;; codes.  Should only be used for syscalls that will never really get an
347
361
;;; error.
348
362
;;;
349
363
(defmacro syscall* ((name &rest arg-types) success-form &rest args)
350
 
  `(locally
351
 
    (declare (optimize (ext::float-accuracy 0)))
352
 
    (let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
353
 
                                 ,@args)))
354
 
      (if (minusp result)
355
 
          (error "Syscall ~A failed: ~A" ,name (get-unix-error-msg))
356
 
          ,success-form))))
 
364
  `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
 
365
                                ,@args)))
 
366
     (if (minusp result)
 
367
         (error "Syscall ~A failed: ~A" ,name (get-unix-error-msg))
 
368
         ,success-form)))
357
369
 
358
370
(defmacro void-syscall ((name &rest arg-types) &rest args)
359
371
  `(syscall (,name ,@arg-types) (values t 0) ,@args))
361
373
(defmacro int-syscall ((name &rest arg-types) &rest args)
362
374
  `(syscall (,name ,@arg-types) (values result 0) ,@args))
363
375
 
364
 
(defun unix-get-errno ()
365
 
  "Get the unix errno value in errno..."
366
 
  (void-syscall ("update_errno")))
367
376
;;; From stdio.h
368
377
 
369
378
;;; Unix-rename accepts two files names and renames the first to the second.
2463
2472
   information."
2464
2473
  (declare (type unix-fd fd)
2465
2474
           (type (unsigned-byte 32) cmd))
2466
 
  (void-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
 
2475
  (int-syscall ("ioctl" int unsigned-int (* char)) fd cmd arg))
2467
2476
 
2468
2477
 
2469
2478
;;; sys/fsuid.h