- (remaining (segment-annotations segment) next)
- (next (cdr remaining) (cdr remaining)))
- ((null remaining))
- (let* ((note (car remaining))
- (posn (annotation-posn note)))
- (unless (zerop delta)
- (decf posn delta)
- (setf (annotation-posn note) posn))
- (cond
- ((chooser-p note)
- (setf (segment-current-index segment) (chooser-index note))
- (setf (segment-current-posn segment) posn)
- (setf (segment-last-annotation segment) prev)
- (cond
- ((funcall (chooser-maybe-shrink note) segment posn delta)
- ;; It emitted some replacement.
- (let ((new-size (- (segment-current-index segment)
- (chooser-index note)))
- (old-size (chooser-size note)))
- (when (> new-size old-size)
- (error "~S emitted ~D bytes, but claimed its max was ~D."
- note new-size old-size))
- (let ((additional-delta (- old-size new-size)))
- (when (< (find-alignment additional-delta)
- (chooser-alignment note))
- (error "~S shrunk by ~D bytes, but claimed that it ~
- preserve ~D bits of alignment."
- note additional-delta (chooser-alignment note)))
- (incf delta additional-delta)
- (emit-filler segment additional-delta))
- (setf prev (segment-last-annotation segment))
- (if prev
- (setf (cdr prev) (cdr remaining))
- (setf (segment-annotations segment)
- (cdr remaining)))))
- (t
- ;; The chooser passed on shrinking. Make sure it didn't emit
- ;; anything.
- (unless (= (segment-current-index segment) (chooser-index note))
- (error "Chooser ~S passed, but not before emitting ~D bytes."
- note
- (- (segment-current-index segment)
- (chooser-index note))))
- ;; Act like we just emitted this chooser.
- (let ((size (chooser-size note)))
- (incf (segment-current-index segment) size)
- (incf (segment-current-posn segment) size))
- ;; Adjust the alignment accordingly.
- (adjust-alignment-after-chooser segment note)
- ;; And keep this chooser for next time around.
- (setf prev remaining))))
- ((alignment-p note)
- (unless (zerop (alignment-size note))
- ;; Re-emit the alignment, letting it collapse if we know
- ;; anything more about the alignment guarantees of the
- ;; segment.
- (let ((index (alignment-index note)))
- (setf (segment-current-index segment) index)
- (setf (segment-current-posn segment) posn)
- (setf (segment-last-annotation segment) prev)
- (emit-alignment segment nil (alignment-bits note)
- (alignment-fill-byte note))
- (let* ((new-index (segment-current-index segment))
- (size (- new-index index))
- (old-size (alignment-size note))
- (additional-delta (- old-size size)))
- (when (minusp additional-delta)
- (error "Alignment ~S needs more space now? It was ~D, ~
- and is ~D now."
- note old-size size))
- (when (plusp additional-delta)
- (emit-filler segment additional-delta)
- (incf delta additional-delta)))
- (setf prev (segment-last-annotation segment))
- (if prev
- (setf (cdr prev) (cdr remaining))
- (setf (segment-annotations segment)
- (cdr remaining))))))
- (t
- (setf prev remaining)))))
+ (remaining (segment-annotations segment) next)
+ (next (cdr remaining) (cdr remaining)))
+ ((null remaining))
+ (let* ((note (car remaining))
+ (posn (annotation-posn note)))
+ (unless (zerop delta)
+ (decf posn delta)
+ (setf (annotation-posn note) posn))
+ (cond
+ ((chooser-p note)
+ (with-modified-segment-index-and-posn (segment (chooser-index note)
+ posn)
+ (setf (segment-last-annotation segment) prev)
+ (cond
+ ((funcall (chooser-maybe-shrink note) segment posn delta)
+ ;; It emitted some replacement.
+ (let ((new-size (- (segment-current-index segment)
+ (chooser-index note)))
+ (old-size (chooser-size note)))
+ (when (> new-size old-size)
+ (error "~S emitted ~W bytes, but claimed its max was ~W."
+ note new-size old-size))
+ (let ((additional-delta (- old-size new-size)))
+ (when (< (find-alignment additional-delta)
+ (chooser-alignment note))
+ (error "~S shrunk by ~W bytes, but claimed that it ~
+ preserves ~W bits of alignment."
+ note additional-delta (chooser-alignment note)))
+ (incf delta additional-delta)
+ (emit-filler segment additional-delta))
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-annotations segment)
+ (cdr remaining)))))
+ (t
+ ;; The chooser passed on shrinking. Make sure it didn't
+ ;; emit anything.
+ (unless (= (segment-current-index segment)
+ (chooser-index note))
+ (error "Chooser ~S passed, but not before emitting ~W bytes."
+ note
+ (- (segment-current-index segment)
+ (chooser-index note))))
+ ;; Act like we just emitted this chooser.
+ (let ((size (chooser-size note)))
+ (incf (segment-current-index segment) size)
+ (incf (segment-current-posn segment) size))
+ ;; Adjust the alignment accordingly.
+ (adjust-alignment-after-chooser segment note)
+ ;; And keep this chooser for next time around.
+ (setf prev remaining)))))
+ ((alignment-p note)
+ (unless (zerop (alignment-size note))
+ ;; Re-emit the alignment, letting it collapse if we know
+ ;; anything more about the alignment guarantees of the
+ ;; segment.
+ (let ((index (alignment-index note)))
+ (with-modified-segment-index-and-posn (segment index posn)
+ (setf (segment-last-annotation segment) prev)
+ (emit-alignment segment nil (alignment-bits note)
+ (alignment-fill-byte note))
+ (let* ((new-index (segment-current-index segment))
+ (size (- new-index index))
+ (old-size (alignment-size note))
+ (additional-delta (- old-size size)))
+ (when (minusp additional-delta)
+ (error "Alignment ~S needs more space now? It was ~W, ~
+ and is ~W now."
+ note old-size size))
+ (when (plusp additional-delta)
+ (emit-filler segment additional-delta)
+ (incf delta additional-delta)))
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-annotations segment)
+ (cdr remaining)))))))
+ (t
+ (setf prev remaining)))))