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.
156 lines
5.5 KiB
Scheme
156 lines
5.5 KiB
Scheme
27 years ago
|
;; contained.ss
|
||
|
|
;;
|
||
|
|
;; Check if one Tvar is contained in another
|
||
|
|
;; Doesn't work for contravariant fields
|
||
|
|
;; Not currently used
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; 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.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
;; ----------------------------------------------------------------------
|
||
|
|
;; NOTE: Tvar2 must be tidy!!!
|
||
|
|
|
||
|
|
(define stack '())
|
||
|
|
(define fail-stack '())
|
||
|
|
|
||
|
|
(define Tvar-containment?
|
||
|
|
(lambda (tvar1 tvar2)
|
||
|
|
(let*-vals
|
||
|
|
( [calc-reached
|
||
|
|
(lambda (tvar)
|
||
|
|
(let*-vals
|
||
|
|
([(reached? set-reached! get-reached)
|
||
|
|
(field->set alloc-Tvar-field)])
|
||
|
|
(recur traverse ([tvar tvar])
|
||
|
|
(unless (reached? tvar)
|
||
|
|
(set-reached! tvar)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ AV _ ($ template _ _ _ ref) _ fields+ field-)
|
||
|
|
(vector-for-each traverse fields+)])
|
||
|
|
(get-Tvar-objs tvar))))
|
||
|
|
(get-reached)))]
|
||
|
|
[list-reached-1 (calc-reached tvar1)]
|
||
|
|
[list-reached-2 (calc-reached tvar2)]
|
||
|
|
[num-reached-1 (length list-reached-1)]
|
||
|
|
[(get-num set-num!) (alloc-Tvar-field)]
|
||
|
|
[(get-reached-vec set-reached-vec!) (alloc-Tvar-field)]
|
||
|
|
)
|
||
|
|
|
||
|
|
(for-each-with-n (lambda (tvar n) (set-num! tvar n))
|
||
|
|
list-reached-1)
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (tvar) (set-reached-vec! tvar (make-vector num-reached-1 #f)))
|
||
|
|
list-reached-2)
|
||
|
|
|
||
|
|
;; Tidyness check
|
||
|
|
'(for-each
|
||
|
|
(lambda (tvar)
|
||
|
|
(let* ([objs (get-Tvar-objs tvar)]
|
||
|
|
[templates (map AV-template objs)]
|
||
|
|
[types (map template-type templates)]
|
||
|
|
[types2 (list->set types)])
|
||
|
|
(unless (= (length types) (length types2))
|
||
|
|
(mrspidey:error
|
||
|
|
(format "Upper bound of containment is not tidy, types are ~s"
|
||
|
|
types)))))
|
||
|
|
list-reached-2)
|
||
|
|
|
||
|
|
(begin0
|
||
|
|
(let/cc
|
||
|
|
fail
|
||
|
|
|
||
|
|
(recur ensure-contained ([tvar1 tvar1][tvar2 tvar2])
|
||
|
|
(fluid-let ([stack (cons (cons tvar1 tvar2) stack)])
|
||
|
|
(let ([n (get-num tvar1)]
|
||
|
|
[reached (get-reached-vec tvar2)])
|
||
|
|
(unless (vector-ref reached n)
|
||
|
|
;; Need to search - record true to detect loops
|
||
|
|
(vector-set! reached n #t)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ AV _ (and template ($ template _ _ ref)) _ fields+)
|
||
|
|
(or
|
||
|
|
|
||
|
|
;; More than one matching => not tidy => say contained.
|
||
|
|
(> (count (match-lambda
|
||
|
|
[($ AV _ template2)
|
||
|
|
(eq? (template-type template)
|
||
|
|
(template-type template2))])
|
||
|
|
(get-Tvar-objs tvar2))
|
||
|
|
1)
|
||
|
|
|
||
|
|
(ormap
|
||
|
|
(match-lambda
|
||
|
|
[($ AV _ template2 _ fields2+)
|
||
|
|
(and ;(eq? template template2)
|
||
|
|
(or
|
||
|
|
(eq?
|
||
|
|
(template-type template)
|
||
|
|
(template-type template2))
|
||
|
|
(memq
|
||
|
|
template2
|
||
|
|
(template-super-templates template)))
|
||
|
|
(begin
|
||
|
|
(for i 0
|
||
|
|
(min
|
||
|
|
(vector-length fields+)
|
||
|
|
(vector-length fields2+))
|
||
|
|
(ensure-contained
|
||
|
|
(vector-ref fields+ i)
|
||
|
|
(vector-ref fields2+ i)))
|
||
|
|
#t))])
|
||
|
|
(get-Tvar-objs tvar2))
|
||
|
|
|
||
|
|
;; No match
|
||
|
|
(begin
|
||
|
|
'(printf
|
||
|
|
"~s ~s not in ~s ~s~n"
|
||
|
|
(map (lambda (AV) (template-type (AV-template AV)))
|
||
|
|
(get-Tvar-objs tvar1))
|
||
|
|
(Tvar-name tvar1)
|
||
|
|
(map (lambda (AV) (template-type (AV-template AV)))
|
||
|
|
(get-Tvar-objs tvar2))
|
||
|
|
(Tvar-name tvar2))
|
||
|
|
(set! fail-stack stack)
|
||
|
|
(fail #f)))])
|
||
|
|
(get-Tvar-objs tvar1))))))
|
||
|
|
|
||
|
|
;; Did not fail => succeed
|
||
|
|
#t)
|
||
|
|
|
||
|
|
))))
|
||
|
|
|
||
|
|
'(define (show-fail-stack-sdl)
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[(a . d)
|
||
|
|
(list (Tvar->SDL a)
|
||
|
|
(Tvar->SDL d))])
|
||
|
|
fail-stack))
|
||
|
|
|
||
|
|
'(define (show-fail-stack)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(a . d)
|
||
|
|
(printf "============~n")
|
||
|
|
(show-Tvar a)
|
||
|
|
(show-Tvar d)])
|
||
|
|
fail-stack))
|
||
|
|
|
||
|
|
|