home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / compiler / fgopt / desenv.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  148 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: desenv.scm,v 4.4 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Environment Design
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; Frame Layout
  27.  
  28. #|
  29.  
  30. Layout of stack frames.  The top of each frame is where the frame
  31. pointer points to, which is the most recently pushed item in the
  32. frame (i.e. the item closest to the top of stack).  There are two
  33. kinds of frames, depending on what kind of procedure this is.
  34.  
  35. Open procedure frame:
  36.  
  37. +-------+-------+-------+-------+
  38. |       Auxiliary 1        |
  39. +-------+-------+-------+-------+
  40. :        :        :
  41. +-------+-------+-------+-------+
  42. |       Auxiliary M        |
  43. +-------+-------+-------+-------+
  44. |        Argument 1        |
  45. +-------+-------+-------+-------+
  46. :        :        :
  47. +-------+-------+-------+-------+
  48. |        Argument N        |
  49. +-------+-------+-------+-------+
  50. |      Rest Argument        |    (omitted if none)
  51. +-------+-------+-------+-------+
  52. |    Pointer to parent frame    |    (omitted if known)
  53. +-------+-------+-------+-------+
  54.  
  55. Closed procedure frame:
  56.  
  57. +-------+-------+-------+-------+
  58. |       Auxiliary 1        |
  59. +-------+-------+-------+-------+
  60. :        :        :
  61. +-------+-------+-------+-------+
  62. |       Auxiliary M        |
  63. +-------+-------+-------+-------+
  64. |         Operator        |    (omitted if not needed)
  65. +-------+-------+-------+-------+
  66. |        Argument 1        |
  67. +-------+-------+-------+-------+
  68. :        :        :
  69. +-------+-------+-------+-------+
  70. |        Argument N        |
  71. +-------+-------+-------+-------+
  72. |      Rest Argument        |    (omitted if none)
  73. +-------+-------+-------+-------+
  74.  
  75. |#
  76.  
  77. (define (design-environment-frames! blocks)
  78.   (for-each (lambda (block)
  79.           (enumeration-case block-type (block-type block)
  80.         ((IC)
  81.          (if (rvalue/procedure? (block-procedure block))
  82.              (setup-ic-block-offsets! block)))
  83.         ((STACK)
  84.          (for-each (lambda (variable)
  85.                  (if (variable-assigned? variable)
  86.                  (set-variable-in-cell?! variable true)))
  87.                (block-bound-variables block))
  88.          (setup-stack-block-offsets! block))
  89.         ((CONTINUATION)
  90.          (set-block-frame-size!
  91.           block
  92.           (continuation/frame-size (block-procedure block))))
  93.         ((CLOSURE) 'DONE)
  94.         (else
  95.          (error "Illegal block type" block))))
  96.         blocks))
  97.  
  98. (define (setup-ic-block-offsets! block)
  99.   (let ((procedure (block-procedure block)))
  100.     (setup-variable-offsets!
  101.      (procedure-names procedure)
  102.      (setup-variable-offset!
  103.       (procedure-rest procedure)
  104.       (setup-variable-offsets!
  105.        (procedure-optional procedure)
  106.        (setup-variable-offsets! (cdr (procedure-required procedure))
  107.                 ic-block-first-parameter-offset))))))
  108.  
  109. (define (setup-stack-block-offsets! block)
  110.   (let ((procedure (block-procedure block)))
  111.     (set-block-frame-size!
  112.      block
  113.      (let ((offset
  114.         (setup-variable-offset!
  115.          (procedure-rest procedure)
  116.          (setup-variable-offsets!
  117.           (procedure-optional procedure)
  118.           (setup-variable-offsets!
  119.            (cdr (procedure-required procedure))
  120.            (let ((offset
  121.               (setup-variable-offsets! (procedure-names procedure) 0)))
  122.          (if (and (procedure/closure? procedure)
  123.               (closure-procedure-needs-operator? procedure))
  124.              (begin (set-procedure-closure-offset! procedure offset)
  125.                 (1+ offset))
  126.              offset)))))))
  127.        (if (or (procedure/closure? procedure)
  128.            (not (stack-block/static-link? block)))
  129.        offset
  130.        (1+ offset))))))
  131.  
  132. (define (setup-variable-offsets! variables offset)
  133.   (if (null? variables)
  134.       offset
  135.       (if (variable-register (car variables))
  136.       (setup-variable-offsets! (cdr variables) offset)
  137.       (begin (set-variable-normal-offset! (car variables) offset)
  138.          (setup-variable-offsets! (cdr variables) (1+ offset))))))
  139.  
  140. (define (setup-variable-offset! variable offset)
  141.   (if (and variable (not (variable-register variable)))
  142.       (begin (set-variable-normal-offset! variable offset)
  143.          (1+ offset))
  144.       offset))
  145.  
  146.  
  147.  
  148.