325c304560
Correction to bug allowing package access methods to implement interface methods. Correction to bug preventing interactions window from accessing protected fields. svn: r3922
948 lines
46 KiB
Scheme
948 lines
46 KiB
Scheme
(module types mzscheme
|
|
|
|
(require
|
|
(only (lib "1.ss" "srfi") lset-intersection)
|
|
(lib "etc.ss")
|
|
(lib "pretty.ss")
|
|
(lib "list.ss")
|
|
(lib "class.ss")
|
|
"ast.ss")
|
|
|
|
(provide (all-defined-except number-assign-conversions remove-dups meth-member?
|
|
contained-in? consolidate-lists subset? depth conversion-steps
|
|
generate-require-spec))
|
|
|
|
;; symbol-type = 'null | 'string | 'boolean | 'char | 'byte | 'short | 'int
|
|
;; | 'long | 'float | 'double | 'void | 'dynamic
|
|
;; reference-type = 'null | 'string | (make-ref-type string (list string))
|
|
;; array-type = (make-array-type type int)
|
|
;; type = symbol-type
|
|
;; | reference-type
|
|
;; | array-type
|
|
;; | dynamic-val
|
|
;; | unknown-ref
|
|
|
|
(define-struct ref-type (class/iface path) (make-inspector))
|
|
(define-struct array-type (type dim))
|
|
|
|
(define object-type (make-ref-type "Object" `("java" "lang")))
|
|
(define string-type (make-ref-type "String" `("java" "lang")))
|
|
(define throw-type (make-ref-type "Throwable" `("java" "lang")))
|
|
(define runtime-exn-type (make-ref-type "RuntimeException" `("java" "lang")))
|
|
(define serializable-type (make-ref-type "Serializable" `("java" "io")))
|
|
(define comparable-type (make-ref-type "Comparable" `("java" "lang")))
|
|
(define cloneable-type (make-ref-type "Cloneable" `("java" "lang")))
|
|
|
|
;
|
|
;
|
|
; ; ; ;
|
|
; ; ;
|
|
; ;;;;;;; ; ;
|
|
; ; ; ;
|
|
; ; ; ; ; ;;; ;;;; ;;; ; ;;; ;;;; ;;; ; ; ;;; ; ;;; ;;; ;
|
|
; ; ; ; ;; ;; ; ;; ; ; ;; ; ; ;; ; ; ; ; ; ;; ; ;; ;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ;;;;;; ; ; ; ;;;;;; ; ;;; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ;; ;; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;; ;;
|
|
; ; ; ; ;;; ;;; ;;; ; ; ;;; ;;; ; ; ;;;;; ; ; ;;; ;
|
|
; ; ; ;
|
|
; ; ; ; ;;
|
|
; ;; ; ;;;
|
|
;
|
|
|
|
|
|
;; reference-type: 'a -> boolean
|
|
(define (reference-type? x)
|
|
(if (and (dynamic-val? x) (dynamic-val-type x))
|
|
(reference-type? (dynamic-val-type x))
|
|
(or (dynamic-val? x)
|
|
(unknown-ref? x)
|
|
(ref-type? x)
|
|
(memq x `(null string)))))
|
|
|
|
;;reference-or-array-type: 'a -> boolean
|
|
(define (reference-or-array-type? x)
|
|
(or (reference-type? x)
|
|
(array-type? x)))
|
|
|
|
;;is-string?: 'a -> boolean
|
|
(define (is-string-type? s)
|
|
(if (dynamic-val? s)
|
|
(is-string-type? (dynamic-val-type s))
|
|
(and (reference-type? s)
|
|
(or (eq? 'string s) (type=? s string-type)))))
|
|
|
|
;; 4.2
|
|
;; prim-integral-type?: 'a -> boolean
|
|
(define (prim-integral-type? t)
|
|
(cond
|
|
((and (dynamic-val? t) (dynamic-val-type t))
|
|
(prim-integral-type? (dynamic-val-type t)))
|
|
((dynamic-val? t) #t)
|
|
(else (memq t `(byte short int long char)))))
|
|
;; prim-numeric-type?: 'a -> boolean
|
|
(define (prim-numeric-type? t)
|
|
(cond
|
|
((and (dynamic-val? t) (dynamic-val-type t))
|
|
(prim-numeric-type? (dynamic-val-type t)))
|
|
((dynamic-val? t) #t)
|
|
(else (or (prim-integral-type? t) (memq t `(float double))))))
|
|
|
|
;; type=?: type type -> boolean
|
|
(define (type=? t1 t2)
|
|
(cond
|
|
((and (symbol? t1) (symbol? t2))
|
|
(symbol=? t1 t2))
|
|
((and (ref-type? t1) (ref-type? t2))
|
|
(and (string=? (ref-type-class/iface t1) (ref-type-class/iface t2))
|
|
(= (length (ref-type-path t1)) (length (ref-type-path t2)))
|
|
(andmap
|
|
(lambda (x y)
|
|
(string=? x y))
|
|
(ref-type-path t1)
|
|
(ref-type-path t2))))
|
|
((and (array-type? t1) (array-type? t2))
|
|
(and (= (array-type-dim t1) (array-type-dim t2))
|
|
(type=? (array-type-type t1) (array-type-type t2))))
|
|
((or (symbol? t1) (symbol? t2))
|
|
(or (or (and (eq? t1 'null) (ref-type? t2))
|
|
(and (eq? t2 'null) (ref-type? t1)))
|
|
(and (eq? t1 'string) (type=? t2 string-type))
|
|
(and (eq? t2 'string) (type=? t1 string-type))))
|
|
(else #f)))
|
|
|
|
;; 5.1.2
|
|
;; widening-prim-conversion: symbol-type symbol-type -> boolean
|
|
(define (widening-prim-conversion to from)
|
|
(cond
|
|
((symbol=? to from) #t)
|
|
((symbol=? to 'char) #f)
|
|
((symbol=? 'short to)
|
|
(symbol=? 'byte from))
|
|
((symbol=? 'int to)
|
|
(memq from `(byte short char)))
|
|
((symbol=? 'long to)
|
|
(memq from `(byte short char int)))
|
|
((symbol=? 'float to)
|
|
(memq from `(byte short char int long)))
|
|
((symbol=? 'double to)
|
|
(memq from `(byte short char int long float)))))
|
|
|
|
;; 5.1.4
|
|
;; widening-ref-conversion: type type type-records -> boolean
|
|
(define (widening-ref-conversion to from type-recs)
|
|
(cond
|
|
((and (symbol? from) (symbol=? from 'null))
|
|
(or (ref-type? to) (symbol=? 'string to) (array-type? to)))
|
|
((and (symbol? from) (symbol=? from 'string))
|
|
(or (type=? to object-type)
|
|
(type=? to serializable-type)
|
|
(type=? to comparable-type)))
|
|
((and (ref-type? from) (ref-type? to))
|
|
(or (is-subclass? from to type-recs)
|
|
(implements? from to type-recs)
|
|
(and (is-interface? from type-recs)
|
|
(type=? object-type to))))
|
|
((array-type? from)
|
|
(or (type=? object-type to)
|
|
(type=? cloneable-type to)
|
|
(type=? serializable-type to)
|
|
(and (array-type? to) (= (array-type-dim from) (array-type-dim to))
|
|
(assignment-conversion (array-type-type to) (array-type-type from) type-recs))))
|
|
(else #f)))
|
|
|
|
;; 5.2
|
|
;; SKIP - possible narrowing conversion for constants
|
|
;; assignment-conversion: type type type-records -> boolean
|
|
(define (assignment-conversion to from type-recs)
|
|
(cond
|
|
((dynamic-val? to)
|
|
(cond
|
|
((dynamic-val-type to) => (lambda (t) (assignment-conversion t from type-recs)))
|
|
(else (set-dynamic-val-type! to from) #t)))
|
|
((dynamic-val? from)
|
|
(cond
|
|
((dynamic-val-type from) => (lambda (t) (assignment-conversion to t type-recs)))
|
|
(else (set-dynamic-val-type! from to) #t)))
|
|
((eq? to 'dynamic) #t)
|
|
((type=? to from) #t)
|
|
((and (prim-numeric-type? to) (prim-numeric-type? from))
|
|
(widening-prim-conversion to from))
|
|
(else
|
|
(widening-ref-conversion to from type-recs))))
|
|
|
|
;castable?: reference-type reference-type type-records -> boolean
|
|
(define (castable? from to type-recs)
|
|
(or (dynamic-val? from)
|
|
(dynamic-val? to)
|
|
(eq? 'dynamic to)
|
|
(eq? 'null from)
|
|
(eq? 'null to)
|
|
(let ((from-record (and (not (array-type? from)) (send type-recs get-class-record from)))
|
|
(to-record (and (not (array-type? to))
|
|
(get-record (send type-recs get-class-record to) type-recs))))
|
|
(cond
|
|
((and to-record from-record
|
|
(class-record-class? from-record)
|
|
(class-record-class? to-record))
|
|
(or (is-eq-subclass? from to type-recs)
|
|
(is-eq-subclass? to from type-recs)))
|
|
((and to-record from-record (class-record-class? from-record))
|
|
(or (not (memq 'final (class-record-modifiers from-record)))
|
|
(implements? from to type-recs)))
|
|
((and (not to-record) from-record (class-record-class? from-record))
|
|
(type=? object-type from))
|
|
((and to-record from-record (class-record-class? to-record))
|
|
(or (not (memq 'final (class-record-modifiers to-record)))
|
|
(implements? to from type-recs)))
|
|
((and to-record from-record (not (class-record-class? to-record)))
|
|
(not (signature-conflicts? (class-record-methods to-record)
|
|
(class-record-methods from-record))))
|
|
((and (not from-record) to-record (class-record-class? to-record))
|
|
(type=? object-type to))
|
|
((and (not from-record) to-record)
|
|
(or (type=? serializable-type to type-recs)
|
|
(type=? cloneable-type to type-recs)))
|
|
(else
|
|
(or (type=? (array-type-type to) (array-type-type from))
|
|
(castable? (array-type-type from)
|
|
(array-type-type to)
|
|
type-recs)))))))
|
|
|
|
;Do the two lists of method signatures have conflicting methods
|
|
;signature-conflicts? (list method-record) (list method-record) -> bool
|
|
(define (signature-conflicts? methods1 methods2)
|
|
(let ((same-sigs (lset-intersection signature-equals? methods1 methods2))
|
|
(same-rets (lset-intersection full-signature-equals? methods1 methods2)))
|
|
(not (= (length same-sigs) (length same-rets)))))
|
|
|
|
;Do the two methods have same name and argument types
|
|
;signature-equals? method-record method-record -> bool
|
|
(define (signature-equals? m1 m2)
|
|
(and (equal? (method-record-name m1)
|
|
(method-record-name m2))
|
|
(= (length (method-record-atypes m1))
|
|
(length (method-record-atypes m2)))
|
|
(andmap type=? (method-record-atypes m1) (method-record-atypes m2))))
|
|
;Do the two methods have the same name, arguments and return types
|
|
;full-signagure-equals? method-record method-record -> bool
|
|
(define (full-signature-equals? m1 m2)
|
|
(and (signature-equals? m1 m2)
|
|
(type=? (method-record-rtype m1) (method-record-rtype m2))))
|
|
|
|
;;equal-greater-access? (list symbol) (list symbol) -> boolean
|
|
(define (equal-greater-access? mods-l mods-r)
|
|
(let ([eq-gt?
|
|
(lambda (acc-l acc-r)
|
|
(case acc-l
|
|
[(public) (memq acc-r '(package protected public))]
|
|
[(protected) (memq acc-r '(package protected))]
|
|
[(package) (memq acc-r '(package))]
|
|
[else #f]))])
|
|
(eq-gt? (extract-access mods-l) (extract-access mods-r))))
|
|
|
|
(define (extract-access mods)
|
|
(cond
|
|
[(memq 'public mods) 'public]
|
|
[(memq 'protected mods) 'protected]
|
|
[(memq 'private mods) 'private]
|
|
[else 'package]))
|
|
|
|
;; type-spec-to-type: type-spec (U #f (list string) symbol type-records -> type
|
|
(define (type-spec-to-type ts container-class level type-recs)
|
|
(let* ((ts-name (type-spec-name ts))
|
|
(t (cond
|
|
((memq ts-name `(null string boolean char byte short int long float double void ctor dynamic)) ts-name)
|
|
((name? ts-name) (name->type ts-name container-class (type-spec-src ts) level type-recs)))))
|
|
(if (> (type-spec-dim ts) 0)
|
|
(make-array-type t (type-spec-dim ts))
|
|
t)))
|
|
|
|
;name->type: name (U (list string) #f) src symbol type-records -> type
|
|
(define (name->type n container-class src level type-recs)
|
|
(let ((name (id-string (name-id n)))
|
|
(path (map id-string (name-path n))))
|
|
(type-exists? name path container-class src level type-recs)
|
|
(make-ref-type name (if (null? path) (send type-recs lookup-path name (lambda () null)) path))))
|
|
|
|
;; type-exists: string (list string) (U (list string) #f) src symbol type-records -> (U record procedure)
|
|
(define (type-exists? name path container-class src level type-recs)
|
|
(send type-recs get-class-record (cons name path) container-class
|
|
((get-importer type-recs) (cons name path) type-recs level src)))
|
|
|
|
;; is-interface?: (U type (list string) 'string) type-records-> boolean
|
|
(define (is-interface? t type-recs)
|
|
(not (class-record-class?
|
|
(get-record (send type-recs get-class-record t) type-recs))))
|
|
|
|
;;Is c1 a subclass of c2?
|
|
;; is-subclass?: (U type (list string) 'string) ref-type type-records -> boolean
|
|
(define (is-subclass? c1 c2 type-recs)
|
|
(let ((cr (get-record (send type-recs get-class-record c1) type-recs)))
|
|
(member (cons (ref-type-class/iface c2) (ref-type-path c2))
|
|
(class-record-parents cr))))
|
|
|
|
;Does c1 implement c2?
|
|
;; implements?: (U type (list string) 'string) ref-type type-records -> boolean
|
|
(define (implements? c1 c2 type-recs)
|
|
(let ((cr (get-record (send type-recs get-class-record c1) type-recs)))
|
|
(member (cons (ref-type-class/iface c2) (ref-type-path c2))
|
|
(class-record-ifaces cr))))
|
|
|
|
;;Is class1 a subclass or equal to class2?
|
|
;is-eq-subclass: type type type-records -> boolean
|
|
(define (is-eq-subclass? class1 class2 type-recs)
|
|
(or (type=? class1 class2)
|
|
(and (reference-type? class1)
|
|
(reference-type? class2)
|
|
(is-subclass? class1 class2 type-recs))))
|
|
|
|
;
|
|
;
|
|
;
|
|
; ;;; ;
|
|
; ;;;; ; ;;;;; ;
|
|
; ; ; ; ; ;; ;
|
|
; ;; ; ; ; ;
|
|
; ; ; ;;;; ;;;; ;;;; ; ; ;;;; ;;; ;;;; ; ;;; ;;; ; ;;;;
|
|
; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ;; ;; ;; ;; ;; ; ;
|
|
; ; ; ;;;;; ;; ;; ;;;;;; ; ; ; ; ; ; ; ; ;;
|
|
; ; ; ;; ; ;;;; ;;;; ; ; ;;;;;; ; ; ; ; ; ; ;;;;
|
|
; ;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ;; ; ; ; ; ; ; ; ; ; ; ;; ;; ; ;; ;; ; ;
|
|
; ;;;; ;;;;; ;;; ; ;;;; ;;;; ; ; ;;; ;;; ;;;; ; ;;; ; ;;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
;; (make-class-record (list string) (list symbol) boolean boolean (list field-record)
|
|
;; (list method-records) (list inner-record) (list (list strings)) (list (list strings)))
|
|
;; After full processing fields and methods should contain all inherited fields
|
|
;; and methods. Also parents and ifaces should contain all super-classes/ifaces
|
|
(define-struct class-record (name modifiers class? object? fields methods inners parents ifaces) (make-inspector))
|
|
|
|
(define interactions-record (make-class-record (list "interactions") null #f #f null null null null null))
|
|
|
|
;; (make-field-record string (list symbol) bool (list string) type)
|
|
(define-struct field-record (name modifiers init? class type) (make-inspector))
|
|
|
|
;; (make-method-record string (list symbol) type (list type) (list type) (U bool method-record) string)
|
|
(define-struct method-record (name modifiers rtype atypes throws override class) (make-inspector))
|
|
|
|
;;(make-inner-record string string (list symbol) bool)
|
|
(define-struct inner-record (name full-name modifiers class?) (make-inspector))
|
|
|
|
;;(make-scheme-record string (list string) path (list dynamic-val))
|
|
(define-struct scheme-record (name path dir provides))
|
|
|
|
;;(make-dynamic-val (U type method-contract unknown-ref))
|
|
(define-struct dynamic-val (type) (make-inspector))
|
|
|
|
;;(make-unknown-ref (U method-contract field-contract))
|
|
(define-struct unknown-ref (access) (make-inspector))
|
|
|
|
;;(make-method-contract string type (list type) (U #f string))
|
|
(define-struct method-contract (name return args prefix) (make-inspector))
|
|
|
|
;;(make-field-contract string type)
|
|
(define-struct field-contract (name type))
|
|
|
|
;
|
|
; ;;
|
|
; ; ;
|
|
; ; ;
|
|
; ;;;;; ;;; ;;;; ;;; ;;; ; ;;; ;;; ;;; ;;; ; ;;; ;;;; ;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ;;;;; ;;;;; ; ;;;;; ; ; ; ; ; ; ;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ;;;; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;; ; ;;;
|
|
; ; ;
|
|
; ; ;
|
|
; ;; ;;;
|
|
|
|
;Class to store various information per package compilation
|
|
(define type-records
|
|
(class object%
|
|
|
|
(field (importer
|
|
(lambda ()
|
|
(error 'internal-error "type-records importer field was not set"))))
|
|
|
|
;Stores type information and require syntax per compile or execution
|
|
(define records (make-hash-table 'equal))
|
|
(define requires (make-hash-table 'equal))
|
|
(define package-contents (make-hash-table 'equal))
|
|
|
|
;Stores per-class information accessed by location
|
|
(define class-environment (make-hash-table))
|
|
(define class-require (make-hash-table))
|
|
|
|
(define compilation-location (make-hash-table))
|
|
|
|
(define class-reqs null)
|
|
(define location #f)
|
|
|
|
;add-class-record: class-record -> void
|
|
(define/public (add-class-record r)
|
|
(hash-table-put! records (class-record-name r) r))
|
|
;add-to-records: (list string) ( -> 'a) -> void
|
|
(define/public (add-to-records key thunk)
|
|
(hash-table-put! records key thunk))
|
|
|
|
;; get-class-record: (U type (list string) 'string) (U (list string) #f) ( -> 'a) ->
|
|
;; (U class-record scheme-record procedure)
|
|
(define/public get-class-record
|
|
(opt-lambda (ctype [container #f] [fail (lambda () null)])
|
|
(let*-values (((key key-path) (normalize-key ctype))
|
|
((key-inner) (when (cons? container) (string-append (car container) "." key)))
|
|
((outer-record) (when (cons? container) (get-class-record container)))
|
|
((path) (if (null? key-path) (lookup-path key (lambda () null)) key-path))
|
|
((inner-path) (if (null? key-path) (lookup-path key-inner (lambda () null)) key-path))
|
|
((new-search)
|
|
(lambda ()
|
|
(cond
|
|
((null? path) (fail))
|
|
(else
|
|
(let ((back-path (reverse path)))
|
|
(search-for-record key (car back-path)
|
|
(reverse (cdr back-path)) (lambda () #f) fail)))))))
|
|
;(printf "key ~a key-path ~a path ~a location ~a ~n" key key-path path location)
|
|
;(printf "get-class-record: ~a~n" ctype)
|
|
;(hash-table-for-each records (lambda (k v) (printf "~a -> ~a~n" k v)))
|
|
(cond
|
|
((and container
|
|
(not (null? outer-record))
|
|
(not (eq? outer-record 'in-progress))
|
|
(member key (map inner-record-name (class-record-inners (get-record outer-record this)))))
|
|
(hash-table-get records (cons key-inner (cdr container)) fail))
|
|
((and container (not (null? outer-record)) (eq? outer-record 'in-progress))
|
|
(let ((res (hash-table-get records (cons key-inner inner-path) (lambda () #f))))
|
|
(or res
|
|
(hash-table-get records (cons key path) new-search))))
|
|
(else
|
|
(hash-table-get records (cons key path) new-search))))))
|
|
|
|
;normalize-key: (U 'strung ref-type (list string)) -> (values string (list string))
|
|
(define/private (normalize-key ctype)
|
|
(cond
|
|
((eq? ctype 'string) (values "String" `("java" "lang")))
|
|
((ref-type? ctype) (values (ref-type-class/iface ctype) (ref-type-path ctype)))
|
|
((cons? ctype) (values (car ctype) (cdr ctype)))
|
|
(else (values ctype null))))
|
|
|
|
;search-for-record string string (list string) (-> #f) (-> 'a) -> class-record
|
|
(define/private (search-for-record class-name new-prefix path test-fail fail)
|
|
(let* ((new-class-name (string-append new-prefix "." class-name))
|
|
(rec? (hash-table-get records (cons new-class-name path) test-fail))
|
|
(back-path (reverse path)))
|
|
(cond
|
|
(rec? rec?)
|
|
((null? path) (fail))
|
|
(else (search-for-record new-class-name (car back-path) (reverse (cdr back-path)) test-fail fail)))))
|
|
|
|
;add-package-contents: (list string) (list string) -> void
|
|
(define/public (add-package-contents package classes)
|
|
(let ((existing-classes (hash-table-get package-contents package (lambda () null))))
|
|
(if (null? existing-classes)
|
|
(hash-table-put! package-contents package classes)
|
|
(hash-table-put! package-contents package (non-dup-append classes existing-classes)))))
|
|
|
|
(define/private (non-dup-append cl pa)
|
|
(cond
|
|
((null? cl) pa)
|
|
((member (car cl) pa) (non-dup-append (cdr cl) pa))
|
|
(else (cons (car cl) (non-dup-append (cdr cl) pa)))))
|
|
|
|
;get-package-contents: (list string) ( -> 'a) -> (list string)
|
|
(define/public (get-package-contents package fail)
|
|
(hash-table-get package-contents package fail))
|
|
|
|
;add-to-env: string (list string) file -> void
|
|
(define/public (add-to-env class path loc)
|
|
(hash-table-put! (hash-table-get class-environment loc
|
|
(lambda ()
|
|
(let ((new-t (make-hash-table 'equal)))
|
|
(hash-table-put! class-environment loc new-t)
|
|
new-t)))
|
|
class
|
|
path))
|
|
|
|
;Returns the environment of classes for the current location
|
|
;get-class-env: -> (list string)
|
|
(define/public (get-class-env)
|
|
(hash-table-map (hash-table-get class-environment location) (lambda (key val) key)))
|
|
|
|
(define (env-failure)
|
|
(error 'class-environment "Internal Error: environment does not have location"))
|
|
|
|
;lookup-path: string ( -> 'a) -> (U (list string) #f)
|
|
(define/public (lookup-path class fail)
|
|
;(printf "class ~a location ~a~n" class location)
|
|
;(printf "lookup ~a~n" class)
|
|
#;(hash-table-for-each (hash-table-get class-environment location)
|
|
(lambda (k v) (printf "~a -> ~a~n" k v)))
|
|
(if location
|
|
(hash-table-get (hash-table-get class-environment
|
|
location
|
|
env-failure)
|
|
class fail)
|
|
(fail)))
|
|
|
|
;add-require-syntax: (list string) (list syntax syntax) -> void
|
|
(define/public (add-require-syntax name syn)
|
|
(get-require-syntax #t name (lambda () (hash-table-put! requires (cons #t name) (car syn))))
|
|
(get-require-syntax #f name (lambda () (hash-table-put! requires (cons #f name) (cadr syn)))))
|
|
|
|
(define (syntax-fail)
|
|
(error 'syntax "Internal Error: syntax did not have given req"))
|
|
|
|
;get-require-syntax: bool (list string) . ( -> 'a) -> syntax
|
|
(define/public (get-require-syntax prefix? name . fail)
|
|
(hash-table-get requires (cons prefix? name) (if (null? fail) syntax-fail (car fail))))
|
|
|
|
;add-class-req: name boolean location -> void
|
|
(define/public (add-class-req name pre loc)
|
|
(hash-table-put! (hash-table-get class-require
|
|
loc
|
|
(lambda () (let ((new-t (make-hash-table 'equal)))
|
|
(hash-table-put! class-require loc new-t)
|
|
new-t)))
|
|
name pre))
|
|
|
|
;require-fail
|
|
(define (require-fail)
|
|
(error 'require-prefix "Internal Error: require does not have location"))
|
|
|
|
;require-prefix?: (list string) ( -> 'a) -> bool
|
|
(define/public (require-prefix? name fail)
|
|
(hash-table-get (hash-table-get class-require location require-fail) name fail))
|
|
|
|
(define/private (member-req req reqs)
|
|
(and (not (null? reqs))
|
|
(or (and (equal? (req-class req) (req-class (car reqs)))
|
|
(equal? (req-path req) (req-path (car reqs))))
|
|
(member-req req (cdr reqs)))))
|
|
|
|
(define/public (set-compilation-location loc dir) (hash-table-put! compilation-location loc dir))
|
|
(define/public (get-compilation-location)
|
|
(hash-table-get compilation-location location
|
|
(lambda () (error 'get-compilation-location "Internal error: location not found"))))
|
|
(define/public (set-composite-location name dir) (hash-table-put! compilation-location name dir))
|
|
(define/public (get-composite-location name)
|
|
;(printf "get-composite-location for ~a~n" name)
|
|
;(hash-table-for-each compilation-location
|
|
; (lambda (k v) (printf "~a -> ~a~n" k v)))
|
|
(hash-table-get compilation-location name
|
|
(lambda () (error 'get-composite-location "Internal error: name not found"))))
|
|
|
|
(define/public (add-req req)
|
|
(unless (member-req req class-reqs)
|
|
(set! class-reqs (cons req class-reqs))))
|
|
(define/public (get-class-reqs) class-reqs)
|
|
(define/public (set-class-reqs reqs) (set! class-reqs reqs))
|
|
|
|
(define/public (set-location! l) (set! location l))
|
|
(define/public (get-location) location)
|
|
|
|
(define interaction-package null)
|
|
(define interaction-fields null)
|
|
(define interaction-boxes null)
|
|
(define execution-loc #f)
|
|
|
|
(define/public (set-interactions-package p) (set! interaction-package p))
|
|
(define/public (get-interactions-package) interaction-package)
|
|
(define/public (add-interactions-field rec)
|
|
(set! interaction-fields (cons rec interaction-fields)))
|
|
(define/public (get-interactions-fields)
|
|
interaction-fields)
|
|
(define/public (clear-interactions)
|
|
(set! interaction-fields null))
|
|
(define/public (add-interactions-box box)
|
|
(set! interaction-boxes (cons box interaction-boxes)))
|
|
(define/public (get-interactions-boxes) (reverse interaction-boxes))
|
|
(define/public (set-execution-loc! loc) (set! execution-loc loc))
|
|
|
|
(define/public (give-interaction-execution-names)
|
|
(when execution-loc
|
|
(hash-table-for-each (hash-table-get class-environment execution-loc)
|
|
(lambda (k v) (add-to-env k v 'interactions)))
|
|
(set! execution-loc #f)))
|
|
|
|
(define test-classes null)
|
|
(define/public (add-test-class name)
|
|
(set! test-classes (cons name test-classes)))
|
|
(define/public (get-test-classes) test-classes)
|
|
|
|
(super-instantiate ())))
|
|
|
|
(define get-importer (class-field-accessor type-records importer))
|
|
(define set-importer! (class-field-mutator type-records importer))
|
|
|
|
;
|
|
|
|
;
|
|
; ;;;; ; ;
|
|
; ; ; ; ;
|
|
; ; ;;;; ;;;;;; ;;;;;; ;;;; ; ;; ;;;;
|
|
; ; ; ;; ; ; ; ;; ;; ; ; ;
|
|
; ; ;; ; ; ; ; ; ; ; ;;
|
|
; ; ; ;;;;;; ; ; ;;;;;; ; ;;;;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;;; ;;; ;;; ;;; ;;; ; ;;;;
|
|
;
|
|
;
|
|
|
|
;get-record: (U class-record procedure) type-records -> class-record
|
|
(define (get-record rec type-recs)
|
|
(cond
|
|
((procedure? rec)
|
|
(let ((location (send type-recs get-location)))
|
|
(begin0 (rec)
|
|
(send type-recs set-location! location))))
|
|
(else rec)))
|
|
|
|
;; get-field-record: string class-record (-> 'a) -> field-record
|
|
(define (get-field-record fname c fail)
|
|
(let ((frec (filter (lambda (f)
|
|
(string=? (field-record-name f) fname))
|
|
(class-record-fields c))))
|
|
(cond
|
|
((null? frec) (fail))
|
|
(else (car frec)))))
|
|
|
|
;get-field-records: class-record -> (list field-record)
|
|
(define (get-field-records c) (class-record-fields c))
|
|
|
|
;; get-method-records: string class-record type-records -> (list method-record)
|
|
(define (get-method-records mname c type-recs)
|
|
(filter (lambda (m)
|
|
(string=? (method-record-name m) mname))
|
|
(if (class-record-class? c)
|
|
(class-record-methods c)
|
|
(append (class-record-methods c) (get-object-methods type-recs)))))
|
|
|
|
(define (get-object-methods type-recs)
|
|
(class-record-methods (send type-recs get-class-record object-type)))
|
|
|
|
;remove-dups: (list method-record) -> (list method-record)
|
|
(define (remove-dups methods)
|
|
(cond
|
|
((null? methods) methods)
|
|
((meth-member? (car methods) (cdr methods))
|
|
(remove-dups (cdr methods)))
|
|
(else (cons (car methods) (remove-dups (cdr methods))))))
|
|
|
|
;meth-member? method-record (list method-record) -> bool
|
|
(define (meth-member? meth methods)
|
|
(and (not (null? methods))
|
|
(or (andmap type=? (method-record-atypes meth)
|
|
(method-record-atypes (car methods)))
|
|
(meth-member? meth (cdr methods)))))
|
|
|
|
;depth: 'a int (listof 'a) -> (U int #f)
|
|
;The position in elt-list that elt is at, starting with 1
|
|
(define (depth elt start elt-list)
|
|
(letrec ((d
|
|
(lambda (elt-list cnt)
|
|
#;(printf "d: elt ~a elt-list ~a~n" elt elt-list)
|
|
(cond
|
|
((null? elt-list) +inf.0)
|
|
((equal? (car elt-list) elt) cnt)
|
|
(else (d (cdr elt-list) (add1 cnt)))))))
|
|
(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
|
|
(define (iface-depth elt ifaces type-recs)
|
|
(if (= 1 (length ifaces))
|
|
1
|
|
(let* ([iface-trees (map (lambda (iface)
|
|
(cons iface
|
|
(class-record-parents
|
|
(get-record (send type-recs get-class-record iface)
|
|
type-recs))))
|
|
ifaces)]
|
|
[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
|
|
(define (conversion-steps from to type-recs)
|
|
#;(printf "conversion-steps ~a ~a~n" from to)
|
|
(cond
|
|
((ref-type? from)
|
|
(let* ((to-name (cons (ref-type-class/iface to) (ref-type-path to)))
|
|
(from-class (send type-recs get-class-record from))
|
|
(from-class-parents (class-record-parents from-class))
|
|
(from-class-ifaces (class-record-ifaces from-class)))
|
|
(cond
|
|
((eq? to 'dynamic) (length from-class-parents))
|
|
((null? from-class-parents)
|
|
(iface-depth to-name from-class-ifaces type-recs))
|
|
((null? from-class-ifaces)
|
|
(depth to-name 1 from-class-parents))
|
|
(else (min (depth to-name 1 from-class-parents)
|
|
(iface-depth to-name from-class-ifaces type-recs))))))
|
|
((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 1 '(short int long float double)))
|
|
((char) (depth to 1 '(byte short int long float double)))
|
|
((short) (depth to 1 '(int long float double)))
|
|
((int) (depth to 1 '(long float double)))
|
|
((long) (depth to 1 '(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 method-args) (car site-args) type-recs)
|
|
(not (type=? (car site-args) (car method-args))))
|
|
(let ((step (conversion-steps (car site-args) (car 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))))
|
|
|
|
;; 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)
|
|
#;(print-struct #t)
|
|
(let* ((a (length arg-types))
|
|
(m-atypes method-record-atypes)
|
|
(a-convert? (lambda (t1 t2) (assignment-conversion t1 t2 type-recs)))
|
|
(methods (remove-dups (filter (lambda (mr) (= a (length (m-atypes mr)))) methods)))
|
|
(methods-same (filter (lambda (mr)
|
|
(andmap type=? (m-atypes mr) arg-types))
|
|
methods))
|
|
(assignable (filter (lambda (mr)
|
|
(andmap a-convert? (m-atypes mr) arg-types))
|
|
methods))
|
|
(sort (lambda (l p) (quicksort l p)))
|
|
(assignable-count (sort
|
|
(map (lambda (mr)
|
|
#;(printf "assigning conversions for ~a~n" (m-atypes mr))
|
|
(list (number-assign-conversions arg-types (m-atypes mr) type-recs)
|
|
mr))
|
|
assignable)
|
|
(lambda (i1 i2) (< (car i1) (car i2))))))
|
|
#;(printf "~a~n" assignable-count)
|
|
(cond
|
|
((null? methods) (arg-count-fail))
|
|
((= 1 (length methods-same)) (car methods-same))
|
|
((> (length methods-same) 1) (method-conflict-fail))
|
|
((null? assignable) (no-method-fail))
|
|
((= 1 (length assignable)) (car assignable))
|
|
((= (car (car assignable-count))
|
|
(car (cadr assignable-count))) (method-conflict-fail))
|
|
(else (cadr (car assignable-count))))))
|
|
|
|
;module-has-binding?: scheme-record string (-> void) -> void
|
|
;module-has-binding raises an exception when variable is not defined in mod-ref
|
|
(define (module-has-binding? mod-ref variable fail)
|
|
(let ((var (string->symbol (java-name->scheme variable))))
|
|
(or (memq var (scheme-record-provides mod-ref))
|
|
(let ((mod-syntax (datum->syntax-object #f
|
|
`(module m mzscheme
|
|
(require ,(generate-require-spec (java-name->scheme (scheme-record-name mod-ref))
|
|
(scheme-record-path mod-ref)))
|
|
,var)
|
|
#f)))
|
|
(with-handlers ((exn? (lambda (e) (fail))))
|
|
(expand mod-syntax))
|
|
(set-scheme-record-provides! mod-ref (cons var (scheme-record-provides mod-ref)))))))
|
|
|
|
;generate-require-spec: string (list string) -> (U string (list symbol string+))
|
|
(define (generate-require-spec name path)
|
|
(let ((mod (string-append name ".ss")))
|
|
(cond
|
|
((null? path) mod)
|
|
((equal? (car path) "lib") `(lib ,mod ,@(cdr path)))
|
|
(else `(file ,(build-path (apply build-path path) mod))))))
|
|
|
|
;java-name->scheme: string -> string
|
|
(define (java-name->scheme name)
|
|
(cond
|
|
((regexp-match "[a-zA-Z0-9]*To[A-Z0-9]*" name)
|
|
(java-name->scheme (regexp-replace "To" name "->")))
|
|
((regexp-match "[a-zA-Z0-9]+P$" name)
|
|
(java-name->scheme (regexp-replace "P$" name "?")))
|
|
((regexp-match "[a-zA-Z0-9]+Set$" name)
|
|
(java-name->scheme (regexp-replace "Set$" name "!")))
|
|
((regexp-match "[a-zA-Z0-9]+Obj$" name)
|
|
(java-name->scheme (regexp-replace "Obj$" name "%")))
|
|
((regexp-match "[a-z0-9]+->[A-Z]" name) =>
|
|
(lambda (substring)
|
|
(let ((char (car (regexp-match "[A-Z]" (car substring)))))
|
|
(java-name->scheme (regexp-replace (string-append "->" char) name
|
|
(string-append "->" (string (char-downcase (car (string->list char))))))))))
|
|
((regexp-match "[a-z0-9]+[A-Z]" name) =>
|
|
(lambda (substring)
|
|
(let ((char (car (string->list (car (regexp-match "[A-Z]" (car substring))))))
|
|
(remainder (car (regexp-match "[a-z0-9]+" (car substring)))))
|
|
(java-name->scheme (regexp-replace (car substring) name
|
|
(string-append remainder "-" (string (char-downcase char))))))))
|
|
(else name)))
|
|
|
|
(define (inner-rec-member name inners)
|
|
(member name (map inner-record-name inners)))
|
|
|
|
;
|
|
; ; ;;
|
|
; ;
|
|
; ;;; ;
|
|
; ; ;
|
|
; ; ;;; ; ;;; ;;;;; ;;;;
|
|
; ; ; ;; ; ; ;; ;;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ;; ; ; ; ; ;; ;;
|
|
; ;;; ;;;;; ; ; ; ;;;;
|
|
;
|
|
|
|
|
|
(define type-version "version4")
|
|
(define type-length 11)
|
|
|
|
;; read-record: path -> (U class-record #f)
|
|
(define (read-record filename)
|
|
(letrec ((parse-class/iface
|
|
(lambda (input)
|
|
(and (= (length input) type-length)
|
|
(equal? type-version (list-ref input 9))
|
|
(or (equal? (version) (list-ref input 10))
|
|
(equal? "ignore" (list-ref input 10)))
|
|
(make-class-record (list-ref input 1)
|
|
(list-ref input 2)
|
|
(symbol=? 'class (car input))
|
|
(list-ref input 3)
|
|
(map parse-field (list-ref input 4))
|
|
(map parse-method (list-ref input 5))
|
|
(map parse-inner (list-ref input 6))
|
|
(list-ref input 7)
|
|
(list-ref input 8)))))
|
|
(parse-field
|
|
(lambda (input)
|
|
(make-field-record (car input)
|
|
(cadr input)
|
|
#f
|
|
(caddr input)
|
|
(parse-type (cadddr input)))))
|
|
(parse-method
|
|
(lambda (input)
|
|
(make-method-record (car input)
|
|
(cadr input)
|
|
(parse-type (caddr input))
|
|
(map parse-type (cadddr input))
|
|
(map parse-type (list-ref input 4))
|
|
#f
|
|
(list-ref input 5))))
|
|
(parse-inner
|
|
(lambda (input)
|
|
(make-inner-record (car input)
|
|
(cadr input)
|
|
(caddr input)
|
|
(symbol=? 'class (cadddr input)))))
|
|
(parse-type
|
|
(lambda (input)
|
|
(cond
|
|
((symbol? input) input)
|
|
((number? (car input))
|
|
(make-array-type (parse-type (cadr input)) (car input)))
|
|
(else
|
|
(make-ref-type (car input) (cdr input)))))))
|
|
(parse-class/iface (call-with-input-file filename read))))
|
|
|
|
;; write-record: class-record port->
|
|
(define (write-record rec port)
|
|
(letrec ((record->list
|
|
(lambda (r)
|
|
(list
|
|
(if (class-record-class? r)
|
|
'class
|
|
'interface)
|
|
(class-record-name r)
|
|
(class-record-modifiers r)
|
|
(class-record-object? r)
|
|
(map field->list (class-record-fields r))
|
|
(map method->list
|
|
(let* ((kept-overrides null)
|
|
(methods
|
|
(filter
|
|
(compose not
|
|
(lambda (meth-rec)
|
|
(and (method-record-override meth-rec)
|
|
(or (equal? (method-record-modifiers meth-rec)
|
|
(method-record-modifiers (method-record-override meth-rec)))
|
|
(not (set! kept-overrides (cons (method-record-override meth-rec) kept-overrides)))))))
|
|
(class-record-methods r))))
|
|
(filter (compose not (lambda (m) (memq m kept-overrides))) methods)))
|
|
(map inner->list (class-record-inners r))
|
|
(class-record-parents r)
|
|
(class-record-ifaces r)
|
|
type-version
|
|
(version))))
|
|
(field->list
|
|
(lambda (f)
|
|
(list
|
|
(field-record-name f)
|
|
(field-record-modifiers f)
|
|
(field-record-class f)
|
|
(type->list (field-record-type f)))))
|
|
(method->list
|
|
(lambda (m)
|
|
(list
|
|
(method-record-name m)
|
|
(method-record-modifiers m)
|
|
(type->list (method-record-rtype m))
|
|
(map type->list (method-record-atypes m))
|
|
(map type->list (method-record-throws m))
|
|
(method-record-class m))))
|
|
(inner->list
|
|
(lambda (i)
|
|
(list (inner-record-name i)
|
|
(inner-record-full-name i)
|
|
(inner-record-modifiers i)
|
|
(if (inner-record-class? i) 'class 'interface))))
|
|
(type->list
|
|
(lambda (t)
|
|
(cond
|
|
((symbol? t) t)
|
|
((ref-type? t) (cons (ref-type-class/iface t) (ref-type-path t)))
|
|
((array-type? t)
|
|
(list (array-type-dim t) (type->list (array-type-type t))))))))
|
|
(pretty-print (record->list rec) port)))
|
|
)
|