(herald (assembler as_utils t 17)
        (env tsys (assembler ib)))  ;  get-value needs

;;; ----------------------------------------------------------------
;;; Runtime support for the assembler 



;;; ---------------- Fetch/compute values in fgs

(define (get-fixed-value vop voc1 vars vals)
  (xselect vop
    ((vop/const) (vref vals voc1))
    ((vop/var)   (let ((expr (vref vars voc1)))
                   (cond ((fixnum? expr) expr)
                         (else 
                          (no-op (error "assembler expecting fixed value, got ~s"
                                        expr))))))
    ((vop/proc)  ((vref vals voc1) vars))))

(define (get-value vop voc1 vars vals)
  (xselect vop
    ((vop/const) (vref vals voc1))
    ((vop/var)   (let ((expr (vref vars voc1)))
                   (cond ((fixnum? expr) expr)  
                         ((procedure? expr) (expr vars))
                         (else expr))))
    ((vop/proc)  ((vref vals voc1) vars))
    ))
    
;;; ---------------- Called from expressions in machine decriptions 
;;;                  that use DISP or FROM.

(define (expr-compute-disp vars mark dest-expr)
  (let ((ma (mark-address mark)))
     (cond ((ib? dest-expr) 
            (fx- (ib-address dest-expr) ma))
           (else                           
            (no-op 
              (error "bad arguments to EXPR-COMPUTE-DISP - DISP and FROM expect a mark and a tag"))))))

;;; ---------------- Useful in machine descriptions

(define (make-symbolic-set-converter bit-names)
  (lambda (bits)
    (iterate loop ((regs bit-names)
                   (bits bits)
                   (accum 0))
      (cond ((null? regs) accum)
            ((memq? (car regs) bits)
             (loop (cdr regs) bits (fx+ (fixnum-ashl accum 1) 1)))
            (else
             (loop (cdr regs) bits (fixnum-ashl accum 1)))))))

;;; ---------------- Used by the VAX description - move there?

(define (choose-width opts signed? val)
  (let ((want (integer-field-size val signed?)))
    (iterate loop ((l opts))
        (cond ((null? l)
               (error "no width fits~%  (choose-width ~s ~s ~s)"
                      opts signed? val))
              ((fx>= (car l) want) (car l))
              (else (loop (cdr l)))))))

(define-integrable (integer-field-size n signed?)
  (if (not (fixnum? n)) (error "integer-field-size on non fixnum"))
  (if signed?
      (signed-field-size n)
      (unsigned-field-size n)))

(define-integrable (signed-field-size n)
  (fx+ (if (fx>= n 0)
           (fixnum-howlong n)
           (fixnum-howlong (fx- -1 n)))
       1))

(define-integrable (unsigned-field-size n)
  (if (fx>= n 0)
      (fixnum-howlong n)
      (error "(unsigned-field-size ~s)" n))) ; (fixnum-howlong (fx- -1 n))

;;; ---------------- Field size stuff (more in AS_OPEN)

(define (lessp x y z)
  (and (<= x y) (< y z)))

;(define (30bit? n)
;  (lessp #x-20000000 n #x20000000))

(define (30bit? n)
  (lessp most-negative-fixnum n #x20000000))

(define (30bit-in-bits? n)
  (lessp #x-100000000 n #x100000000))

(define (32bit? n)
  (lessp #x-80000000 n #x80000000))

(define (32bit-u? n)
  (lessp -1 n #x100000000))

;;; ---------------- AS internal enumeration
;;;  values need in compile_fgs

(define-constant vop/const 0)
(define-constant vop/var   1)
(define-constant vop/proc  2)
(define-constant wop/fix       0)
(define-constant wop/@fix      1)
(define-constant wop/subfield  2)
(define-constant wop/variable  3)
(define-constant wop/mark      4)
(define-constant wop/group     5)

;;; ---------------- Random

(define (walk-backwards proc list)
  (cond ((null? list) 'done)
        (else (walk-backwards proc (cdr list))
              (proc (car list)))))

(define (fixnum-mod x y)
  (cond ((fx< x 0)
         (fx- (fx- y 1) (fixnum-remainder (fx- -1 x) y)))
        (else (fixnum-remainder x y))))