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 / rtlbase / rtlobj.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  124 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rtlobj.scm,v 4.12 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; Register Transfer Language: Object Datatypes
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define-structure (rtl-expr
  27.            (conc-name rtl-expr/)
  28.            (constructor make-rtl-expr
  29.                 (rgraph label entry-edge debugging-info))
  30.            (print-procedure
  31.             (standard-unparser (symbol->string 'RTL-EXPR)
  32.               (lambda (state expression)
  33.             (unparse-object state (rtl-expr/label expression))))))
  34.   (rgraph false read-only true)
  35.   (label false read-only true)
  36.   (entry-edge false read-only true)
  37.   (debugging-info false read-only true))
  38.  
  39. (define-integrable (rtl-expr/entry-node expression)
  40.   (edge-right-node (rtl-expr/entry-edge expression)))
  41.  
  42. (define-structure (rtl-procedure
  43.            (conc-name rtl-procedure/)
  44.            (constructor make-rtl-procedure
  45.                 (rgraph label entry-edge name n-required
  46.                     n-optional rest? closure?
  47.                     dynamic-link? type
  48.                     debugging-info
  49.                     next-continuation-offset stack-leaf?))
  50.            (print-procedure
  51.             (standard-unparser (symbol->string 'RTL-PROCEDURE)
  52.               (lambda (state procedure)
  53.             (unparse-object state
  54.                     (rtl-procedure/label procedure))))))
  55.   (rgraph false read-only true)
  56.   (label false read-only true)
  57.   (entry-edge false read-only true)
  58.   (name false read-only true)
  59.   (n-required false read-only true)
  60.   (n-optional false read-only true)
  61.   (rest? false read-only true)
  62.   (closure? false read-only true)
  63.   (dynamic-link? false read-only true)
  64.   (type false read-only true)
  65.   (%external-label false)
  66.   (debugging-info false read-only true)
  67.   (next-continuation-offset false read-only true)
  68.   (stack-leaf? false read-only true))
  69.  
  70. (define-integrable (rtl-procedure/entry-node procedure)
  71.   (edge-right-node (rtl-procedure/entry-edge procedure)))
  72.  
  73. (define (rtl-procedure/external-label procedure)
  74.   (or (rtl-procedure/%external-label procedure)
  75.       (let ((label (generate-label (rtl-procedure/name procedure))))
  76.     (set-rtl-procedure/%external-label! procedure label)
  77.     label)))
  78.  
  79. (define-structure (rtl-continuation
  80.            (conc-name rtl-continuation/)
  81.            (constructor make-rtl-continuation
  82.                 (rgraph label entry-edge
  83.                     next-continuation-offset
  84.                     debugging-info))
  85.            (print-procedure
  86.             (standard-unparser (symbol->string 'RTL-CONTINUATION)
  87.               (lambda (state continuation)
  88.             (unparse-object
  89.              state
  90.              (rtl-continuation/label continuation))))))
  91.   (rgraph false read-only true)
  92.   (label false read-only true)
  93.   (entry-edge false read-only true)
  94.   (next-continuation-offset false read-only true)
  95.   (debugging-info false read-only true))
  96.  
  97. (define-integrable (rtl-continuation/entry-node continuation)
  98.   (edge-right-node (rtl-continuation/entry-edge continuation)))
  99.  
  100. (define (make/label->object expression procedures continuations)
  101.   (let ((hash-table
  102.      (make-eq-hash-table
  103.       (+ (if expression 1 0)
  104.          (length procedures)
  105.          (length continuations)))))
  106.     (if expression
  107.     (hash-table/put! hash-table
  108.              (rtl-expr/label expression)
  109.              expression))
  110.     (for-each (lambda (procedure)
  111.         (hash-table/put! hash-table
  112.                  (rtl-procedure/label procedure)
  113.                  procedure))
  114.           procedures)
  115.     (for-each (lambda (continuation)
  116.         (hash-table/put! hash-table
  117.                  (rtl-continuation/label continuation)
  118.                  continuation))
  119.           continuations)
  120.     (lambda (label)
  121.       (let ((datum (hash-table/get hash-table label #f)))
  122.     (if (not datum)
  123.         (error "Undefined label:" label))
  124.     datum))))