anchor.diff:          (repoid (marshal-string-record repoid buffer))))
   
   
  +(defun all-member-types (tc)
  +  (and tc
  +       (with-cache-slot (tc all-member-types)
  +         (append (all-member-types (op:concrete_base_type tc))
  +                 (tc-member-types tc)))))
  +
  +(defun all-feature-symbols (tc)
  +  (and tc
  +       (with-cache-slot (tc all-feature-symbols)
  +         (append (all-feature-symbols (op:concrete_base_type tc))
  +                 (tc-feature-symbols tc)))))
  +
  +(defun all-feature-values (tc value)
  +  (loop for feature in (all-feature-symbols tc) 
  +        collect (slot-value value feature)))
  +
  +
  +(defun marshal-value-state (chunking values types buffer)
  +  (cond (chunking
  +         (let ((*chunking-level* (1+ *chunking-level*))
  +               (*chunk-start* nil))
  +           (let ((*chunk-tail* nil))
  +             (loop for (val . more) on values and tc in types
  +                   do (setq *chunk-tail* (not more))
  +                   (unless *chunk-start* (start-chunk buffer))
  +                   (marshal val tc buffer)))
  +           (end-chunk buffer)
  +           (unless *chunk-tail*       ; end-tag, unless in tail of enclosing value
  +             (marshal-long (- *chunking-level*) buffer))))
  +        (t
  +         (marshal-multiple values types buffer))))
  +
  +
  +(defun marshal-value (value buffer &optional expected-id)
  +  (flet ((marshal-value-1 (value buffer)
  +           (let ((id (object-id value)))
  +             (let ((exact-type (equal id expected-id))
  +                   (value-class (ifr-id-symbol id)))
  +               (assert value-class)
  +               (let ((tc (symbol-typecode value-class)))
  +                 (let ((truncatable (and (not exact-type)
  +                                         (eql corba:vm_truncatable (op:type_modifier tc)))))
  +                   (let ((chunking (or truncatable (> *chunking-level* 0)))
  +                         (repoid (cond (truncatable (truncatable-interfaces tc))
  +                                       ((not exact-type) id))))
  +                     (marshal-value-header repoid chunking buffer)
  +                     (marshal-value-state chunking 
  +                                          (all-feature-values tc value)
  +                                          (all-member-types tc)
  +                                          buffer))))))))
  +    (marshal-record value #'marshal-value-1 buffer)))
  +
  +
   (defmethod marshal (value (tc-formal value-typecode) buffer)
  -  (flet ((marshal-value (value buffer)
  -           (let* ((id (object-id value))
  -                  (exact-type (equal id (op:id tc-formal)))
  -                  (value-class (ifr-id-symbol id))
  -                  tc)
  -             (assert value-class)
  -             (setq tc (if exact-type tc-formal (symbol-typecode value-class)))
  -             (let ((truncatable (and (not exact-type)
  -                                     (eql corba:vm_truncatable (op:type_modifier tc)))))
  -               (let ((chunking (or truncatable (> *chunking-level* 0)))
  -                     (repoid (cond (truncatable (truncatable-interfaces tc))
  -                                   ((not exact-type) id))))
  -                 (marshal-value-header repoid chunking buffer)
  -                 (do ((this   (op:concrete_base_type tc)
  -                              (op:concrete_base_type this))
  -                      (types  (tc-member-types tc)
  -                              (append (tc-member-types this) types))
  -                      (values (tc-feature-values tc value)
  -                              (nconc (tc-feature-values this value) values)))
  -                     ((null this)
  -                      (marshal-value-state chunking values types buffer))))))))
  -    (marshal-record value #'marshal-value buffer)))
  -
  -
  -(defvar *chunk-start*)
  -
  -
  -(defun tc-feature-values (tc value)
  -  (loop for feature in (tc-feature-symbols tc)
  -        collect (slot-value value feature)))
  -
  -
  -(defun marshal-value-state (chunking values types buffer)
  -  (flet ((chunk-marshal (v tc buffer)
  -           (let ((new-value (and (typep v 'CORBA::ValueBase)
  -                                 (not (gethash v (buffer-record buffer))))))
  -             (cond ((and new-value *chunk-start*)
  -                    (end-chunk buffer))
  -                   ((and (not *chunk-start*) (not new-value))
  -                    (start-chunk buffer)))
  -             (marshal v tc buffer))))
  -    (cond (chunking
  -           (let ((*chunking-level* (1+ *chunking-level*))
  -                 (*chunk-start* nil))
  -             (let ((*chunk-tail* nil))
  -               (loop for (val . more) on values and tc in types
  -                     do (setq *chunk-tail* (not more))
  -                     (chunk-marshal val tc buffer)))
  -             (when *chunk-start* (end-chunk buffer))
  -             (unless *chunk-tail*
  -               (marshal-long (- *chunking-level*) buffer))))
  -          (t
  -           (marshal-multiple values types buffer)))))
  -
  -
  -(defun start-chunk (buffer)
  -  (with-out-buffer (buffer)
  -    (align 4)
  -    (setq *chunk-start* pos)
  -    (incf pos 4)))
  -
  -(defun end-chunk (buffer)
  -  (when *chunk-start*
  -    (with-out-buffer (buffer)
  -      (let ((old-pos pos))
  -        (setf pos *chunk-start*)
  -        (marshal-long (- old-pos pos 4) buffer)
  -        (setf pos old-pos)))
  -    (setf *chunk-start* nil)))
  -
  +  (marshal-value value buffer (op:id tc-formal)))
   
   
   
  
positive.code:         (if chunking-p (find-end-of-value))))))
  
  
  (defun unmarshal-value (buffer &optional expected-id)
    (unmarshal-record
     (lambda (buffer) 
       (without-chunking (buffer)
         (let ((valuetag (unmarshal-long buffer)))
           (unless (zerop valuetag)
             (unmarshal-value-1 valuetag buffer expected-id)))))
     buffer))
  
  (defun unmarshal-value-1 (valuetag buffer expected-id)
    (multiple-value-bind (chunked repoid)
                         (unmarshal-value-header valuetag buffer)
      (let (tc symbol truncate)
        (unless repoid
          (setq repoid expected-id))
  
negative.code:             (apply #'make-instance (or (ifr-id-symbol (op:id tc)) 'value-box)
                     initargs))
             (t (second initargs))))))
     buffer :chunk-tag))
  
  
  
  ;;;; AbstractInterface
  
  
  (define-typecode abstract_interface-typecode
    :kind :tk_abstract_interface
    :cdr-syntax (complex :tk_string :tk_string)
    :params (id name)
    :share named-typecode :shared-params 2)
  
  
  (defmacro define-abstract-interface (symbol super &key (id "") proxy (name "") mixin)
    `(progn
       (set-symbol-id/typecode ',symbol ,id (create-abstract-interface-tc ,id ,name))
       (setf (get ',symbol 'ifr-bases) ',super)
       (defclass ,mixin () ())
       (defclass ,symbol (,mixin ,@super) ())
       ,@(if proxy
           `((defclass ,(car proxy) (,mixin ,@(cdr proxy)) ())
             (register-proxy-class ,id ',(car proxy))))
       (defmethod object-id ((obj ,mixin))
         ,id)
       (defmethod object-is-a or ((obj ,mixin) interface-id)
         (string= interface-id ,id))))
    
  
  (defmethod marshal (obj (tc abstract_interface-typecode) buffer)
    (assert (or (null obj) (op:_is_a obj (op:id tc))))
    (etypecase obj
      (CORBA:Proxy
       (marshal-bool t buffer)
       (marshal-object obj buffer))
      ((or NULL CORBA:ValueBase)
       (marshal-bool nil buffer)
       (marshal-value obj buffer))
      ;; this is doubtful as the spec says requires that
      ;; "the object is already registered with the ORB/OA"
      (CORBA:Object
       (marshal-bool t buffer)
       (marshal-object obj buffer))))
  
  
  (defmethod unmarshal ((tc abstract_interface-typecode) buffer)
    (let ((case-label (unmarshal-bool buffer)))
      (if case-label
        (unmarshal-object buffer (op:id tc))
        (unmarshal-value buffer))))
  