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 / constr.scm < prev    next >
Text File  |  1999-01-02  |  8KB  |  258 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: constr.scm,v 1.3 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 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. ;;; Procedures for managing a set of ordering constraints
  23.  
  24. (define-structure (constraint
  25.            (conc-name constraint/)
  26.            (constructor
  27.             &make-constraint (element)))
  28.   (element false read-only true)
  29.   (graph-head false)
  30.   (afters '())
  31.   (generation)
  32.   (closed? true))
  33.  
  34. (define-structure (constraint-graph
  35.            (conc-name constraint-graph/)
  36.            (constructor make-constraint-graph ()))
  37.   (entry-nodes '())
  38.   (closed? true))
  39.  
  40. (define (make-constraint element #!optional graph-head afters)
  41.   (let ((constraint (&make-constraint element)))
  42.     (if (and (not (default-object? graph-head))
  43.          (constraint-graph? graph-head))
  44.     (begin
  45.       (set-constraint/graph-head! constraint graph-head)
  46.       (set-constraint-graph/entry-nodes!
  47.        graph-head
  48.        (cons constraint (constraint-graph/entry-nodes graph-head)))))
  49.     (if (not (default-object? afters))
  50.     (for-each
  51.      (lambda (after) (constraint-add! constraint after))
  52.      afters))
  53.     constraint))
  54.  
  55. (define (find-constraint element graph-head)
  56.  
  57.   (define (loop children)
  58.     (if (pair? children)
  59.     (or (search (car children))
  60.         (loop (cdr children)))
  61.     false))
  62.  
  63.   (define (search constraint)
  64.     (if (eqv? element (constraint/element constraint))
  65.     constraint
  66.     (loop (constraint/afters constraint))))
  67.   
  68.   (loop (constraint-graph/entry-nodes graph-head)))
  69.  
  70. (define (find-or-make-constraint element graph-head
  71.                  #!optional afters)
  72.   (or (find-constraint element graph-head)
  73.       (if (default-object? afters)
  74.       (make-constraint element graph-head)
  75.       (make-constraint element graph-head afters))))
  76.           
  77.  
  78. (define (constraint-add! before after)
  79.   (if (eq? (constraint/element before) (constraint/element after))
  80.       (error "A node cannot be constrained to come after itself" after))
  81.   (set-constraint/afters! before (cons after (constraint/afters before)))
  82.   (let ((c-graph (constraint/graph-head after)))
  83.     (if c-graph
  84.     (set-constraint-graph/entry-nodes! 
  85.      c-graph
  86.      (delq! after (constraint-graph/entry-nodes c-graph)))))
  87.   (set-constraint/closed?! before false)
  88.   (if (constraint/graph-head before)
  89.       (set-constraint-graph/closed?!
  90.        (constraint/graph-head before)
  91.        false)))
  92.  
  93. (define (add-constraint-element! before-element after-element
  94.                  graph-head)
  95.   (find-or-make-constraint
  96.    before-element
  97.    graph-head
  98.    (list after-element)))
  99.  
  100. (define (add-constraint-set! befores afters graph-head)
  101.   (let ((after-constraints
  102.      (map (lambda (after)
  103.         (find-or-make-constraint after graph-head))
  104.           afters)))
  105.     (for-each
  106.      (lambda (before)
  107.        (find-or-make-constraint before graph-head after-constraints))
  108.      befores)))
  109.  
  110. (define (close-constraint-graph! c-graph)
  111.   (with-new-constraint-marks
  112.    (lambda ()
  113.      (for-each close-constraint-node!
  114.            (constraint-graph/entry-nodes c-graph))))
  115.   (set-constraint-graph/closed?! c-graph true))
  116.  
  117. (define (close-constraint-node! node)
  118.   (with-new-constraint-marks
  119.    (lambda ()
  120.      (&close-constraint-node! node))))
  121.  
  122. (define (&close-constraint-node! node)
  123.   (transitively-close-dag!
  124.    node
  125.    constraint/afters
  126.    (lambda (before afters)
  127.      (set-constraint/afters!
  128.       before
  129.       (append
  130.        (constraint/afters before)
  131.        (if (memq node afters)
  132.        (error
  133.         "Illegal cycle in constraint graph involving node:"
  134.         node)
  135.        afters))))
  136.    constraint-marked?
  137.    (lambda (node)
  138.      (constraint-mark! node)
  139.      (set-constraint/closed?! node true))))
  140.  
  141. (define (transitively-close-dag! node select update! marked? mark!)
  142.   (let transitively-close*! ((node node))
  143.     (let ((elements (select node)))
  144.       (if (or (null? elements) (marked? node))
  145.       elements
  146.       (begin
  147.         (mark! node)
  148.         (update! node (append-map transitively-close*! elements))
  149.         (select node))))))
  150.  
  151. (define (order-per-constraints elements constraint-graph)
  152.   (order-per-constraints/extracted
  153.    elements
  154.    constraint-graph
  155.    identity-procedure))
  156.  
  157. (define (order-per-constraints/extracted things
  158.                      constraint-graph
  159.                      element-extractor)
  160. ;;; This orders a set of things according to the constraints where the
  161. ;;; things are not elements of the constraint-graph nodes but elements
  162. ;;; can be extracted from the things by element-extractor
  163.   (let loop ((linearized-constraints
  164.           (reverse-postorder
  165.            (constraint-graph/entry-nodes constraint-graph)
  166.            constraint/afters
  167.            with-new-constraint-marks
  168.            constraint-mark!
  169.            constraint-marked?))
  170.          (things things)
  171.          (result '()))
  172.     (if (and (pair? linearized-constraints)
  173.          (pair? things))
  174.     (let ((match (list-search-positive
  175.              things
  176.                (lambda (thing)
  177.              (eqv?
  178.               (constraint/element
  179.                (car linearized-constraints))
  180.               (element-extractor thing))))))
  181.       (loop (cdr linearized-constraints)
  182.         (delv match things)
  183.         (if (and match
  184.              (not (memv match result)))
  185.             (cons match result)
  186.             result)))
  187.     (reverse! result))))
  188.  
  189. (define (legal-ordering-per-constraints? element-ordering constraint-graph)
  190.   (let loop ((ordering element-ordering)
  191.          (nodes (constraint-graph/entry-nodes constraint-graph)))
  192.  
  193.     (define (depth-first-search? node)
  194.       (if (or (null? node) (constraint-marked? node))
  195.       false
  196.       (begin
  197.         (constraint-mark! node)
  198.         (if (eq? (constraint/element node) (car ordering))
  199.         (loop (cdr ordering) (constraint/afters node))
  200.         (multiple-search? (constraint/afters node))))))
  201.  
  202.     (define (multiple-search? nodes)
  203.       (if (null? nodes)
  204.       false
  205.       (or (depth-first-search? (car nodes))
  206.           (multiple-search? (cdr nodes)))))
  207.  
  208.     (if (null? ordering)
  209.     true
  210.     (with-new-constraint-marks
  211.      (lambda ()
  212.        (multiple-search? nodes))))))
  213.  
  214. (define (reverse-postorder entry-nodes get-children
  215.                with-new-node-marks node-mark!
  216.                node-marked?)
  217.  
  218.   (define result)
  219.   
  220.   (define (loop node)
  221.     (node-mark! node)
  222.     (for-each next (get-children node))
  223.     (set! result (cons node result)))
  224.  
  225.   (define (next node)
  226.     (and node
  227.      (not (node-marked? node))
  228.      (loop node)))
  229.     
  230.   (define (doit node)
  231.     (set! result '())
  232.     (loop node)
  233.     (reverse! result))
  234.  
  235.   (with-new-node-marks
  236.    (lambda ()
  237.      (append-map! doit entry-nodes))))
  238.  
  239. (define *constraint-generation*)
  240.  
  241. (define (with-new-constraint-marks thunk)
  242.   (fluid-let ((*constraint-generation* (make-constraint-generation)))
  243.     (thunk)))
  244.  
  245. (define make-constraint-generation
  246.   (let ((constraint-generation 0))
  247.     (named-lambda (make-constraint/generation)
  248.       (let ((value constraint-generation))
  249.     (set! constraint-generation (1+ constraint-generation))
  250.     value))))
  251.  
  252. (define (constraint-marked? constraint)
  253.   (eq? (constraint/generation constraint) *constraint-generation*))
  254.  
  255. (define (constraint-mark! constraint)
  256.   (set-constraint/generation! constraint *constraint-generation*))
  257.  
  258.