;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved


;; "_repr.scm"

(##include "header.scm")

;------------------------------------------------------------------------------

; Procedures to access back-end dependent object representation

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (##proc-closure? p)
  (and (##not (##fixnum.< (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) #x8000))
       (##fixnum.= (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 3) #x4eb9)))

(define (##proc-closure-body p)
  (##slot-ref (##type-cast p 0) 1))

(define (##proc-closure-length p)
  (##fixnum.- (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -2) #x2001))

(define (##proc-closure-ref p i)
  (##slot-ref (##type-cast p 0) (##fixnum.+ i 2)))

(define (##proc-closure-set! p i v)
  (##slot-set! (##type-cast p 0) (##fixnum.+ i 2) v))

(define (##proc-subproc? p)
  (##fixnum.< (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) #x8000))

(define (##proc-subproc-tag p)
  (##fixnum.- #x1000 (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -3)))

(define (##proc-subproc-parent p)
  (##fixnum.- p (##fixnum.- #x1000 (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -3))))

(define (##proc-return-dyn-env? p)
  (##fixnum.= (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 0) 0))

(define (##proc-return-fs p)
  (let ((x (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 0)))
    (if (##fixnum.= x 0)
      2 ; dynamic environment frame size
      (##fixnum.ash (##fixnum.modulo x #x8000) -2))))

(define (##proc-return-link p)
  (##fixnum.- (##proc-return-fs p)
              (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 1) -2)))

(define (##proc-debug-info p)
  (let ((len (##fixnum.- (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -2) #x2000)))
    (##vector-ref (##type-cast p (type-subtyped)) (##fixnum.- len 2))))

;------------------------------------------------------------------------------

(define (##continuation->frame c)
  (let ((v (##proc-closure-ref c 1))
        (r (##proc-closure-ref c 0))
        (d (##proc-closure-ref c 2)))
    (let ((x (##make-vector 4 #f)))
      (##vector-set! x 0 v)
      (##vector-set! x 1 r)
      (##vector-set! x 2 d)
      (##vector-set! x 3 1)
      x)))

(define (##frame-ret f)
  (##vector-ref f 1))

(define (##frame-dyn-env f)
  (##vector-ref f 2))

(define (##frame-fs f)
  (##proc-return-fs (##vector-ref f 1)))

(define (##frame-stk-ref f i)
  (##vector-ref (##vector-ref f 0)
                (##fixnum.- (##fixnum.+ (##vector-ref f 3)
                                        (##proc-return-fs (##vector-ref f 1)))
                            i)))

(define (##frame-stk-set! f i v)
  (##vector-set! (##vector-ref f 0)
                 (##fixnum.- (##fixnum.+ (##vector-ref f 3)
                                         (##proc-return-fs (##vector-ref f 1)))
                             i)
                 v))

(define (##frame-next f)
  (let ((v (##vector-ref f 0))
        (r (##vector-ref f 1))
        (d (##vector-ref f 2))
        (o (##vector-ref f 3)))
    (let* ((o* (##fixnum.+ o (##proc-return-fs r)))
           (r* (##vector-ref v (##fixnum.- o* (##proc-return-link r))))
           (d* (if (##proc-return-dyn-env? r)
                 (##vector-ref v (##fixnum.- o* 2))
                 d)))
      (if (##fixnum.< o* (##vector-length v))
        (let ((x (##make-vector 4 #f)))
          (##vector-set! x 0 v)
          (##vector-set! x 1 r*)
          (##vector-set! x 2 d*)
          (##vector-set! x 3 o*)
          x)
        (let ((v* (##vector-ref v 0)))
          (if v*
            (let ((x (##make-vector 4 #f)))
              (##vector-set! x 0 v*)
              (##vector-set! x 1 r*)
              (##vector-set! x 2 d*)
              (##vector-set! x 3 1)
              x)
            #f))))))

;------------------------------------------------------------------------------