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 / base / rvalue.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  178 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rvalue.scm,v 4.7 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 1989, 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. ;;;; Right (Hand Side) Values
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define-root-type rvalue
  27.   %passed-out?)
  28.  
  29. ;;; converted to a macro.
  30. ;;; (define (make-rvalue tag . extra)
  31. ;;;   (list->vector (cons* tag false extra)))
  32.  
  33. (define-enumeration rvalue-type
  34.   (block
  35.    constant
  36.    expression
  37.    procedure
  38.    reference
  39.    unassigned-test))
  40.  
  41. (define (rvalue-values rvalue)
  42.   (if (rvalue/reference? rvalue)
  43.       (reference-values rvalue)
  44.       (list rvalue)))
  45.  
  46. (define (rvalue-passed-in? rvalue)
  47.   (and (rvalue/reference? rvalue)
  48.        (reference-passed-in? rvalue)))
  49.  
  50. (define (rvalue-passed-out? rvalue)
  51.   (if (rvalue/reference? rvalue)
  52.       (reference-passed-out? rvalue)
  53.       (rvalue-%passed-out? rvalue)))
  54.  
  55. (define (rvalue-known-value rvalue)
  56.   (if (rvalue/reference? rvalue)
  57.       (reference-known-value rvalue)
  58.       rvalue))
  59.  
  60. (define (rvalue-known-constant? rvalue)
  61.   (let ((value (rvalue-known-value rvalue)))
  62.     (and value
  63.      (rvalue/constant? value))))
  64.  
  65. (define (rvalue-constant-value rvalue)
  66.   (constant-value (rvalue-known-value rvalue)))
  67.  
  68. (define (rvalue=? rvalue rvalue*)
  69.   (if (rvalue/reference? rvalue)
  70.       (if (rvalue/reference? rvalue*)
  71.       (lvalue=? (reference-lvalue rvalue) (reference-lvalue rvalue*))
  72.       (eq? (lvalue-known-value (reference-lvalue rvalue)) rvalue*))
  73.       (if (rvalue/reference? rvalue*)
  74.       (eq? rvalue (lvalue-known-value (reference-lvalue rvalue*)))
  75.       (eq? rvalue rvalue*))))
  76.  
  77. ;;;; Constant
  78.  
  79. (define-rvalue constant
  80.   value)
  81.  
  82. (define *constants*)
  83.  
  84. (define (make-constant value)
  85.   (let ((entry (assv value *constants*)))
  86.     (if entry
  87.     (cdr entry)
  88.     (let ((constant (make-rvalue constant-tag value)))
  89.       (set! *constants* (cons (cons value constant) *constants*))
  90.       constant))))
  91.  
  92. (define-vector-tag-unparser constant-tag
  93.   (standard-unparser (symbol->string 'CONSTANT)
  94.     (lambda (state constant)
  95.       (unparse-object state (constant-value constant)))))
  96.  
  97. (define-integrable (rvalue/constant? rvalue)
  98.   (eq? (tagged-vector/tag rvalue) constant-tag))
  99.  
  100. ;;;; Reference
  101.  
  102. (define-rvalue reference
  103.   context
  104.   lvalue
  105.   safe?)
  106.  
  107. (define (make-reference block lvalue safe?)
  108.   (make-rvalue reference-tag block lvalue safe?))
  109.  
  110. (define-vector-tag-unparser reference-tag
  111.   (standard-unparser (symbol->string 'REFERENCE)
  112.     (lambda (state reference)
  113.       (unparse-object state (variable-name (reference-lvalue reference))))))
  114.  
  115. (define-integrable (rvalue/reference? rvalue)
  116.   (eq? (tagged-vector/tag rvalue) reference-tag))
  117.  
  118. (define-integrable (reference-values reference)
  119.   (lvalue-values (reference-lvalue reference)))
  120.  
  121. (define-integrable (reference-passed-in? reference)
  122.   (lvalue-passed-in? (reference-lvalue reference)))
  123.  
  124. (define-integrable (reference-passed-out? reference)
  125.   (lvalue-passed-out? (reference-lvalue reference)))
  126.  
  127. (define-integrable (reference-known-value reference)
  128.   (lvalue-known-value (reference-lvalue reference)))
  129.  
  130. (define (reference-to-known-location? reference)
  131.   (variable-in-known-location? (reference-context reference)
  132.                    (reference-lvalue reference)))
  133.  
  134. ;;; This type is only important while we use the `unassigned?' special
  135. ;;; form to perform optional argument defaulting.  When we switch over
  136. ;;; to the new optional argument proposal we can flush this since the
  137. ;;; efficiency of this construct won't matter anymore.
  138.  
  139. (define-rvalue unassigned-test
  140.   context
  141.   lvalue)
  142.  
  143. (define (make-unassigned-test block lvalue)
  144.   (make-rvalue unassigned-test-tag block lvalue))
  145.  
  146. (define-vector-tag-unparser unassigned-test-tag
  147.   (standard-unparser (symbol->string 'UNASSIGNED-TEST)
  148.     (lambda (state unassigned-test)
  149.       (unparse-object state (unassigned-test-lvalue unassigned-test)))))
  150.  
  151. (define-integrable (rvalue/unassigned-test? rvalue)
  152.   (eq? (tagged-vector/tag rvalue) unassigned-test-tag))
  153.  
  154. ;;;; Expression
  155.  
  156. (define-rvalue expression
  157.   block
  158.   continuation
  159.   entry-edge
  160.   label
  161.   debugging-info)
  162.  
  163. (define *expressions*)
  164.  
  165. (define (make-expression block continuation scfg)
  166.   (let ((expression
  167.      (make-rvalue expression-tag block continuation
  168.               (node->edge (cfg-entry-node scfg))
  169.               (generate-label 'EXPRESSION) false)))
  170.     (set! *expressions* (cons expression *expressions*))
  171.     (set-block-procedure! block expression)
  172.     expression))
  173.  
  174. (define-integrable (rvalue/expression? rvalue)
  175.   (eq? (tagged-vector/tag rvalue) expression-tag))
  176.  
  177. (define-integrable (expression-entry-node expression)
  178.   (edge-next-node (expression-entry-edge expression)))