From 4e8dd55532c80a6698e159af5ca5c3291a7f48fb Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Sat, 3 Jun 2006 07:07:12 +0000 Subject: [PATCH] Corrected bugs in overloading resolution, character conversion, and interface field staticness svn: r3201 --- collects/profj/build-info.ss | 13 ++++++++++- collects/profj/compile.ss | 3 ++- collects/profj/to-scheme.ss | 15 ++++++++++-- collects/profj/types.ss | 44 ++++++++++++++++++++++++++++++++++-- 4 files changed, 69 insertions(+), 6 deletions(-) diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index c7466f5999..ccbca2bb86 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -751,6 +751,12 @@ (valid-inherited-methods? super-records (header-extends info) level type-recs) (check-current-methods super-records m members level type-recs) + (for-each (lambda (fi) + (unless (memq 'static (field-record-modifiers fi)) + (set-field-record-modifiers! fi + (cons 'static (field-record-modifiers fi))))) + f) + (let ((record (make-class-record iname @@ -1060,10 +1066,15 @@ (implements-all? (get-methods-need-implementing (class-record-methods super)) methods super-name level))) (andmap (lambda (iface iface-name) - (implements-all? (class-record-methods iface) methods iface-name level)) + (or (super-implements? iface (class-record-ifaces super)) + (implements-all? (class-record-methods iface) methods iface-name level))) ifaces ifaces-name)) + ;super-implements?: class-record (list (list string)) + (define (super-implements? iface ifaces) + (member (class-record-name iface) ifaces)) + ;make-unimplmented-stubs: (list class-record) (list name) (list method-record) type-records -> (list method) (define (make-unimplmented-stubs ifaces ifaces-name methods type-recs) (letrec ((type->type-spec diff --git a/collects/profj/compile.ss b/collects/profj/compile.ss index e6442144a1..1f073dc4b2 100644 --- a/collects/profj/compile.ss +++ b/collects/profj/compile.ss @@ -152,7 +152,8 @@ (unless (null? (check-list)) (check-defs (car (check-list)) level type-recs)) (remove-from-packages ast type-recs) - (order-cus (translate-program ast type-recs) type-recs)) + (order-cus (translate-program ast type-recs) + type-recs)) ;compile-java-internal: port location type-records bool level-> (list compilation-unit) (define (compile-java-internal port location type-recs file? level) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 3e81fd34a6..c18f06b7fd 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -1535,6 +1535,10 @@ ((and (memq (field-type init?) '(float double)) (memq actual-type '(long int byte short))) (make-syntax #f `(exact->inexact ,body-syntax) body-syntax)) + ((and (eq? actual-type 'char) (memq (field-type init?) '(byte short int long))) + (make-syntax #f `(char->integer ,body-syntax) body-syntax)) + ((and (eq? actual-type 'char) (memq (field-type init?) '(float double))) + (make-syntax #f `(exact->inexact (char->integer ,body-syntax)) body-syntax)) (else body-syntax)))) (else default-val))))) @@ -2562,7 +2566,7 @@ ;translate-array-alloc-init: type-spec int array-init src (define (translate-array-alloc-init type dim init src) - (initialize-array type (array-init-vals init))) + (initialize-array (array-init-vals init) type)) ;translate-type-spec: type-spec -> syntax (define (translate-type-spec type) @@ -2682,6 +2686,12 @@ ((and (memq type '(float double)) (memq (expr-types assign-to) '(long int short byte))) `(exact->inexact ,expanded-expr)) + ((and (eq? (expr-types assign-to) 'char) + (memq type '(byte short int long))) + `(char->integer ,expanded-expr)) + ((and (eq? (expr-types assign-to) 'char) + (memq type '(float double))) + `(exact->inexact (char->integer ,expanded-expr))) (else expanded-expr)))))) (cond ((array-access? name) @@ -2709,7 +2719,8 @@ (build-identifier (var-access-class vaccess)))))) ((not obj) (set-h (translate-id (build-var-name field) field-src))) (else - (let ((setter (if (var-access-final? vaccess) + (let ((setter (if (and (var-access-final? vaccess) + (not (eq? 'private (var-access-access vaccess)))) (make-syntax #f `(lambda (my-dummy new-val) ((class-field-mutator ,(build-identifier (var-access-class vaccess)) diff --git a/collects/profj/types.ss b/collects/profj/types.ss index b2da7dba76..68ec269f38 100644 --- a/collects/profj/types.ss +++ b/collects/profj/types.ss @@ -116,6 +116,7 @@ (define (widening-prim-conversion to from) (cond ((symbol=? to from) #t) + ((symbol=? to 'char) #f) ((symbol=? 'short to) (symbol=? 'byte from)) ((symbol=? 'int to) @@ -617,13 +618,52 @@ (method-record-atypes (car methods))) (meth-member? meth (cdr methods))))) + ;depth: 'a (listof 'a) -> int + ;The position in elt-list that elt is at, starting with 1 + (define (depth elt elt-list) + (letrec ((d + (lambda (elt-list cnt) + #;(printf "d: elt ~a elt-list ~a~n" elt elt-list) + (cond + ((equal? (car elt-list) elt) cnt) + (else (d (cdr elt-list) (add1 cnt))))))) + (d elt-list 1))) + + ;conversion-steps: type type -> int + (define (conversion-steps from to type-recs) + #;(printf "conversion-steps ~a ~a~n" from to) + (cond + ((ref-type? from) + (let* ((from-class (send type-recs get-class-record from)) + (from-class-parents (class-record-parents from-class))) + (if (eq? to 'dynamic) + (sub1 (length from-class-parents)) + (depth (cons (ref-type-class/iface to) (ref-type-path to)) + from-class-parents)))) + ((array-type? from) + (cond + ((array-type? to) + (conversion-steps (array-type-type from) (array-type-type to) type-recs)) + (else + (add1 (conversion-steps (array-type-type from) to type-recs))))) + (else + (case from + ((byte) (depth to '(short int long float double))) + ((char) (depth to '(byte short int long float double))) + ((short) (depth to '(int long float double))) + ((int) (depth to '(long float double))) + ((long) (depth to '(float double))) + (else 1)) + ))) + ;number-assign-conversion: (list type) (list type) type-records -> int (define (number-assign-conversions site-args method-args type-recs) (cond ((null? site-args) 0) - ((and (assignment-conversion (car site-args) (car method-args) type-recs) + ((and (assignment-conversion (car method-args) (car site-args) type-recs) (not (type=? (car site-args) (car method-args)))) - (add1 (number-assign-conversions (cdr site-args) (cdr method-args) type-recs))) + (+ (conversion-steps (car site-args) (car method-args) type-recs) + (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