(herald (assembler compile_fgs t 37))

;;; (fg-template (fgname . parameters)
;;;   . <fg-spec-item>s )
;;;
;;;   <parameter> is (<predicate> <parameter-name>)  or <parameter-name>
;;;   and the <predicate> returns false if the parameter passed
;;;   to create the fg was not of the right type.
;;; 
;;; 
;;; <fg-spec-item> ::= (PRINTER ...)  |
;;;                    (LOCAL <local-var-name>s) | 
;;;                    (CONTEXT <ContextSpec>)
;;;                    (SET-CONTEXT <name> <context>)
;;;                       <name> is a parameter of local var whose
;;;                       value is a field group.  Context is an early
;;;                       value that is used as the context for the 
;;;                       field group named by <name>
;;;                    (SET-CONTEXT-ITEM <name> <context-item-spec>)
;;;                       like set-context but allows on part of the
;;;                       context to be given; see comment in code below.
;;;                    (FIELDS . <field-spec>s)
;;;
;;; The order of the items matters: any SET-CONTEXT or SET-CONTEXT-ITEM must
;;; follow specs for CONTEXT and LOCAL.  There should be at most one of
;;; and of the above except for SET-CONTEXT[-ITEM] which may occur more 
;;; than once.
;;;
;;; <field-spec> is one of
;;;  
;;;   (FIXED <width> <value>)
;;;      <width> is an early expr yielding the width of the field in # of bits
;;;      <value> is a late expr yielding an integer to use to fill the field
;;;   ({0|1} {0|1} ...) -- like (FIXED width value), msb first
;;;
;;;   (SUBFIELD [ <name> ] <fg>)
;;;      <name> is a <parameter-name> of <local-var-name> whose value is
;;;             set to the value of <fg>
;;;      <fg> is a early expr yielding a field group to splice at this 
;;;           position
;;;   
;;;   (VARIABLE ... )
;;;      -- see section below.
;;;
;;;   (MARK <name>)
;;;      -- <name> is a <local-var-name> that will be set to
;;;         the current location counter.
;;; 
;;;   expressions may use anything in T.
;;;
;;;   "early expressions" can reference parameters, context values
;;;       from the field group
;;;   "late expressions" can also reference marks using
;;;      (MARK-ADDRESS <mark-name> or (FROM <mark-name> <tag-name>)
;;;      (both yield values expressed in bits, not bytes)

;;; (VARIABLE <width-expr> <selector> <final-bits-expr>)
;;; <selector> ::=
;;;     ( <selector-name> ( <width-name> <min-width> ) <displ-name> )

;;; The selector in a VARIABLE spec is used to calculate the number of bits
;;; needed to represent the field, given the displacement specified in the
;;; VARIABLE spec, and the width of this field used in computing that
;;; displacement.  

;;; <width-name> and <displ-name> are names of variables local to this fg.
;;; The selector is passed these (TAS figures out initial values) and must
;;; return new values.  The two variables will be set to the final width
;;; and displacement values.  The last form in the VARIABLE spec is an
;;; expression that will be evaluated to get an fg (or list of them) to use
;;; as the VARIABLE spec.  That fg is obligated to be exactly as wide as
;;; the selector computed it would be (that width will be the value of the
;;; variable named <width-name>.  

;;; The returned displacement must be measured from the same spot that
;;; the passed-in displacement was measured from.

;;; This routine 'wraps' the selector so that its return values will
;;; be available to the fg expression.

;;; Who sets what fields in a VARIABLE spec:  COUNT sets the sdf-number
;;; slot of the sdf to be index of that sdf in the SDFS vector.  The sdf is
;;; stored in the sdf-i slot of VARS when the fg is consed.  The mark-i
;;; slot of VARS is a mark structure for the mark mentioned in the VARIABLE
;;; spec; it is also initialized when the fg in consed 

;;; ----------------------------------------------------------------
;;;  Contexts

(define context-id car)
(define context-components cdr)

;;; ----------------------------------------------------------------
;;; Variables and constants 

;;; The vars list is multiplexed to provide information about the shape of
;;; the runtime variable vector for an fg as well as the initial values of
;;; those variables.  

;;; Usually an element of the vars list is a symbol, and the position in
;;; the list indicates where the variable of that name will be located at
;;; runtime.  There are some anonymous variables that are initialized, and
;;; there appear in the vars list as `(,*var-mark* .  cruft).  Some named
;;; variables are given initial values; they appear in the vars list as
;;; `(*init-var-mark* ,var-name . cruft) 

;;; This stuff is a mess.

(define *var-mark* (cons '*var-mark* nil))
(define *init-var-mark* (cons '*init-var-mark* nil))

(define (augment-vals state val)
  (let ((vals (fgstate-vals state)))
    (set (fgstate-vals state) (cons val vals))
    (length vals)))

(define (allocate-vars-slot state)
  (let ((vars (fgstate-vars state)))
    (set (fgstate-vars state) (cons '#f vars))
    (length vars)))

(define (augment-vars state val)
  (let ((vars (fgstate-vars state)))
    (set (fgstate-vars state) (cons `(,*var-mark* . ,val) vars))
    (length vars)))

(define (add-field-expr state exp)
  (augment-vals state (compile-expr state exp)))

(define (all-vars-and-positions state)
  (iterate loop ((names '())
                 (vars (fgstate-vars state)))
    (cond ((null? vars)
           (map (lambda (n) (cons n (vars-ref state n)))
                names))
          (else
           (let ((item (car vars)))
             (cond ((symbol? item)
                    (loop (cons item names) (cdr vars)))
                   ((and (pair? item) (eq? (car item) *init-var-mark*))
                    (loop (cons (cadr item) names) (cdr vars)))
                   (else
                    (loop names (cdr vars)))))))))
                
(define (set-initial-value var val state)
    (iterate loop ((vars (fgstate-vars state)))
        (cond ((null? vars)
               (error "can't set initial value of ~s in ~s" var vars))
              ((eq? (car vars) var)
               (set (car vars) `(,*init-var-mark* ,var . ,val)))
              ((and (pair? (car vars))
                    (eq? (caar vars) *init-var-mark*)
                    (eq? (cadar vars) var))
               (error "~s already has an initial value ~s" var vars))
              (else
               (loop (cdr vars))))))


(define (get-initial-value state var)
  (let ((vars (fgstate-vars state)))
    (cond ((any (lambda (some-var) (is-the-var? var some-var)) vars)
           => (lambda (v) (cond ((pair? v) (cddr v))
                                (else ''()))))
          (else
           ''()))))

(define (is-the-var? the-var some-var)
  (cond ((eq? the-var some-var) t)
        ((and (pair? some-var)
              (eq? (car some-var) *init-var-mark*)
              (eq? (cadr some-var) the-var))
         some-var)
        (else nil)))

(define (vars-ref state key)
  (let ((vars (fgstate-vars state)))
    (fx- (fx- (length vars)
              (or (pos is-the-var? key vars)
                  (error "variable ~s not found in ~s" key vars)))
         1)))

;;; ----------------------------------------------------------------
;;; FG definition processing

;;; ---------------- For convenience, we package up the state from
;;;  processing an FG definition.

(define-structure-type fgstate
  ;; these first slots are simply components of the FG definition
  id
  bvl
  parameters
  locals 
  context 
  printer 
  ppn       ; printer's port name (name of var printer uses for the port)

  ;; these slots are computed as we process the definition
  vars                          ; VARS are maintained in backwards order
  vals 
  contexts
  fixed-forces 
  subfield-forces
  sdf-statics
  )

(define (cons-fgstate name parameters)
  (let ((fgstate (make-fgstate)))
    (set (fgstate-id fgstate) name)
    (set (fgstate-parameters fgstate) parameters)
    (set (fgstate-bvl fgstate)
         (map (lambda (x) (if (pair? x) (cadr x) x)) parameters))
    fgstate))

(let ((fgstate (stype-master fgstate-stype)))
  (set (fgstate-vars fgstate) '#t)
  (set (fgstate-locals fgstate) '())
  (set (fgstate-context fgstate) '#f)
  (set (fgstate-printer fgstate) '#f)
  (set (fgstate-ppn fgstate) 'port)

  (set (fgstate-vals fgstate) '())
  (set (fgstate-contexts fgstate) '())
  (set (fgstate-fixed-forces fgstate) '())
  (set (fgstate-subfield-forces fgstate) '())
  (set (fgstate-sdf-statics fgstate) '())
  )

;;; ---------------- Compile FG definition into scheme code.
                                
(define (process-fg-definition name parameters specs)
  (let* ((state (cons-fgstate name parameters))
         (fields (process-random-specs state specs)))
    (iterate loop ((fields fields)
                   (ops's '()))
      (cond ((null? fields)
             (let ((type-name (generate-symbol 'fg-type)))
               `(let ((,type-name ,(fgt-code state ops's))
                      ,@(fgstate-sdf-statics state))
                  ,(fg-code state type-name)
                  ,type-name)))
            ((eq? (caar fields) 'group)
             (loop `((group-start) ,@(cdar fields) (group-end) ,@(cdr fields))
                   ops's))
            (else
             (let ((ops (process-field-spec state (car fields))))
               (loop (cdr fields) (append! ops's ops) )))))))


;;; ---------------- Construct code for a processed FG definition

;;; Construct code for fg-type.

(define (fgt-code state ops)
  (let ((context (fgstate-context state)))
    `(cons-fg-type ',(fgstate-id state)
                   ,(compile-print-expr state)
                   ',ops
                   (vector ,@(map (lambda (x)
                                    (cond ((and (pair? x)
                                                (neq? (car x) 'lambda))
                                           `',x)
                                          (else x)))
                                  (reverse! (fgstate-vals state))))
                   ',(context-id context)
                   ',(length (context-components context))
                   ',(fgstate-contexts state)
                   ',(fgstate-fixed-forces state)
                   ',(fgstate-subfield-forces state)
                   )))
                              
;;; Construct code for fg object itself.

(define (fg-code state type-name)
  (let ((bvl (fgstate-bvl state))
        (parameters (fgstate-parameters state))
        (context (fgstate-context state))
        (locals (fgstate-locals state))
        (vars (fgstate-vars state)))
    (let ((cons-fg-code
           `(cons-fg ,type-name
                     (vector ,@(append (map (lambda (()) ''())
                                            (context-components context))
                                       bvl
                                       (map (lambda (v)
                                              (get-initial-value state v))
                                            locals)
                                       (make-var-slot-code vars)
                                       )))))
      `(set (fg-type-constructor ,type-name)
            (lambda ,bvl
              ,(cond ((any? pair? parameters)
                      `(let (,@(map list bvl parameters))
                         (and ,@bvl ,cons-fg-code)))
                     (else cons-fg-code)))))))

;;; ---------------- Random specs
             
;;; Collect LOCAL PRINTER and CONTEXT specs out of a FG definition
;;; Return field specs

(define (process-random-specs state specs)
   (iterate loop ((specs specs) (fields '()))
     (cond ((null? specs)
            (set-fgstate-vars state)
            fields)
           (else
            (let* ((spec (car specs))
                   (key (car spec)))
              (case key
                ((fields)
                 (loop (cdr specs) (cdr spec)))
                ((local)
                 (set (fgstate-locals state) (cdr spec))
                 (loop (cdr specs) fields))
                ((printer)
                 (set (fgstate-printer state)
                      `(format ,(fgstate-ppn state) . ,(cdr spec)))
                 (loop (cdr specs) fields))
                ((print)
                 (let ((bvl (cadr spec))
                       (body (cddr spec)))
                   (set (fgstate-ppn state) (car bvl))
                   (set (fgstate-printer state) `(block . ,body))
                   (loop (cdr specs) fields)))
                ((context)
                 (set (fgstate-context state) (cadr spec))
                 (loop (cdr specs) fields))
                ((set-context)
                 (set-fgstate-vars state)
                 (process-set-context state spec)
                 (loop (cdr specs) fields))
                ((set-context-item)
                 (set-fgstate-vars state)
                 (process-set-context-item state spec)
                 (loop (cdr specs) fields))
                (else
                 (error "bad fg keyword ~s" key))))))))

(define (set-fgstate-vars state)
  (cond ((eq? (fgstate-vars state) '#t)  ; not yet set
         (set (fgstate-vars state)
              (append (reverse (fgstate-locals state))
                      (reverse (fgstate-bvl state))
                      (reverse (context-components
                                (fgstate-context state))))))))


;;; ---------------- Process field specs

(define (process-field-spec state spec)
  (case (car spec)
    ((fixed) 
     (process-fixed-field state spec))
    ((0 1)
     (receive (width value) 
              (bits->fixnum spec)
       (process-fixed-field state `(fixed ,width ,value))))
    ((variable)
     (process-variable-width-field state spec))
    ((subfield)
     (receive (name fg-expr)
              (cond ((= (length spec) 3)
                     (return (cadr spec) (caddr spec)))
                    (else
                     (return '#f (cadr spec))))
       (process-subfield state name fg-expr)))
    ((mark)
     (destructure (((#f mark-name) spec))
       (set-initial-value mark-name '(make-mark) state)
       `(,wop/mark ,(vars-ref state mark-name))))
    ((group-start)
     (list wop/group 1))
    ((group-end)
     (list wop/group 0))
    (else
     (error "unrecognized field specifier: ~s" spec))))

;;; ---------------- Fixed fields
 
(define (process-fixed-field state spec)
  (destructure (((#f w-exp v-exp) spec))
    (receive (vop voc1)
             (fg-value-op state v-exp)
      (receive (wop wopc)
               (cond ((fixnum? w-exp)
                      (return wop/fix w-exp))
                     ((symbol? w-exp)
                      (return wop/@fix (vars-ref state w-exp)))
                     (else
                      (let ((expr-i (add-field-expr state w-exp))
                            (cw-i (allocate-vars-slot state)))
                        (push (fgstate-fixed-forces state) (cons expr-i cw-i))
                        (return wop/@fix cw-i))))
        `(,wop ,wopc ,vop ,voc1)))))

;;; ---------------- Subfields

;;; (SUBFIELD [name] <fg-expr>)
;;;   If the fg-expr needs to be computed, the VAL index of the
;;;   <expr>-procedure is stored in the VAR slot allocated for the subfg 

(define (process-subfield state name fg-expr)
  `(,wop/subfield
    ,(cond ((symbol? fg-expr)
            (if name (error "2 names for subfield: ~s, ~s" fg-expr name))
            (let ((fg-i (vars-ref state fg-expr)))
              (push (fgstate-subfield-forces state) fg-i)
              fg-i))
           (else                        ; have an <expr> for subfg
            (let ((expr-i (add-field-expr state fg-expr))
                  (fg-i (cond (name (vars-ref state name))
                              (else (allocate-vars-slot state)))))
              (push (fgstate-subfield-forces state) (cons expr-i fg-i))
              fg-i)))))

;;; ---------------- Variable fields (span dependent fields)

;;; (VARIABLE <width-expr> <selector> <final-bits-expr>)
;;; <selector> ::=
;;;     ( <selector-name> ( <width-name> <min-width> ) <displ-name> )

(define (process-variable-width-field state spec)
  (destructure (((#f (#f m-name label) 
                     (sel (w-name min) d-name) 
                     fg-expr) 
                 spec))
    (let ((width-i (vars-ref state w-name))
          (displ-i (vars-ref state d-name))
          (mark-i  (vars-ref state m-name))
          (static-var (generate-symbol 'sdfstatic))
          )
      (let ((sdf-i (augment-vars state `(cons-sdf ,label ,sel ,static-var))))
        (push (fgstate-sdf-statics state)
              `(,static-var (cons-sdf-static ,min ,width-i ,displ-i)))
        (let ((fg-expr-i (add-field-expr state fg-expr)))
          `(,wop/variable ,sdf-i ,mark-i ,fg-expr-i))))))

;;; ---------------- Set-contexts

;;; (SET-CONTEXT <fg-name> <context-expr>)
;;;    <context-expr> evaluates to a whole context form
;;; (SET-CONTEXT-ITEM <fg-name> <single-item-from-a-context expr>)
;;;    for a context line (GENERAL FOO BAR BAZ) you can specify
;;;    values for one or more of the context elements:
;;;      (GENERAL (FOO 'a) BAR (BAZ 3))  sets values for FOO and BAZ

(define (process-set-context state spec)
  (destructure (((#f name c-expr) spec))
    (let ((fg-i (vars-ref state name)))
      (receive (vop voc)
               (fg-value-op state c-expr)
        (push (fgstate-contexts state) (vector fg-i -1 vop voc))))))
                               
(define (process-set-context-item state spec)
  (destructure (((#f name c1-form) spec))
    (let ((fg-i (vars-ref state name)))
      (iterate loop ((forms (cdr c1-form))
                     (pos 0))
        (cond ((null? forms) 'done)
              (else
               (let ((item (car forms)))
                 (cond ((symbol? item)
                        (loop (cdr forms) (+ pos 1)))
                       ((and (pair? item) (pair? (cdr item)))
                        (make-context-1 state fg-i pos (cadr item))
                        (loop (cdr forms) (+ pos 1)))
                       (else
                        (error "bad context-1 value spec in ~s" spec))))))))))
                        
(define (make-context-1 state fg-i pos item)
  (receive (vop voc)
           (fg-value-op state item)
    (push (fgstate-contexts state) (vector fg-i pos vop voc))))

;;; ---------------- Random ness

;;; Compile a value expression - return <v-op> <v-opcode1>

(define (fg-value-op state v-exp)
  (xcond ((fixnum? v-exp)
          (return vop/const (augment-vals state v-exp)))
         ((symbol? v-exp)
          (return vop/var (vars-ref state v-exp)))
         ((pair? v-exp)
          (cond ((eq? (car v-exp) 'quote)
                 (return vop/const (augment-vals state `',(cadr v-exp))))
                (else
                 (return vop/proc (add-field-expr state v-exp)))))))

;;; As the PROCESS- guys build of the list of things in the FG-VARS vector,
;;; some things are marked as needing to be evaluated by wrapping them
;;; with (*var-mark* ...);  MAKE-VAR-SLOT-CODE takes the marks out, and
;;; puts in quotes.  Note this results in a reversed list, and the input
;;; is only processed up to the first symbol.   This is because VARS
;;; starts out with the context names, parameter names, and local variable
;;; names in it so the PROCESS- guys can compile references to those things.
;;; BUT! there are no values for the local and context vars when the fg 
;;; is made, but there are parameter values, so blah blah.

(define (make-var-slot-code vars)
  (iterate loop ((l vars) (var-slots '()))
     (cond ((null? l) 
            var-slots)
           ((null? (car l)) 
            (loop (cdr l) (cons ''#f var-slots)))
           ((and (pair? (car l)) 
                 (eq? (caar l) *var-mark*))
            (loop (cdr l) (cons (cdar l) var-slots)))
           (else
            var-slots))))

;;; Convert a list of bits to a fixnum.

(define *as-bits-per-fixnum* 30)

(define (bits->fixnum bits-in)
  (iterate loop ((l 0) (num 0) (bits bits-in))
     (cond ((null? bits)
            (return l num))
           ((fx>= l *as-bits-per-fixnum*)
             (error "too many bits~%  (bits->fixnum ~s)" bits-in))
           (else
            (loop (fx+ l 1) (fx+ (fixnum-ashl num 1) (car bits)) (cdr bits))))))

;;; ----------------------------------------------------------------
;;; "compile" expressions taken from an FG definition

;(require (assembler expand))

(define *fg-expr-syntax-table*
  (make-syntax-table *standard-syntax-table* '*fg-expr-syntax-table*))
                 
(lset *env-parameter-name* '#f)

(set (syntax-table-entry *fg-expr-syntax-table* 'from)
     (macro-expander (from mark-var dest-var)
       `(expr-compute-disp ,*env-parameter-name* ,mark-var ,dest-var)
       ))

;;; Returns s-expr for a procedure, which expects its first argument
;;; to be the VARS vector.

(define (compile-expr state expr)
  (let ((env-parameter-name (generate-symbol 'expr-env)))
    (bind ((*env-parameter-name* env-parameter-name))
;      (let ((code (expand expr *fg-expr-syntax-table*)))
      (let ((code (tas/expand expr *fg-expr-syntax-table*)))
        (let ((vs&ps (all-vars-and-positions state)))
          `(lambda (,env-parameter-name)
             (let ,(map (lambda (item)
                          `(,(car item)
                            (vref ,env-parameter-name ,(cdr item))) )
                        vs&ps)
               (ignorable  ,env-parameter-name ,@(map car vs&ps))
               ,code)))))))
                                           
;;; Returns s-expr for a printer for an FG.

(define (compile-print-expr state)
  (let ((env-parameter-name (generate-symbol 'expr-env))
;        (code (expand (fgstate-printer state)
        (code (tas/expand (fgstate-printer state)
                      *fg-expr-syntax-table*)))
    (cond ((null? (fgstate-printer state)) 'false)
          (else
           (let ((vs&ps (all-vars-and-positions state)))
             `(lambda (,env-parameter-name ,(fgstate-ppn state))
                (let ,(map (lambda (item)
                             `(,(car item)
                               (vref ,env-parameter-name ,(cdr item))))
                           vs&ps)
                  (ignorable  ,env-parameter-name ,@(map car vs&ps))
                  ,code)))))))