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 / cfg1.scm < prev    next >
Text File  |  1999-01-02  |  5KB  |  167 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: cfg1.scm,v 4.5 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987, 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. ;;;; Control Flow Graph Abstraction
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; Node Datatypes
  27.  
  28. (define cfg-node-tag (make-vector-tag false 'CFG-NODE false))
  29. (define cfg-node? (tagged-vector/subclass-predicate cfg-node-tag))
  30. (define-vector-slots node 1 generation alist previous-edges)
  31.  
  32. (set-vector-tag-description!
  33.  cfg-node-tag
  34.  (lambda (node)
  35.    (descriptor-list node generation alist previous-edges)))
  36.  
  37. (define snode-tag (make-vector-tag cfg-node-tag 'SNODE false))
  38. (define snode? (tagged-vector/subclass-predicate snode-tag))
  39. (define-vector-slots snode 4 next-edge)
  40.  
  41. ;;; converted to a macro.
  42. ;;; (define (make-snode tag . extra)
  43. ;;;   (list->vector (cons* tag false '() '() false extra)))
  44.  
  45. (set-vector-tag-description!
  46.  snode-tag
  47.  (lambda (snode)
  48.    (append! ((vector-tag-description (vector-tag-parent snode-tag)) snode)
  49.         (descriptor-list snode next-edge))))
  50.  
  51. (define pnode-tag (make-vector-tag cfg-node-tag 'PNODE false))
  52. (define pnode? (tagged-vector/subclass-predicate pnode-tag))
  53. (define-vector-slots pnode 4 consequent-edge alternative-edge)
  54.  
  55. ;;; converted to a macro.
  56. ;;; (define (make-pnode tag . extra)
  57. ;;;   (list->vector (cons* tag false '() '() false false extra)))
  58.  
  59. (set-vector-tag-description!
  60.  pnode-tag
  61.  (lambda (pnode)
  62.    (append! ((vector-tag-description (vector-tag-parent pnode-tag)) pnode)
  63.         (descriptor-list pnode consequent-edge alternative-edge))))
  64.  
  65. (define (add-node-previous-edge! node edge)
  66.   (set-node-previous-edges! node (cons edge (node-previous-edges node))))
  67.  
  68. (define (delete-node-previous-edge! node edge)
  69.   (set-node-previous-edges! node (delq! edge (node-previous-edges node))))
  70.  
  71. (define-integrable (snode-next snode)
  72.   (edge-next-node (snode-next-edge snode)))
  73.  
  74. (define-integrable (pnode-consequent pnode)
  75.   (edge-next-node (pnode-consequent-edge pnode)))
  76.  
  77. (define-integrable (pnode-alternative pnode)
  78.   (edge-next-node (pnode-alternative-edge pnode)))
  79.  
  80. (define (cfg-node-get node key)
  81.   (let ((entry (assq key (node-alist node))))
  82.     (and entry
  83.      (cdr entry))))
  84.  
  85. (define (cfg-node-put! node key item)
  86.   (let ((entry (assq key (node-alist node))))
  87.     (if entry
  88.     (set-cdr! entry item)
  89.     (set-node-alist! node (cons (cons key item) (node-alist node))))))
  90.  
  91. (define (cfg-node-remove! node key)
  92.   (set-node-alist! node (del-assq! key (node-alist node))))
  93.  
  94. ;;;; Edge Datatype
  95.  
  96. (define-structure (edge (type vector))
  97.   left-node
  98.   left-connect
  99.   right-node)
  100.  
  101. (define (create-edge! left-node left-connect right-node)
  102.   (let ((edge (make-edge left-node left-connect right-node)))
  103.     (if left-node
  104.     (left-connect left-node edge))
  105.     (if right-node
  106.     (add-node-previous-edge! right-node edge))
  107.     edge))
  108.  
  109. (define-integrable (node->edge node)
  110.   (create-edge! false false node))
  111.  
  112. (define (edge-next-node edge)
  113.   (and edge (edge-right-node edge)))
  114.  
  115. (define (edge-connect-left! edge left-node left-connect)
  116.   (if (edge-left-node edge)
  117.       (error "Attempt to doubly connect left node of edge" edge))
  118.   (if left-node
  119.       (begin
  120.     (set-edge-left-node! edge left-node)
  121.     (set-edge-left-connect! edge left-connect)
  122.     (left-connect left-node edge))))
  123.  
  124. (define (edge-connect-right! edge right-node)
  125.   (if (edge-right-node edge)
  126.       (error "Attempt to doubly connect right node of edge" edge))
  127.   (if right-node
  128.       (begin
  129.     (set-edge-right-node! edge right-node)
  130.     (add-node-previous-edge! right-node edge))))
  131.  
  132. (define (edge-disconnect-left! edge)
  133.   (let ((left-node (edge-left-node edge))
  134.     (left-connect (edge-left-connect edge)))
  135.     (if left-node
  136.     (begin
  137.       (set-edge-left-node! edge false)
  138.       (set-edge-left-connect! edge false)
  139.       (left-connect left-node false)))))
  140.  
  141. (define (edge-disconnect-right! edge)
  142.   (let ((right-node (edge-right-node edge)))
  143.     (if right-node
  144.     (begin
  145.       (set-edge-right-node! edge false)
  146.       (delete-node-previous-edge! right-node edge)))))
  147.  
  148. (define (edge-disconnect! edge)
  149.   (edge-disconnect-left! edge)
  150.   (edge-disconnect-right! edge))
  151.  
  152. (define (edge-replace-left! edge left-node left-connect)
  153.   (edge-disconnect-left! edge)
  154.   (edge-connect-left! edge left-node left-connect))
  155.  
  156. (define (edge-replace-right! edge right-node)
  157.   (edge-disconnect-right! edge)
  158.   (edge-connect-right! edge right-node))
  159.  
  160. (define (edges-connect-right! edges right-node)
  161.   (for-each (lambda (edge) (edge-connect-right! edge right-node)) edges))
  162.  
  163. (define (edges-disconnect-right! edges)
  164.   (for-each edge-disconnect-right! edges))
  165.  
  166. (define (edges-replace-right! edges right-node)
  167.   (for-each (lambda (edge) (edge-replace-right! edge right-node)) edges))