anchor.diff:  ;;;; Marshal
   
   (in-package :clorb)
  +
  +
  +;;; should be in buffer:
  +
  +(defmacro with-out-buffer ((buffer &key (resize 400)) &body body)
  +  "Open upp buffer.
  +In body: 
  +- buffer     the buffer,
  +- octets     the octet vector,
  +- start-pos  start pos in octets for this work,
  +- pos        current pos in octets (setf-able),
  +- (align n)  align output to n octets (n must be litteral),
  +- (put-octet n)  output octet n. "
  +  `(let* ((buffer ,buffer)
  +          (start-pos (buffer-start-pos buffer))
  +          (octets (buffer-octets buffer)))
  +     (declare (ignorable start-pos octets)
  +              (type buffer-index start-pos))
  +     (macrolet ((put-octet (n)
  +                  `(vector-push-extend ,n octets ,',resize))
  +                (align (n) 
  +                  `(let ((skip (- ,n (logand (the buffer-index (- (fill-pointer octets) start-pos))
  +                                             (- ,n 1)))))
  +                     (declare (fixnum skip))
  +                     (when (< skip ,n)
  +                       (dotimes (x skip)
  +                         (declare (fixnum x))
  +                         (vector-push-extend 0 octets ,',resize))))))
  +       (symbol-macrolet ((pos (fill-pointer octets)))
  +         ,@body))))
  +
  +(defun buffer-pos (buffer)
  +  (fill-pointer (buffer-octets buffer)))
  +
  +
   
   (defun marshal-octet (n buffer)
     (declare (type buffer buffer)
              (optimize (speed 3) (debug 0)))
  -  (vector-push-extend n (buffer-octets buffer) 400))
  +  (with-out-buffer (buffer) (put-octet n)))
   
   (defun marshal-bool (s buffer)
     (marshal-octet (if s 1 0) buffer))
   
  -(defun marshal-align (n buffer)
  -  (declare (type buffer buffer)
  -           (type (integer 0 8) n)
  -           (optimize (speed 3) (safety 1) (debug 0)))
  -  (let* ((octets (buffer-octets buffer))
  -         (start-pos (buffer-start-pos buffer))
  -         (skip (- n (logand (- (the buffer-index (fill-pointer octets))
  -                               start-pos) 
  -                            (- n 1)))))
  -    (when (< skip n)
  -      (dotimes (x skip)
  -        (declare (type (integer 0 8) x))
  -        (vector-push-extend 0 octets) ))))
  -
  -#-clisp
  -(defun marshal-number (n size buffer &optional (align size))
  -  (declare (fixnum size)
  -           (integer n)
  -           (optimize (speed 3) (debug 0) (safety 1)))
  -  (marshal-align align buffer)
  -  (loop for p from 0 by 8
  -	for c fixnum below size
  -	do (marshal-octet (ldb (byte 8 p) n) buffer)))
  -
  -;;
  -(#-clisp define-compiler-macro #+clisp defmacro
  -         marshal-number (&whole form n size buffer &optional (align size))
  -  (if (numberp size)
  -      (let ((nvar '#:nvar)
  -            (nnvar '#:nnvar)
  -            (bvar '#:bvar))
  -        `(let* (,@(if (> size 3) 
  -                      `((,nnvar ,n) 
  -                        (,nvar (logand ,nnvar #16rffffff)))
  -                      `((,nvar ,n)))
  -                (,bvar ,buffer))
  -          ,@(if (> size 3)
  -                `((declare (type (integer 0 #16rFFFFFF) ,nvar))))
  -          (marshal-align ,align ,bvar)
  -          (marshal-octet (logand #16rff ,nvar) ,bvar)
  -          ,@(loop for p from 8 by 8
  -                  for c from 1 below size
  -                  collect `(marshal-octet (ldb (byte 8 ,p) 
  -                                           ,(if (>= c 3) nnvar nvar)) 
  -                            ,bvar))))
  -      form))
  +
  +(defmacro %marshal-number (n size buffer &optional (align size))
  +  (let ((nvar '#:nvar)
  +        (nnvar '#:nnvar))
  +    `(with-out-buffer (,buffer)
  +       (let* (,@(if (> size 3) 
  +                  `((,nnvar ,n) 
  +                    (,nvar (logand ,nnvar #xFFFFFF)))
  +                  `((,nvar ,n))))
  +         (declare (type (integer #x-FFFFFF #xFFFFFF) ,nvar))
  +         (align ,align)
  +         (put-octet (logand #xFF ,nvar))
  +         ,@(loop for p from 8 by 8
  +                 for c from 1 below size
  +                 collect `(put-octet (ldb (byte 8 ,p) 
  +                                          ,(if (>= c 3) nnvar nvar))))))))
  +
   
   (defun marshal-short (n buffer)
  -  (declare (type (or CORBA:ushort CORBA:short) n)
  +  (declare (type CORBA:short n)
              (optimize speed))
  -  (marshal-number n 2 buffer))
  +  (%marshal-number n 2 buffer))
   
   (defun marshal-ushort (n buffer)
     (declare (type (or CORBA:ushort CORBA:short) n)
              (optimize speed))
  -  (marshal-number n 2 buffer))
  +  (%marshal-number n 2 buffer))
   
   (defun marshal-ulong (n buffer)
     (declare (type CORBA:ulong n)
              (optimize speed))
  -  (marshal-number n 4 buffer))
  +  (%marshal-number n 4 buffer))
   
   (defun marshal-long (n buffer)
     (declare (type CORBA:long n)
              (optimize speed))
  -  (marshal-number n 4 buffer))
  +  (%marshal-number n 4 buffer))
  +
  +(defun marshal-longlong (arg buffer)
  +  (%marshal-number arg 8 buffer))
  +
  +(defun marshal-ulonglong (arg buffer)
  +  (%marshal-number arg 8 buffer))
  +
  +(defun marshal-char (char buffer)
  +  (marshal-octet (char-code char) buffer))
   
   (defun float-as-ieee-integer (number sign-bit fraction-bits bias)
     (multiple-value-bind (frac expn sign)
  
positive.code:                  buffer))
  
  (defun marshal-double (arg buffer)
    (marshal-number (float-as-ieee-integer (coerce arg 'corba:double)
                                           63 52 1023)
                    8 buffer))
  
  (defun marshal-longdouble (arg buffer)
    (marshal-number (float-as-ieee-integer (coerce arg 'corba:longdouble)
                                           127 112 16383)
                    16 buffer 8))
  
  
negative.code: 
  (defun marshal-typecode (tc buffer)
    (let ((recursive-typecode-pos
           (cdr (assoc tc *marshal-typecode-record*))))
      (cond
       (recursive-typecode-pos
        (marshal-ulong #xFFFFFFFF buffer)
        (marshal-long (- recursive-typecode-pos (buffer-pos buffer))
                      buffer))
       (t
        (let ((*marshal-typecode-record*
               (acons tc (buffer-pos buffer)
                      *marshal-typecode-record*))
              (kind (typecode-kind tc))
              (*typecode-params* (typecode-params tc)))
  