You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
106 lines
4.1 KiB
Scheme
106 lines
4.1 KiB
Scheme
27 years ago
|
; ======================================================================
|
||
|
|
; find-nonempty-tvars
|
||
|
|
;
|
||
|
|
; Input: lower : (listof Tvar) with non-empty Tvar_L
|
||
|
|
; upper : (listof Tvar) with non-empty Tvar_U
|
||
|
|
;
|
||
|
|
; Finds non-empty non-terminals
|
||
|
|
; returns (listof Tvar)
|
||
|
|
; ======================================================================
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
||
|
|
;
|
||
|
|
; This program is free software; you can redistribute it and/or
|
||
|
|
; modify it under the terms of the GNU General Public License
|
||
|
|
; version 2 as published by the Free Software Foundation.
|
||
|
|
;
|
||
|
|
; This program is distributed in the hope that it will be useful,
|
||
|
|
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
; GNU General Public License for more details.
|
||
|
|
;
|
||
|
|
; You should have received a copy of the GNU General Public License
|
||
|
|
; along with this program; if not, write to the Free Software
|
||
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (find-nonempty-tvars lower upper)
|
||
|
|
(pretty-debug-min
|
||
|
|
`(find-nonempty-tvars ,(map Tvar-name lower) ,(map Tvar-name upper)))
|
||
|
|
|
||
|
|
(let*-vals ( [(reached-U? set-reached-U!) (alloc-Tvar-field)]
|
||
|
|
[(reached-L? set-reached-L!) (alloc-Tvar-field)]
|
||
|
|
[(reached-AV set-reached-AV!) (alloc-AV-field)]
|
||
|
|
[num-AV 0]
|
||
|
|
[list-tvar '()])
|
||
|
|
(letrec
|
||
|
|
( [add-Tvar!
|
||
|
|
(lambda (tvar)
|
||
|
|
(set! list-tvar (cons tvar list-tvar)))]
|
||
|
|
[walk-AV
|
||
|
|
(lambda (AV)
|
||
|
|
(unless (reached-AV AV)
|
||
|
|
;; Walk it
|
||
|
|
(set-reached-AV! AV #t)
|
||
|
|
(match AV
|
||
|
|
[($ AV _ template _ fields+ fields-)
|
||
|
|
(vector-for-each walk-U fields+)
|
||
|
|
(when (follow-antimono-fields template)
|
||
|
|
(pretty-debug-min
|
||
|
|
`(walking-U
|
||
|
|
,(eq? template template-lam)
|
||
|
|
,(st:minimize-respect-assignable-part-of-fields)))
|
||
|
|
(vector-for-each walk-U fields-))])))]
|
||
|
|
[walk-U
|
||
|
|
(lambda (tvar)
|
||
|
|
(unless (reached-U? tvar)
|
||
|
|
(unless (reached-L? tvar) (add-Tvar! tvar))
|
||
|
|
(set-reached-U! tvar #t)
|
||
|
|
(pretty-debug-min `(walk-U ,(Tvar-name tvar)))
|
||
|
|
(for-each walk-AV (get-Tvar-objs tvar))
|
||
|
|
(for-each walk-U (Tvar-edgefrom tvar))))]
|
||
|
|
[walk-L
|
||
|
|
(lambda (tvar)
|
||
|
|
(unless (reached-L? tvar)
|
||
|
|
(unless (reached-U? tvar) (add-Tvar! tvar))
|
||
|
|
(set-reached-L! tvar #t)
|
||
|
|
(pretty-debug-min `(walk-L ,(Tvar-name tvar)))
|
||
|
|
;; Have to_L -> tvar_L
|
||
|
|
(for-each walk-L (Tvar-edgeto tvar))
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ con _ _ field-no tvar2 sign misc)
|
||
|
|
;; Have tvar2_L -> rng(tvar_L)
|
||
|
|
;; or tvar2_U -> dom(tvar_L)
|
||
|
|
(if sign
|
||
|
|
(walk-L tvar2)
|
||
|
|
(walk-U tvar2))]
|
||
|
|
[($ con-filter _ filter tvar2)
|
||
|
|
;; Have tvar2_L -> tvar_L
|
||
|
|
(walk-L tvar2)])
|
||
|
|
(Tvar-constraints tvar))))])
|
||
|
|
(for-each walk-U upper)
|
||
|
|
(for-each walk-L lower)
|
||
|
|
'(printf "walk-reachable-constraints allocated ~s tvar, ~s AV~n"
|
||
|
|
(length list-tvar) num-AV)
|
||
|
|
|
||
|
|
(values list-tvar reached-L? reached-U?))))
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
|
||
|
|
(define (copy-nonempty-tvars lower upper)
|
||
|
|
(let*-vals
|
||
|
|
( [(live-tvars _ _) (find-nonempty-tvars lower upper)]
|
||
|
|
[(tvar-live? set-tvar-live!) (alloc-Tvar-field)])
|
||
|
|
(for-each mk-Tvar-NTs! live-tvars)
|
||
|
|
(for-each (lambda (tvar) (set-tvar-live! tvar #t)) live-tvars)
|
||
|
|
(copy-constraints-equiv!
|
||
|
|
(append lower upper live-tvars)
|
||
|
|
tvar-live?
|
||
|
|
(append
|
||
|
|
(map Tvar-L live-tvars)
|
||
|
|
(map Tvar-U live-tvars))
|
||
|
|
(lambda (tvar) (list tvar))
|
||
|
|
(lambda (AV) (list AV)))))
|