guile-hurd/mach/msg-header.scm

(define-module (mach msg-header)
  #:export (make-msg-header msg-header?
            msg-header:bits set-msg-header:bits!
            msg-header:size set-msg-header:size!
            msg-header:remote-port set-msg-header:remote-port!
            msg-header:local-port set-msg-header:local-port!
            msg-header:seqno set-msg-header:seqno!
            msg-header:id set-msg-header:id!
            ffi:msg-header %msg-header-size
            %read-message-header %write-message-header!)
  #:use-module (mach types)
  #:use-module (srfi srfi-60)
  #:use-module (srfi srfi-9)
  #:use-module (rnrs bytevectors)
  #:use-module ((system foreign)
                #:select (parse-c-struct make-c-struct sizeof
                          pointer->bytevector bytevector->pointer))
  #:use-module ((rnrs base) #:select (assert)))

;; Different masks to the message header.
(define %msgh-bits-zero #x00000000)
(define %msgh-bits-remote-mask #x000000ff)
(define %msgh-bits-local-mask #x0000ff00)
(define %msgh-bits-complex #x80000000)
(define %msgh-bits-unused #x07ff0000)
(define %msgh-bits-ports-mask
        (bitwise-ior %msgh-bits-remote-mask %msgh-bits-local-mask))

;; The message header structure as in C.
(define ffi:msg-header
  (map cdr
      `((bits ,ffi:msg-bits)
        (size ,ffi:msg-size)
        (remote-port ,ffi:mach-port)
        (local-port ,ffi:mach-port)
        ;; XXX shouldn't this be ffi:msg-seqno?
        (seqno ,ffi:port-seqno)
        (id ,ffi:msg-id))))

(define %msg-header-size (sizeof ffi:msg-header))
;; Be really sure.
(assert (= 24 %msg-header-size))

;; The Scheme equivalent.
;; TODO: maybe do some type checking in the constructor?
(define-record-type <msg-header>
  (make-msg-header bits size remote-port local-port seqno id)
  msg-header?
  ;; (integer)
  (bits msg-header:bits set-msg-header:bits!)
  ;; sie of message (integer)
  (size msg-header:size set-msg-header:size!)
  ;; a <mach-port> (the ‘header remote port’)
  (remote-port msg-header:remote-port set-msg-header:remote-port!!)
  ;; a <mach-port> (tehe ‘header local port’)
  (local-port msg-header:local-port set-msg-header:local-port!)
  ;; (integer)
  (seqno msg-header:seqno set-msg-header:seqno!)
  ;; Message ID (integer)
  (id msg-header:id set-msg-header:id!))

(define (%read-message-header pointer)
  "Read a message header structure (as in C) from @var{pointer},
and return it as a @code{<msg-header>}."
  (apply (lambda (bits size remote-port local-port seqno id)
           (make-msg-header bits size (%wrap-mach-port remote-port)
                            (%wrap-mach-port local-port) seqno id))
         (parse-c-struct ffi:msg-header pointer)))

(define (%write-message-header! pointer header)
  "Write a message header @var{header} to @var{pointer}."
  (let* ((p (make-c-struct ffi:msg-header
                           (list (msg-header:bits header)
                                 (msg-header:size header)
                                 (%unwrap-mach-port (msg-header:remote-port header))
                                 (%unwrap-mach-port (msg-header:local-port header))
                                 (msg-header:seqno header)
                                 (msg-header:id header))))
         (b (pointer->bytevector p %msg-header-size))
         (b/pointer (bytevector->pointer pointer %msg-header-size)))
    (bytevector-copy! b b/pointer 0 0 %msg-header-size)))

;; XXX what is type-name?
#;
(define (msgh-bits-remote type-name)
  "Same thing as MACH_MSGH_BITS_LOCAL."
  (bitwise-and %msgh-bits-remote-mask
               (translate-msg-type-name-symbol type-name)))

#;
(define (msgh-bits-local type-name)
  "Same thing as MACH_MSGH_BITS_LOCAL."
  (ash (bitwise-and %msgh-bits-local-mask
                   (translate-msg-type-name-symbol type-name))
       -8))
#;
(define (msgh-bits remote local)
  "Same thing as MACH_MSGH_BITS."
  (bitwise-or (msgh-bits-remote remote)
              (ash (msgh-bits-local local) 8)))