home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Runtime (.scm & .s) / _repr.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  4.0 KB  |  114 lines  |  [TEXT/gamI]
  1. (##include "header.scm")
  2.  
  3. ;------------------------------------------------------------------------------
  4.  
  5. ; Procedures to access back-end dependent object representation
  6.  
  7. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8.  
  9. (define (##proc-closure? p)
  10.   (and (##not (##fixnum.< (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) #x8000))
  11.        (##fixnum.= (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 3) #x4eb9)))
  12.  
  13. (define (##proc-closure-body p)
  14.   (##slot-ref (##type-cast p 0) 1))
  15.  
  16. (define (##proc-closure-length p)
  17.   (##fixnum.- (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -2) #x2001))
  18.  
  19. (define (##proc-closure-ref p i)
  20.   (##slot-ref (##type-cast p 0) (##fixnum.+ i 2)))
  21.  
  22. (define (##proc-closure-set! p i v)
  23.   (##slot-set! (##type-cast p 0) (##fixnum.+ i 2) v))
  24.  
  25. (define (##proc-subproc? p)
  26.   (##fixnum.< (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) #x8000))
  27.  
  28. (define (##proc-subproc-tag p)
  29.   (##fixnum.- #x1000 (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -3)))
  30.  
  31. (define (##proc-subproc-parent p)
  32.   (##fixnum.- p (##fixnum.- #x1000 (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -3))))
  33.  
  34. (define (##proc-return-dyn-env? p)
  35.   (##fixnum.= (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 0) 0))
  36.  
  37. (define (##proc-return-fs p)
  38.   (let ((x (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 0)))
  39.     (if (##fixnum.= x 0)
  40.       2 ; dynamic environment frame size
  41.       (##fixnum.ash (##fixnum.modulo x #x8000) -2))))
  42.  
  43. (define (##proc-return-link p)
  44.   (##fixnum.- (##proc-return-fs p)
  45.               (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 1) -2)))
  46.  
  47. (define (##proc-debug-info p)
  48.   (let ((len (##fixnum.- (##fixnum.ash (##vector16-ref (##type-cast (##fixnum.- p 1) (type-subtyped)) 2) -2) #x2000)))
  49.     (##vector-ref (##type-cast p (type-subtyped)) (##fixnum.- len 2))))
  50.  
  51. ;------------------------------------------------------------------------------
  52.  
  53. (define (##continuation->frame c)
  54.   (let ((v (##proc-closure-ref c 1))
  55.         (r (##proc-closure-ref c 0))
  56.         (d (##proc-closure-ref c 2)))
  57.     (let ((x (##make-vector 4 #f)))
  58.       (##vector-set! x 0 v)
  59.       (##vector-set! x 1 r)
  60.       (##vector-set! x 2 d)
  61.       (##vector-set! x 3 1)
  62.       x)))
  63.  
  64. (define (##frame-ret f)
  65.   (##vector-ref f 1))
  66.  
  67. (define (##frame-dyn-env f)
  68.   (##vector-ref f 2))
  69.  
  70. (define (##frame-fs f)
  71.   (##proc-return-fs (##vector-ref f 1)))
  72.  
  73. (define (##frame-stk-ref f i)
  74.   (##vector-ref (##vector-ref f 0)
  75.                 (##fixnum.- (##fixnum.+ (##vector-ref f 3)
  76.                                         (##proc-return-fs (##vector-ref f 1)))
  77.                             i)))
  78.  
  79. (define (##frame-stk-set! f i v)
  80.   (##vector-set! (##vector-ref f 0)
  81.                  (##fixnum.- (##fixnum.+ (##vector-ref f 3)
  82.                                          (##proc-return-fs (##vector-ref f 1)))
  83.                              i)
  84.                  v))
  85.  
  86. (define (##frame-next f)
  87.   (let ((v (##vector-ref f 0))
  88.         (r (##vector-ref f 1))
  89.         (d (##vector-ref f 2))
  90.         (o (##vector-ref f 3)))
  91.     (let* ((o* (##fixnum.+ o (##proc-return-fs r)))
  92.            (r* (##vector-ref v (##fixnum.- o* (##proc-return-link r))))
  93.            (d* (if (##proc-return-dyn-env? r)
  94.                  (##vector-ref v (##fixnum.- o* 2))
  95.                  d)))
  96.       (if (##fixnum.< o* (##vector-length v))
  97.         (let ((x (##make-vector 4 #f)))
  98.           (##vector-set! x 0 v)
  99.           (##vector-set! x 1 r*)
  100.           (##vector-set! x 2 d*)
  101.           (##vector-set! x 3 o*)
  102.           x)
  103.         (let ((v* (##vector-ref v 0)))
  104.           (if v*
  105.             (let ((x (##make-vector 4 #f)))
  106.               (##vector-set! x 0 v*)
  107.               (##vector-set! x 1 r*)
  108.               (##vector-set! x 2 d*)
  109.               (##vector-set! x 3 1)
  110.               x)
  111.             #f))))))
  112.  
  113. ;------------------------------------------------------------------------------
  114.