(herald (assembler fg t 45))

(define-structure-type fg
  type vars
  (;handler
   ((pretty-print self stream)
    (pretty-print-fg self stream))
   ((print self stream)
    (format stream
            "#{Field-group~_~s~_~s}"
            (fg-type-id (fg-type self))
            (object-hash self)))))

(define-structure-type fg-type
  id                        ; for debugging
  constructor
  printer 
  ops 
  vals 
  context 
  first-parameter-index     ; so we can find the args passes to an FG
  contextifiers
  fixed-forces
  subfield-forces
  data?                     ; currently unused, for peephole optimizer
  (;handler
   ((print self stream)
    (format stream
            "#{Field-group-type~_~s~_~s}"
            (fg-type-id self)
            (object-hash self))))
  )

(define (pretty-print-fg fg stream)
  ((fg-type-printer (fg-type fg)) (fg-vars fg) stream))

(define (cons-fg t v)
  (let ((fg (make-fg)))
    (set (fg-type fg) t)
    (set (fg-vars fg) v)
    fg
    ))

(define (cons-fg-type id p o v c fpi cs ff sf)
  (let ((fgt (make-fg-type)))
    (set (fg-type-id fgt) id)
    (set (fg-type-printer fgt) p)
    (set (fg-type-ops fgt) o)
    (set (fg-type-vals fgt) v)
    (set (fg-type-context fgt) c)
    (set (fg-type-first-parameter-index fgt) fpi)        
    (set (fg-type-contextifiers fgt) cs)
    (set (fg-type-fixed-forces fgt) ff)
    (set (fg-type-subfield-forces fgt) sf)
    fgt
    ))

(define-integrable (fg-argref fg n)
  (vref (fg-vars fg) (fx+ n (fg-type-first-parameter-index (fg-type fg)))))
                                                        
(define (make-fg-predicator type)
  (lambda (x) (and (fg? x) (eq? (fg-type x) type))))

(define (data-fg? fg)
  (and (fg? fg) (fg-type-data? (fg-type fg))))

;;; ----------------------------------------------------------------
;;; Solidification - convert early expressions into values
;;;   and propagate context values through the subfields

(define (solidify-fg fg)
  (let* ((fgt (fg-type fg))
         (vars (fg-vars fg))
         (vals (fg-type-vals fgt)))
    (apply-forces (fg-type-subfield-forces fgt) vars vals)
    (apply-contexts (fg-type-contextifiers fgt) vars vals)
    (walk (lambda (item)
            (let ((i (if (pair? item) (cdr item) item)))
              (solidify-fg (vref vars i))))
          (fg-type-subfield-forces fgt))
    (apply-forces (fg-type-fixed-forces fgt) vars vals)))

;;; FORCES is a list of items of the form 
;;;     ( <source-expr-in-vals> . <dest-slot-in-vars> )
;;; (there may be elements in the list that are not pairs --
;;;  they are not forces)

(define (apply-forces forces vars vals)
  (do ((fs forces (cdr fs)))
      ((null? fs) 'done)
    (let ((f (car fs)))
      (if (pair? f) (vset vars (cdr f) ((vref vals (car f)) vars))))))

;;; CONTEXTS is a lits of items of the form
;;;   #(fg-index pos-in-vars vop voc)

(define-integrable (contextifier-fg-i   c) (vref c 0))
(define-integrable (contextifier-dest-i c) (vref c 1))
(define-integrable (contextifier-vop    c) (vref c 2))
(define-integrable (contextifier-voc    c) (vref c 3))

(define (apply-contexts contexts vars vals)
  (do ((cs contexts (cdr cs)))
      ((null? cs) 'done)
    (let* ((c (car cs))
           (c-val (get-value (contextifier-vop c)
                             (contextifier-voc c)
                             vars
                             vals)))
      (let ((dest-i (contextifier-dest-i c))
            (fg (vref vars (contextifier-fg-i c))))
        (let ((context-type (fg-type-context (fg-type fg))))
          (cond ((null? context-type))
                ((fx< dest-i 0)
                 (cond ((neq? context-type (car c-val))
                        (error "sub-field ~s not valid in context ~s" fg c-val))
                       (else
                        (let ((vars (fg-vars fg)))
                          (do ((i 0 (fx+ i 1))
                               (l (cdr c-val) (cdr l)))
                              ((null? l) fg)
                            (set (vref vars i) (car l)))))))
                (else
                 (vset (fg-vars fg) dest-i c-val))))))))


;;; ----------------------------------------------------------------
;;; DESTRUCTURE-FG.  
;;;   This is kind of a hack for pulling an FG apart, after it has been made.
;;; Returns field value, field width, and updated start.  We shouldn't have
;;; to do this.  

(define (destructure-fg fg start)
  (let* ((fgt (fg-type fg))
         (vars (fg-vars fg))
         (vals (fg-type-vals fgt))
         (ops  (fg-type-ops fgt))
         (ops (nthcdr ops start)))
     (cond ((null? ops)
            (return nil 0 start))
           (else
            (select (car ops)
              ((wop/fix)
               (destructure (((#f width vop voc1 . ops) ops))
                 (return (get-value vop voc1 vars vals) 
                         width 
                         (fx+ start 4))))
              ((wop/@fix)
               (destructure (((#f width-i vop voc1 . ops) ops))
                 (return (get-value vop voc1 vars vals) 
                         (vref vars width-i)
                         (fx+ start 4))))
              ((wop/mark)
               (destructure (((#f marker-i . ops) ops))
                 (return 0 0 (fx+ start 2))))
              (else
               (error "can't destructure~%  (DESTRUCTURE-FG ~s ~s)" fg start))
              )))))