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.
581 lines
21 KiB
Scheme
581 lines
21 KiB
Scheme
27 years ago
|
; ======================================================================
|
||
|
|
; copy-live-constraints
|
||
|
|
;
|
||
|
|
; Input: lower : list Tvar
|
||
|
|
; upper : list Tvar
|
||
|
|
;
|
||
|
|
; Copies live constraints
|
||
|
|
; returns list-nu Tvar->nu
|
||
|
|
; ======================================================================
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; 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 (copy-live-constraints lower upper)
|
||
|
|
|
||
|
|
(pretty-debug-min
|
||
|
|
`(copy-live-constraints ,(map Tvar-name lower) ,(map Tvar-name upper)))
|
||
|
|
|
||
|
|
(let*-vals
|
||
|
|
( [(live-nts live-nt? live-tvars live-tvar? _ _ _)
|
||
|
|
(calc-live-tvars-nts lower upper #f)])
|
||
|
|
|
||
|
|
(copy-constraints-equiv!
|
||
|
|
(append lower upper live-tvars)
|
||
|
|
live-tvar? live-nts
|
||
|
|
(lambda (tvar) (list tvar))
|
||
|
|
(lambda (AV) (list AV)))))
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
|
||
|
|
(define (copy-live-constraints-noe lower upper)
|
||
|
|
|
||
|
|
(pretty-debug-min
|
||
|
|
`(copy-live-constraints-noe
|
||
|
|
,(map Tvar-name lower) ,(map Tvar-name upper)))
|
||
|
|
|
||
|
|
(let*-vals
|
||
|
|
( [(live-nts live-nt? live-tvars live-tvar? _ _ _)
|
||
|
|
(calc-live-tvars-nts lower upper #t)]
|
||
|
|
[(get-nu-Tvar set-nu-Tvar!) (alloc-Tvar-field)]
|
||
|
|
[list-nuTvar
|
||
|
|
(map (lambda (Tvar)
|
||
|
|
(let ([nu (mk-Tvar 'min-live)])
|
||
|
|
(set-nu-Tvar! Tvar nu)
|
||
|
|
nu))
|
||
|
|
live-tvars)]
|
||
|
|
[dummy-tvars
|
||
|
|
(copy-constraints-noe! live-tvar? live-nts get-nu-Tvar lower)])
|
||
|
|
|
||
|
|
(values
|
||
|
|
(append dummy-tvars list-nuTvar)
|
||
|
|
get-nu-Tvar)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
; calc-live-tvars-nts
|
||
|
|
;
|
||
|
|
; Calculates live Tvars and NTs
|
||
|
|
; Input: lower : list Tvar
|
||
|
|
; upper : list Tvar
|
||
|
|
;
|
||
|
|
; Uses find-nonempty-nts-rhs-nts to find nonempty nts and sources
|
||
|
|
; Walk "forward" in grammar using rhs-nts from crossover and AV-w/-const
|
||
|
|
; to calculate live
|
||
|
|
;
|
||
|
|
; Returns (values live-nts live-nt? live-tvars live-tvar?
|
||
|
|
; AV-w/-const crossover rhs-nts)
|
||
|
|
|
||
|
|
(define (calc-live-tvars-nts lower upper inline-epsilon)
|
||
|
|
|
||
|
|
(pretty-debug-min
|
||
|
|
`(calc-live-tvars-nts ,inline-epsilon
|
||
|
|
,(map Tvar-name lower) ,(map Tvar-name upper)))
|
||
|
|
|
||
|
|
(let*-vals
|
||
|
|
( [t (lambda (s)
|
||
|
|
(when timing-min
|
||
|
|
(min-record-progress (cons 'calc-live-tvars-nts s))))]
|
||
|
|
[_ (t 0)]
|
||
|
|
[(rhs-nts crossover AV-w/-const)
|
||
|
|
(find-nonempty-nts-rhs-nts lower upper inline-epsilon)]
|
||
|
|
[_ (t 1)]
|
||
|
|
[(live-nt? set-live-nt! get-live-nts) (field->set alloc-NT-field)]
|
||
|
|
[_ (t 2)]
|
||
|
|
|
||
|
|
;; --------------------------------------------------
|
||
|
|
;; Walk forward from crossover and AV-w/-const, recording nts
|
||
|
|
|
||
|
|
[_ (letrec ([mark-live
|
||
|
|
(lambda (nt)
|
||
|
|
(unless (eq? nt #t)
|
||
|
|
;;(pretty-print `(mark-live ,(nt->sym nt)))
|
||
|
|
(unless (live-nt? nt)
|
||
|
|
(set-live-nt! nt)
|
||
|
|
(when (rhs-nts nt)
|
||
|
|
(for-each mark-live (rhs-nts nt))))))])
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (Tvar)
|
||
|
|
(mark-live (Tvar-U Tvar))
|
||
|
|
(mark-live (Tvar-L Tvar)))
|
||
|
|
crossover)
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (AV) (mark-live (AV-U AV)))
|
||
|
|
AV-w/-const)
|
||
|
|
|
||
|
|
(pretty-debug-min `(live-nt ,(map nt->sym (get-live-nts)))))]
|
||
|
|
[_ (t 3)]
|
||
|
|
|
||
|
|
;; --------------------------------------------------
|
||
|
|
;; Have in (get-live-nts) all nts that are reached and non-empty
|
||
|
|
;; Calc live Tvar
|
||
|
|
|
||
|
|
[(live-tvar? set-live-tvar! get-live-tvars)
|
||
|
|
(field->set alloc-Tvar-field)]
|
||
|
|
[_ (t 4)]
|
||
|
|
[_ (begin
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ NT tvar) (when (Tvar? tvar) (set-live-tvar! tvar))])
|
||
|
|
(get-live-nts))
|
||
|
|
(for-each set-live-tvar! lower)
|
||
|
|
(for-each set-live-tvar! upper))]
|
||
|
|
[_ (t 5)]
|
||
|
|
[_ (pretty-debug-min `(live-Tvar ,(map Tvar-name (get-live-tvars))))])
|
||
|
|
|
||
|
|
(pretty-debug-min
|
||
|
|
`(calc-live-tvars-nts-results
|
||
|
|
,(map (lambda (nt)
|
||
|
|
`(nt-rhs ,(nt->sym nt)
|
||
|
|
,(map (lambda (nt) (or (eq? nt #t) (nt->sym nt)))
|
||
|
|
(rhs-nts nt))))
|
||
|
|
(get-live-nts))))
|
||
|
|
|
||
|
|
(values
|
||
|
|
(get-live-nts) live-nt?
|
||
|
|
(get-live-tvars) live-tvar?
|
||
|
|
AV-w/-const
|
||
|
|
crossover
|
||
|
|
rhs-nts
|
||
|
|
)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (follow-antimono-fields template)
|
||
|
|
(or
|
||
|
|
(eq? template template-lam)
|
||
|
|
(eq? template template-unit)
|
||
|
|
(eq? template template-internal-class)
|
||
|
|
(st:minimize-respect-assignable-part-of-fields)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
; find-nonempty-nts-rhs-nts
|
||
|
|
;
|
||
|
|
; Calculates non-empty Tvars, NTs.
|
||
|
|
; For each non-empty NT, finds all rhs-nts NT' such that NT -> x.NT'
|
||
|
|
|
||
|
|
; Input: lower : (listof Tvar)
|
||
|
|
; upper : (listof Tvar)
|
||
|
|
;
|
||
|
|
; Returns (values rhs-nts crossover-tvars AV-w/-const)
|
||
|
|
;
|
||
|
|
; Walks "backwards" in grammer to find nonempty NTs
|
||
|
|
; Keeps track of rhs-nts on the way
|
||
|
|
;
|
||
|
|
; crossover is the set of Tvars tvar such that
|
||
|
|
; both L(tvar_L) and L(tvar_U) are nonempty
|
||
|
|
|
||
|
|
;; #### Always looks at assignable fields ...
|
||
|
|
|
||
|
|
(define (find-nonempty-nts-rhs-nts lower upper inline-epsilon)
|
||
|
|
(pretty-debug-min
|
||
|
|
`(find-nonempty-tvars-nts-rhs-nts ,inline-epsilon
|
||
|
|
,(map Tvar-name lower) ,(map Tvar-name upper)))
|
||
|
|
|
||
|
|
(let*-vals ( [(reached-tvar? set-reached-tvar!) (alloc-Tvar-field)]
|
||
|
|
[(reached-AV? set-reached-AV!) (alloc-AV-field)]
|
||
|
|
[(rhs-nts set-rhs-nts!) (alloc-NT-field)]
|
||
|
|
[add-rhs-nt!
|
||
|
|
(lambda (nt src) (set-rhs-nts! nt (cons src (rhs-nts nt))))]
|
||
|
|
[crossover '()]
|
||
|
|
;; crossover is set of tvars with tvar_L and tvar_U nonempty
|
||
|
|
[AV-w/-const '()]
|
||
|
|
)
|
||
|
|
(letrec
|
||
|
|
( [add-crossover!
|
||
|
|
(lambda (tvar)
|
||
|
|
(set! crossover (cons tvar crossover)))]
|
||
|
|
[walk-AV
|
||
|
|
(lambda (AV src)
|
||
|
|
(pretty-debug-min `(walk-AV ,(AV-num AV) ,(nt->sym src)))
|
||
|
|
(if (reached-AV? AV)
|
||
|
|
(add-rhs-nt! (AV-U AV) src)
|
||
|
|
;; Walk it
|
||
|
|
(begin
|
||
|
|
(set-reached-AV! AV #t)
|
||
|
|
(mk-AV-NTs! AV)
|
||
|
|
(let ([nt (AV-U AV)])
|
||
|
|
(set-rhs-nts! nt (list src))
|
||
|
|
(match AV
|
||
|
|
[($ AV _ (and template ($ template _ _ _ ref))
|
||
|
|
misc fields+ fields-)
|
||
|
|
(when (or
|
||
|
|
(zero? (vector-length ref))
|
||
|
|
;; the following are lazy
|
||
|
|
;; ie (box empty) = empty
|
||
|
|
;; but (empty -> empty) != empty
|
||
|
|
(eq? template template-lam)
|
||
|
|
(eq? template template-unit)
|
||
|
|
(eq? template template-internal-class)
|
||
|
|
(eq? template template-ivarset)
|
||
|
|
)
|
||
|
|
(set! AV-w/-const (cons AV AV-w/-const)))
|
||
|
|
(vector-for-each
|
||
|
|
(lambda (f) (walk-U f nt))
|
||
|
|
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
|
||
|
|
(lambda (f) (walk-L f nt))
|
||
|
|
fields-))])))))]
|
||
|
|
[reach-tvar
|
||
|
|
(lambda (tvar)
|
||
|
|
(unless (reached-tvar? tvar)
|
||
|
|
(set-reached-tvar! tvar #t)
|
||
|
|
(mk-Tvar-NTs! tvar)))]
|
||
|
|
[walk-U
|
||
|
|
(lambda (tvar src)
|
||
|
|
(let
|
||
|
|
([f
|
||
|
|
(lambda (tvar)
|
||
|
|
(reach-tvar tvar)
|
||
|
|
(pretty-debug-min `(walk-U ,(Tvar-name tvar) ,(nt->sym src)))
|
||
|
|
(let ([nt (Tvar-U tvar)])
|
||
|
|
(if (rhs-nts nt)
|
||
|
|
(add-rhs-nt! nt src)
|
||
|
|
;; Walk it
|
||
|
|
(begin
|
||
|
|
(set-rhs-nts! nt (list src))
|
||
|
|
(when (rhs-nts (Tvar-L tvar)) (add-crossover! tvar))
|
||
|
|
(pretty-debug-min `(walk-U ,(Tvar-name tvar)))
|
||
|
|
(for-each
|
||
|
|
(lambda (AV) (walk-AV AV nt))
|
||
|
|
(get-Tvar-objs tvar))
|
||
|
|
'(unless inline-epsilon
|
||
|
|
(for-each
|
||
|
|
(lambda (from)
|
||
|
|
(walk-U from nt))
|
||
|
|
(Tvar-edgefrom tvar)))))))])
|
||
|
|
|
||
|
|
'(if inline-epsilon
|
||
|
|
;; really want to walk all tvar2 st tvar2_U -> tvar_U
|
||
|
|
(for-each f (Tvar-transitive-edgefrom tvar))
|
||
|
|
(f tvar))
|
||
|
|
(f tvar)))]
|
||
|
|
|
||
|
|
[walk-L
|
||
|
|
(lambda (tvar src)
|
||
|
|
(let
|
||
|
|
([f (lambda (tvar)
|
||
|
|
(reach-tvar tvar)
|
||
|
|
(pretty-debug-min
|
||
|
|
`(walk-L ,(Tvar-name tvar) ,(nt->sym src)))
|
||
|
|
(let ([nt (Tvar-L tvar)])
|
||
|
|
(if (rhs-nts nt)
|
||
|
|
(add-rhs-nt! nt src)
|
||
|
|
;; Walk it
|
||
|
|
(begin
|
||
|
|
(set-rhs-nts! nt (list src))
|
||
|
|
(when (rhs-nts (Tvar-U tvar)) (add-crossover! tvar))
|
||
|
|
(pretty-debug-min `(walk-L ,(Tvar-name tvar)))
|
||
|
|
|
||
|
|
(unless inline-epsilon
|
||
|
|
(for-each
|
||
|
|
(lambda (to)
|
||
|
|
;; Have to_L -> tvar_L
|
||
|
|
(walk-L to nt))
|
||
|
|
(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 nt)
|
||
|
|
(walk-U tvar2 nt))]
|
||
|
|
[($ con-filter _ filter tvar2)
|
||
|
|
;; Have tvar2_L -> tvar_L
|
||
|
|
(unless inline-epsilon (walk-L tvar2 nt))])
|
||
|
|
(Tvar-constraints tvar))))))])
|
||
|
|
'(if inline-epsilon
|
||
|
|
;; really want to walk all tvar2 st tvar2_L -> tvar_L
|
||
|
|
(for-each f (Tvar-transitive-edgeto tvar))
|
||
|
|
(f tvar))
|
||
|
|
(f tvar)))])
|
||
|
|
|
||
|
|
(for-each (lambda (tvar) (walk-U tvar #t)) upper)
|
||
|
|
(for-each (lambda (tvar) (walk-L tvar #t)) lower)
|
||
|
|
|
||
|
|
(min-record-progress 'find-nonempty-nts-rhs-nts-done)
|
||
|
|
(: rhs-nts (NT -> (union NT true)))
|
||
|
|
|
||
|
|
(pretty-debug-min
|
||
|
|
`(find-nonempty-nts-rhs-nts-returns
|
||
|
|
,(map AV-num AV-w/-const)
|
||
|
|
,(map Tvar-name crossover)))
|
||
|
|
|
||
|
|
(values
|
||
|
|
(lambda (nt)
|
||
|
|
(let ([r (rhs-nts nt)])
|
||
|
|
(pretty-debug-min
|
||
|
|
`(rhs-nts ,(nt->sym nt)
|
||
|
|
,(map (lambda (nt) (or (eq? nt #t) (nt->sym nt))) r)))
|
||
|
|
r))
|
||
|
|
crossover
|
||
|
|
AV-w/-const))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
; copy-constraints!
|
||
|
|
;
|
||
|
|
; tvar->equiv and AV->equiv describe an equivalence relation on tvars and AVs
|
||
|
|
;
|
||
|
|
; Copies the contents of a set of Tvars
|
||
|
|
; Takes care not to duplicate AVs
|
||
|
|
; returns (values nu-tvars tvar->nu-tvar)
|
||
|
|
; live-tvars should include lower and upper, and may contain duplicates
|
||
|
|
|
||
|
|
(define (copy-constraints-equiv!
|
||
|
|
live-tvars live-tvar? live-nts
|
||
|
|
tvar->equiv AV->equiv)
|
||
|
|
|
||
|
|
(pretty-debug-min `(copy-constraints-equiv! ,(map nt->sym live-nts)))
|
||
|
|
(let*-vals
|
||
|
|
( [t (lambda (s)
|
||
|
|
(when timing-min
|
||
|
|
(min-record-progress (cons 'copy-constraint-equivs! s))))]
|
||
|
|
[_ (t 0)]
|
||
|
|
|
||
|
|
;; --- Allocate new tvar
|
||
|
|
[(Tvar-nuTvar set-Tvar-nuTvar!) (alloc-Tvar-field)]
|
||
|
|
[list-nu-tvars '()]
|
||
|
|
[_ (for-each
|
||
|
|
(lambda (tvar)
|
||
|
|
(unless (Tvar-nuTvar tvar)
|
||
|
|
(let ([nu (mk-Tvar 'copy-constraints!)])
|
||
|
|
(set! list-nu-tvars (cons nu list-nu-tvars))
|
||
|
|
(for-each
|
||
|
|
(lambda (tvar2) (set-Tvar-nuTvar! tvar2 nu))
|
||
|
|
(tvar->equiv tvar)))))
|
||
|
|
live-tvars)]
|
||
|
|
[_ (t 1)]
|
||
|
|
|
||
|
|
[Tvar->nuTvar
|
||
|
|
(lambda (Tvar)
|
||
|
|
(if (live-tvar? Tvar)
|
||
|
|
(let ([nu (Tvar-nuTvar Tvar)])
|
||
|
|
(assert (Tvar? nu) 'Tvar->nuTvar
|
||
|
|
nu (live-tvar? Tvar) (memq Tvar live-tvars))
|
||
|
|
nu)
|
||
|
|
(let ([dummy (mk-Tvar 'dummy)])
|
||
|
|
(set! list-nu-tvars (cons dummy list-nu-tvars))
|
||
|
|
dummy)))]
|
||
|
|
|
||
|
|
[(AV-nuAV set-AV-nuAV!) (alloc-AV-field)]
|
||
|
|
[copy-AV
|
||
|
|
(lambda (AV)
|
||
|
|
(or
|
||
|
|
(AV-nuAV AV)
|
||
|
|
(match AV
|
||
|
|
[(and AV ($ AV _ template misc fields+ fields-))
|
||
|
|
(let*
|
||
|
|
( [nu-fields+ (vector-map Tvar->nuTvar fields+)]
|
||
|
|
[nu-fields- (vector-map Tvar->nuTvar fields-)]
|
||
|
|
[nu-AV (create-AV template misc nu-fields+ nu-fields-)])
|
||
|
|
(set-AV-nuAV! AV nu-AV)
|
||
|
|
(for-each
|
||
|
|
(lambda (eq-AV)
|
||
|
|
(when (and
|
||
|
|
(not (AV-nuAV eq-AV))
|
||
|
|
(eq? (AV-template eq-AV) template)
|
||
|
|
(vector-andmap2 eq? nu-fields+
|
||
|
|
(vector-map Tvar->nuTvar (AV-fields+ eq-AV)))
|
||
|
|
'(vector-andmap2 eq? nu-fields-
|
||
|
|
(vector-map Tvar->nuTvar (AV-fields- eq-AV))))
|
||
|
|
(set-AV-nuAV! eq-AV nu-AV)))
|
||
|
|
(AV->equiv AV))
|
||
|
|
nu-AV)])))]
|
||
|
|
[_ (t 1.1)])
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ NT source LU)
|
||
|
|
(when (Tvar? source)
|
||
|
|
(let ([dest (Tvar->nuTvar source)])
|
||
|
|
(case LU
|
||
|
|
[(U)
|
||
|
|
;; --- AVs
|
||
|
|
(for-each (lambda (AV) (new-AV! dest (copy-AV AV)))
|
||
|
|
(Tvar-objs source))]
|
||
|
|
[(L)
|
||
|
|
;; --- Constraints
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ con _ template field-no Tvar sign)
|
||
|
|
(when (live-tvar? Tvar)
|
||
|
|
(new-con! dest
|
||
|
|
(create-con template field-no
|
||
|
|
(Tvar->nuTvar Tvar) sign)))]
|
||
|
|
[($ con-filter _ filter Tvar)
|
||
|
|
(when (live-tvar? Tvar)
|
||
|
|
;; (new-con! dest
|
||
|
|
;; (create-con-filter filter (Tvar->nuTvar Tvar))
|
||
|
|
(new-edge! dest (Tvar->nuTvar Tvar)))])
|
||
|
|
(Tvar-constraints source))
|
||
|
|
|
||
|
|
;; --- Edges
|
||
|
|
(for-each
|
||
|
|
(lambda (Tvar2)
|
||
|
|
(when (live-tvar? Tvar2)
|
||
|
|
(let ([nu (Tvar->nuTvar Tvar2)])
|
||
|
|
(unless (eq? dest nu)
|
||
|
|
(new-edge! dest nu)))))
|
||
|
|
(Tvar-edgeto source))])))])
|
||
|
|
live-nts)
|
||
|
|
(t 2)
|
||
|
|
|
||
|
|
(pretty-debug-min
|
||
|
|
`(copy-constraints-equiv!
|
||
|
|
old->new
|
||
|
|
,(map
|
||
|
|
(lambda (tvar)
|
||
|
|
(list (Tvar-name tvar) (Tvar-name (Tvar-nuTvar tvar))))
|
||
|
|
live-tvars)))
|
||
|
|
|
||
|
|
|
||
|
|
(values list-nu-tvars Tvar-nuTvar)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
; copy-constraints-noe!
|
||
|
|
;
|
||
|
|
; Copies the contents of a set of Tvars
|
||
|
|
; Does closure under epsilon
|
||
|
|
; Takes care not to add duplicate AVs
|
||
|
|
; But may make many copies of the same AV in different Tvar
|
||
|
|
|
||
|
|
(define (copy-constraints-noe! live-tvar? live-nts Tvar-nuTvar lower)
|
||
|
|
(pretty-debug-min
|
||
|
|
`(copy-constraints-noe!
|
||
|
|
live-nts
|
||
|
|
,(map nt->sym live-nts)
|
||
|
|
lower
|
||
|
|
,(map Tvar-name lower)
|
||
|
|
conversion
|
||
|
|
,(map
|
||
|
|
(lambda (tvar)
|
||
|
|
(list (Tvar-name tvar) (Tvar-name (Tvar-nuTvar tvar))))
|
||
|
|
(filter Tvar? (map NT-tvar live-nts)))))
|
||
|
|
'(let*-vals
|
||
|
|
( [(AV-nuAV set-AV-nuAV!) (alloc-AV-field)]
|
||
|
|
[dummy-tvars '()]
|
||
|
|
[mk-dummy-tvar
|
||
|
|
(lambda ()
|
||
|
|
(let ([dummy (mk-Tvar 'dummy)])
|
||
|
|
(set! dummy-tvars (cons dummy dummy-tvars))
|
||
|
|
dummy))]
|
||
|
|
[Tvar->nuTvar
|
||
|
|
(lambda (Tvar)
|
||
|
|
(if (live-tvar? Tvar)
|
||
|
|
(Tvar-nuTvar Tvar)
|
||
|
|
(mk-dummy-tvar)))]
|
||
|
|
[table '()]
|
||
|
|
[Tvar*->nuTvar
|
||
|
|
(lambda (Tvar*)
|
||
|
|
(let* ( [Tvar* (if (Tvar? Tvar*) (list Tvar*) Tvar*)]
|
||
|
|
[nu-Tvar*
|
||
|
|
(list->set
|
||
|
|
(filter-map
|
||
|
|
(lambda (Tvar)
|
||
|
|
(if (live-tvar? Tvar) (Tvar->nuTvar Tvar) #f))
|
||
|
|
Tvar*))])
|
||
|
|
(match nu-Tvar*
|
||
|
|
[() (mk-dummy-tvar)]
|
||
|
|
[(Tvar) Tvar]
|
||
|
|
[_ (or (ormap
|
||
|
|
(match-lambda
|
||
|
|
[(Tvar2* . nu)
|
||
|
|
(if (set-eq? Tvar2* nu-Tvar*) nu #f)])
|
||
|
|
table)
|
||
|
|
(let ([nu (mk-Tvar 'multiple)])
|
||
|
|
(set! table (cons (cons nu-Tvar* nu) table))
|
||
|
|
(for-each (lambda (to) (new-edge! nu to)) nu-Tvar*)
|
||
|
|
nu))])))]
|
||
|
|
[tag-reached-AV (gensym)])
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ NT source LU)
|
||
|
|
(when (Tvar? source)
|
||
|
|
(pretty-debug-min `(copying ,(Tvar-name source)))
|
||
|
|
(let ([dest (Tvar->nuTvar source)])
|
||
|
|
(case LU
|
||
|
|
[(U)
|
||
|
|
;; --- AVs
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(and AV
|
||
|
|
($ AV _
|
||
|
|
(and template ($ template _ signs)) misc fields))
|
||
|
|
|
||
|
|
(pretty-debug-min `(AV ,(Tvar-name dest)
|
||
|
|
,(vector-map Tvar-name fields)))
|
||
|
|
|
||
|
|
(new-AV! dest
|
||
|
|
(or (AV-nuAV AV)
|
||
|
|
(let* ([nu-fields
|
||
|
|
(vector-map
|
||
|
|
(lambda (sign field)
|
||
|
|
(if sign
|
||
|
|
(Tvar->nuTvar field)
|
||
|
|
(Tvar*->nuTvar
|
||
|
|
(Tvar-transitive-edgeto field))))
|
||
|
|
signs fields)]
|
||
|
|
[nu-AV (create-AV template misc nu-fields)])
|
||
|
|
(set-AV-nuAV! AV nu-AV)
|
||
|
|
nu-AV)))])
|
||
|
|
(Tvar-objs source))]
|
||
|
|
|
||
|
|
[(L)
|
||
|
|
;; --- Constraints
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ con _ template field-no Tvar)
|
||
|
|
(for-each
|
||
|
|
(lambda (Tvar)
|
||
|
|
(when (live-tvar? Tvar)
|
||
|
|
(new-con! dest
|
||
|
|
(create-con template field-no
|
||
|
|
(Tvar->nuTvar Tvar)))))
|
||
|
|
(if (vector-ref (template-signs template) field-no)
|
||
|
|
(Tvar-transitive-edgeto Tvar)
|
||
|
|
(list Tvar)
|
||
|
|
;;(Tvar-transitive-edgefrom Tvar)
|
||
|
|
))]
|
||
|
|
[($ con-filter _ filter Tvar)
|
||
|
|
;; Was treated as edge
|
||
|
|
(void)])
|
||
|
|
(Tvar-constraints source))])))])
|
||
|
|
live-nts)
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (L)
|
||
|
|
(let ([nu-L (Tvar->nuTvar L)])
|
||
|
|
(for-each
|
||
|
|
(lambda (to)
|
||
|
|
(when (live-tvar? to)
|
||
|
|
(let ([nu-to (Tvar->nuTvar to)])
|
||
|
|
(unless (eq? nu-L nu-to)
|
||
|
|
(new-edge! nu-L nu-to)))))
|
||
|
|
(Tvar-transitive-edgeto L))))
|
||
|
|
lower)
|
||
|
|
|
||
|
|
(append dummy-tvars (map cdr table))))
|
||
|
|
|
||
|
|
;; ======================================================================
|