suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Refinement of overloading resolution in the presence of odd interface hierarchies

Browse Source 
svn: r3416
This commit is contained in:
Kathy Gray 2006-06-19 16:40:53 +00:00
parent f272ae9d7e
commit d6eff0630c
1 changed files with 52 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
collects/profj/types.ss
View File

@ -9,6 +9,7 @@
"ast.ss") "ast.ss")
(provide (all-defined-except number-assign-conversions remove-dups meth-member? (provide (all-defined-except number-assign-conversions remove-dups meth-member?
contained-in? consolidate-lists subset?
generate-require-spec)) generate-require-spec))
;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int ;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int
@ -618,29 +619,55 @@
(method-record-atypes (car methods))) (method-record-atypes (car methods)))
(meth-member? meth (cdr methods))))) (meth-member? meth (cdr methods)))))
;depth: 'a (listof 'a) -> (U int #f) ;depth: 'a int (listof 'a) -> (U int #f)
;The position in elt-list that elt is at, starting with 1 ;The position in elt-list that elt is at, starting with 1
(define (depth elt elt-list) (define (depth elt start elt-list)
(letrec ((d (letrec ((d
(lambda (elt-list cnt) (lambda (elt-list cnt)
#;(printf "d: elt ~a elt-list ~a~n" elt elt-list) #;(printf "d: elt ~a elt-list ~a~n" elt elt-list)
(cond (cond
((null? (cdr elt-list)) +inf.0) ((null? elt-list) +inf.0)
((equal? (car elt-list) elt) cnt) ((equal? (car elt-list) elt) cnt)
(else (d (cdr elt-list) (add1 cnt))))))) (else (d (cdr elt-list) (add1 cnt)))))))
(d elt-list 1))) (d elt-list start)))
;consolidate-lists: (listof (listof alpha)) -> (listof (listof alpha))
(define (consolidate-lists lsts)
(cond
((or (null? lsts) (null? (cdr lsts))) lsts)
((contained-in? (car lsts) (cdr lsts))
(consolidate-lists (cdr lsts)))
(else
(cons (car lsts) (consolidate-lists (cdr lsts))))))
;contained-in? (listof alpha) (listof (listof alpha)) -> boolean
(define (contained-in? current rest)
(and (not (null? rest))
(or (subset? (reverse current)
(reverse (car rest)))
(contained-in? current (cdr rest)))))
(define (subset? smaller bigger)
(or (null? smaller)
(and (equal? (car smaller) (car bigger))
(subset? (cdr smaller) (cdr bigger)))))
;iface-depth: (list string) (list (list string)) type-records -> int ;iface-depth: (list string) (list (list string)) type-records -> int
(define (iface-depth elt ifaces type-recs) (define (iface-depth elt ifaces type-recs)
(if (= 1 (length ifaces)) (if (= 1 (length ifaces))
1 1
(let ([iface-tree (map (lambda (iface) (let* ([iface-trees (map (lambda (iface)
(cons iface (cons iface
(class-record-parents (class-record-parents
(get-record (send type-recs get-class-record iface) (get-record (send type-recs get-class-record iface)
type-recs)))) type-recs))))
ifaces)]) ifaces)]
(apply min (map (lambda (i-list) (depth elt i-list)) iface-tree))))) [sorted-ifaces (sort iface-trees
(lambda (a b) (< (length a) (length b))))]
[ifaces (consolidate-lists sorted-ifaces)])
#;(printf "iface-depth ~a ~a ~a ~n" elt
iface-trees (map (lambda (i-list) (depth elt 0 i-list)) iface-trees))
(apply min (map (lambda (i-list) (depth elt 0 i-list)) ifaces)))))
;conversion-steps: type type -> int ;conversion-steps: type type -> int
(define (conversion-steps from to type-recs) (define (conversion-steps from to type-recs)
@ -656,8 +683,8 @@
((null? from-class-parents) ((null? from-class-parents)
(iface-depth to-name from-class-ifaces type-recs)) (iface-depth to-name from-class-ifaces type-recs))
((null? from-class-ifaces) ((null? from-class-ifaces)
(depth to-name from-class-parents)) (depth to-name 1 from-class-parents))
(else (min (depth to-name from-class-parents) (else (min (depth to-name 1 from-class-parents)
(iface-depth to-name from-class-ifaces type-recs)))))) (iface-depth to-name from-class-ifaces type-recs))))))
((array-type? from) ((array-type? from)
(cond (cond
@ -667,11 +694,11 @@
(add1 (conversion-steps (array-type-type from) to type-recs))))) (add1 (conversion-steps (array-type-type from) to type-recs)))))
(else (else
(case from (case from
((byte) (depth to '(short int long float double))) ((byte) (depth to 1 '(short int long float double)))
((char) (depth to '(byte short int long float double))) ((char) (depth to 1 '(byte short int long float double)))
((short) (depth to '(int long float double))) ((short) (depth to 1 '(int long float double)))
((int) (depth to '(long float double))) ((int) (depth to 1 '(long float double)))
((long) (depth to '(float double))) ((long) (depth to 1 '(float double)))
(else 1)) (else 1))
))) )))
@ -681,12 +708,14 @@
((null? site-args) 0) ((null? site-args) 0)
((and (assignment-conversion (car method-args) (car site-args) type-recs) ((and (assignment-conversion (car method-args) (car site-args) type-recs)
(not (type=? (car site-args) (car method-args)))) (not (type=? (car site-args) (car method-args))))
(+ (conversion-steps (car site-args) (car method-args) type-recs) (let ((step (conversion-steps (car site-args) (car method-args) type-recs)))
(number-assign-conversions (cdr site-args) (cdr method-args) type-recs))) #;(printf "steps for ~a ~a~n" (car site-args) step)
(+ step (number-assign-conversions (cdr site-args) (cdr method-args) type-recs))))
(else (number-assign-conversions (cdr site-args) (cdr method-args) type-recs)))) (else (number-assign-conversions (cdr site-args) (cdr method-args) type-recs))))
;; resolve-overloading: (list method-record) (list type) (-> 'a) (-> 'a) (-> 'a) type-records-> method-record ;; resolve-overloading: (list method-record) (list type) (-> 'a) (-> 'a) (-> 'a) type-records-> method-record
(define (resolve-overloading methods arg-types arg-count-fail method-conflict-fail no-method-fail type-recs) (define (resolve-overloading methods arg-types arg-count-fail method-conflict-fail no-method-fail type-recs)
#;(print-struct #t)
(let* ((a (length arg-types)) (let* ((a (length arg-types))
(m-atypes method-record-atypes) (m-atypes method-record-atypes)
(a-convert? (lambda (t1 t2) (assignment-conversion t1 t2 type-recs))) (a-convert? (lambda (t1 t2) (assignment-conversion t1 t2 type-recs)))
@ -700,10 +729,12 @@
(sort (lambda (l p) (quicksort l p))) (sort (lambda (l p) (quicksort l p)))
(assignable-count (sort (assignable-count (sort
(map (lambda (mr) (map (lambda (mr)
#;(printf "assigning conversions for ~a~n" (m-atypes mr))
(list (number-assign-conversions arg-types (m-atypes mr) type-recs) (list (number-assign-conversions arg-types (m-atypes mr) type-recs)
mr)) mr))
assignable) assignable)
(lambda (i1 i2) (< (car i1) (car i2)))))) (lambda (i1 i2) (< (car i1) (car i2))))))
#;(printf "~a~n" assignable-count)
(cond (cond
((null? methods) (arg-count-fail)) ((null? methods) (arg-count-fail))
((= 1 (length methods-same)) (car methods-same)) ((= 1 (length methods-same)) (car methods-same))
@ -712,7 +743,7 @@
((= 1 (length assignable)) (car assignable)) ((= 1 (length assignable)) (car assignable))
((= (car (car assignable-count)) ((= (car (car assignable-count))
(car (cadr assignable-count))) (method-conflict-fail)) (car (cadr assignable-count))) (method-conflict-fail))
(else (car assignable))))) (else (cadr (car assignable-count))))))
;module-has-binding?: scheme-record string (-> void) -> void ;module-has-binding?: scheme-record string (-> void) -> void
;module-has-binding raises an exception when variable is not defined in mod-ref ;module-has-binding raises an exception when variable is not defined in mod-ref