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

Corrected bugs in overloading resolution, character conversion, and interface

Browse Source 
field staticness

svn: r3201
This commit is contained in:
Kathy Gray 2006-06-03 07:07:12 +00:00
parent 62354d69bd
commit 4e8dd55532
4 changed files with 69 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/profj/build-info.ss
View File

@ -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

3
collects/profj/compile.ss
View File

@ -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)

15
collects/profj/to-scheme.ss
View File

@ -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))

44
collects/profj/types.ss
View File

@ -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