2649 lines
143 KiB
Scheme
2649 lines
143 KiB
Scheme
(module to-scheme mzscheme
|
|
(require "ast.ss"
|
|
"types.ss"
|
|
"parameters.ss"
|
|
(lib "class.ss")
|
|
(lib "list.ss")
|
|
(lib "etc.ss"))
|
|
|
|
(provide translate-program translate-interactions (struct compilation-unit (contains code locations depends)))
|
|
|
|
;(make-compilation-unit (list string) (list syntax) (list location) (list (list string)))
|
|
(define-struct compilation-unit (contains code locations depends) (make-inspector))
|
|
|
|
;File takes java AST as defined by ast.ss and produces
|
|
;semantically (hopefully) equivalent scheme code
|
|
|
|
;NOTE! Abstract classes are treated no differently than any class.
|
|
|
|
;Parameters for information about each class
|
|
(define class-name (make-parameter "interactions"))
|
|
(define loc (make-parameter #f))
|
|
(define interactions? (make-parameter #f))
|
|
(define class-override-table (make-parameter null))
|
|
(define parent-name (make-parameter "Object"))
|
|
(define module-name (make-parameter ""))
|
|
(define module-require (make-parameter ""))
|
|
|
|
;Parameters for inforamtion about the types
|
|
(define types (make-parameter null))
|
|
(define current-depth (make-parameter 0))
|
|
(define current-local-classes (make-parameter null))
|
|
|
|
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
|
|
(define (stx-for-source) stx-for-original-property)
|
|
(define (create-syntax oddness sexpression source)
|
|
(datum->syntax-object (or oddness (syntax-location) (stx-for-source)) sexpression source stx-for-original-property))
|
|
(define (make-syntax oddness sexpression source)
|
|
(datum->syntax-object (or oddness (syntax-location) (stx-for-source)) sexpression source))
|
|
|
|
;-------------------------------------------------------------------------------------------------------------
|
|
|
|
;Type abbreviation
|
|
|
|
;The value of this will vary based on information I have at a given time,
|
|
;as well as whether location is from source file or not
|
|
;SrcList => boolean
|
|
; | (list symbol int)
|
|
; | (list symbol int int int)
|
|
|
|
|
|
;------------------------------------------------------------------------------------------------------------
|
|
;Helper functions
|
|
;Functions which are used throughout the transformation
|
|
|
|
;build-identifier: (U string symbol (list string)) -> symbol
|
|
(define (build-identifier name)
|
|
(cond
|
|
((symbol? name) name)
|
|
((string? name) (string->symbol name))
|
|
;PROBLEM might not be best method
|
|
((pair? name) (string->symbol (apply string-append (map (lambda (s) (string-append s ".")) name))))
|
|
(else
|
|
(error 'build-identifier (format "Given ~s" name))
|
|
name)))
|
|
|
|
;build-static-name: string symbol -> string
|
|
(define (build-static-name name . args)
|
|
(format "~a-~a" (if (null? args) (class-name) (car args)) name))
|
|
|
|
;build-src: src -> SrcList
|
|
(define (build-src src)
|
|
(if (not src)
|
|
src
|
|
(if (and (= (src-line src) 0)
|
|
(= (src-col src) 0)
|
|
(= (src-pos src) 0)
|
|
(= (src-span src) 0))
|
|
#f
|
|
(list (or (src-file src) (loc)) (src-line src) (src-col src) (src-pos src) (src-span src)))))
|
|
|
|
;get-defualt-value: type-spec -> syntax
|
|
(define (get-default-value type)
|
|
(let ((name (type-spec-name type)))
|
|
(if (> (type-spec-dim type) 0)
|
|
(make-syntax #f 'null #f)
|
|
(cond
|
|
((prim-numeric-type? name) (make-syntax #f 0 #f))
|
|
((eq? 'char name) (make-syntax #f '#\space #f))
|
|
((eq? 'boolean name) (make-syntax #f '#f #f))
|
|
(else (make-syntax #f 'null #f))))))
|
|
|
|
;create-get-name: string string? -> symbol
|
|
(define (create-get-name name . args)
|
|
(build-identifier (format "~a-~a-get" (if (null? args) (class-name) (car args)) name)))
|
|
|
|
;create-set-name: string string? -> symbol
|
|
(define (create-set-name name . args)
|
|
(build-identifier (format "~a-~a-set!" (if (null? args) (class-name) (car args)) name)))
|
|
|
|
;Methods to determine member restrictions
|
|
;make-mod-test: symbol -> (list -> bool)
|
|
(define (make-mod-test acc) (lambda (m) (memq acc m)))
|
|
(define public? (make-mod-test 'public))
|
|
(define private? (make-mod-test 'private))
|
|
(define protected? (make-mod-test 'protected))
|
|
(define static? (make-mod-test 'static))
|
|
(define abstract? (make-mod-test 'abstract))
|
|
(define final? (make-mod-test 'final))
|
|
|
|
;get-class-name: (U name type-spec) -> syntax
|
|
(define (get-class-name name)
|
|
(if (type-spec? name)
|
|
(set! name (type-spec-name name)))
|
|
(if (null? (name-path name))
|
|
(translate-id (id-string (name-id name))
|
|
(id-src (name-id name)))
|
|
(create-syntax #f
|
|
(build-identifier (get-class-string name))
|
|
(build-src (name-src name)))))
|
|
|
|
;get-class-string: name -> string
|
|
(define (get-class-string name)
|
|
(format "~a~a" (apply string-append (map (lambda (s)
|
|
(string-append s "."))
|
|
(map id-string (name-path name))))
|
|
(id-string (name-id name))))
|
|
|
|
;build-var-name: string -> string
|
|
(define (build-var-name id) (format "~a~~f" id))
|
|
|
|
;build-generic-name: string string -> string
|
|
(define (build-generic-name class name) (format "~a-~a~~generic" class name))
|
|
|
|
;build-method-name: string (list type) -> string
|
|
(define (mangle-method-name id types)
|
|
(letrec ((parm-name
|
|
(lambda (t)
|
|
(format "-~a"
|
|
(cond
|
|
((symbol? t) t)
|
|
((ref-type? t)
|
|
(string-append (apply string-append (map (lambda (p) (string-append p "."))
|
|
(ref-type-path t)))
|
|
(ref-type-class/iface t)))
|
|
((array-type? t)
|
|
(string-append (let ((s (parm-name (array-type-type t))))
|
|
(substring s 1 (string-length s)))
|
|
(format "~a" (array-type-dim t))))
|
|
(else (error 'mangle-method-name (format "Internal Error: given unexptected type ~a" t))))))))
|
|
(format "~a~a" id (apply string-append (map parm-name types)))))
|
|
|
|
;constructor? string -> bool
|
|
(define (constructor? name)
|
|
(equal? name (class-name)))
|
|
|
|
;build-constructor-name: string (list type) -> string
|
|
(define (build-constructor-name class-name args)
|
|
(mangle-method-name (format "~a-constructor" class-name) args))
|
|
|
|
;-------------------------------------------------------------------------------------------------------------------------
|
|
;Translation
|
|
|
|
;translate-interactions: ast location type-records boolean-> syntax
|
|
(define (translate-interactions prog location type-recs gen-reqs?)
|
|
(loc location)
|
|
(interactions? #t)
|
|
(types type-recs)
|
|
(class-name "interactions")
|
|
(let ((reqs (send type-recs get-class-reqs))
|
|
(syn (cond
|
|
((pair? prog)
|
|
(send type-recs set-class-reqs null)
|
|
(make-syntax #f
|
|
`(begin ,@(map (lambda (f)
|
|
(translate-interactions f location type-recs gen-reqs?))
|
|
prog))
|
|
#f))
|
|
((field? prog)
|
|
(translate-field `(private)
|
|
(field-type-spec prog)
|
|
(field-name prog)
|
|
(and (var-init? prog) prog)
|
|
(if (var-init? prog)
|
|
(var-init-src prog)
|
|
(var-decl-src prog))
|
|
#f))
|
|
((statement? prog) (translate-statement prog type-recs))
|
|
((expr? prog) (translate-expression prog))
|
|
(else
|
|
(error 'translate-interactions "Internal Error: translate-interactions given ~a" prog)))))
|
|
(if (or (null? reqs) (not gen-reqs?))
|
|
syn
|
|
(make-syntax #f
|
|
`(begin (require ,@(remove-dup-syntax (translate-interact-require reqs type-recs)))
|
|
,syn)
|
|
#f))))
|
|
|
|
;translate-program: package type-records -> (list compilation-unit)
|
|
(define (translate-program program type-recs)
|
|
(types type-recs)
|
|
(interactions? #f)
|
|
(let* ((package-path (if (package-name program)
|
|
(append (map id-string (name-path (package-name program)))
|
|
(list (id-string (name-id (package-name program)))))
|
|
null))
|
|
(full-defs (if (null? (packages)) (package-defs program) (append (packages) (package-defs program))))
|
|
(dependent-defs (find-dependent-defs full-defs type-recs))
|
|
(modules (map (lambda (defs)
|
|
(let*-values (((ordered-defs) (order-defs defs))
|
|
((translated-defs reqs) (translate-defs ordered-defs type-recs)))
|
|
(make-compilation-unit (map (lambda (def) (id-string (def-name def))) ordered-defs)
|
|
translated-defs
|
|
(map def-file ordered-defs)
|
|
reqs)))
|
|
dependent-defs)))
|
|
modules))
|
|
|
|
;get-package: definition type-records -> (list string)
|
|
(define (get-package def type-recs)
|
|
(send type-recs set-location! (def-file def))
|
|
(send type-recs lookup-path (id-string (def-name def)) (lambda () (error 'internal-error))))
|
|
|
|
;find-dependent-defs: (list defs) -> (list (list defs))
|
|
(define (find-dependent-defs defs type-recs)
|
|
(let* ((for-each-def (lambda (defs thunk) (for-each thunk defs)))
|
|
(find
|
|
(lambda (req)
|
|
(letrec ((walker
|
|
(lambda (defs)
|
|
(and (not (null? defs))
|
|
(if (and (equal? (req-path req)
|
|
(get-package (car defs) type-recs))
|
|
(equal? (req-class req)
|
|
(id-string (def-name (car defs)))))
|
|
(car defs)
|
|
(walker (cdr defs)))))))
|
|
(walker defs))))
|
|
(get-requires
|
|
(lambda (def)
|
|
(filter (lambda (x) x) (map find (def-uses def)))))
|
|
)
|
|
(get-strongly-connected-components defs for-each-def get-requires)))
|
|
|
|
;get-strongly-connected-components: GRAPH (GRAPH (NODE -> void) -> void) (NODE -> (list NODE)) -> (list (list NODE))
|
|
(define (get-strongly-connected-components graph for-each-node get-connected-nodes)
|
|
|
|
(let ((marks (make-hash-table))
|
|
(strongly-connecteds null)
|
|
(cur-cycle-length 0)
|
|
(current-cycle null))
|
|
|
|
(letrec ((already-in-cycle? (lambda (n) (eq? 'in-cycle (hash-table-get marks n))))
|
|
|
|
(in-current-cycle?
|
|
(lambda (n) (hash-table-get current-cycle n (lambda () #f))))
|
|
(current-cycle-memq
|
|
(lambda (nodes)
|
|
(ormap in-current-cycle? nodes)))
|
|
(add-to-current-cycle
|
|
(lambda (n)
|
|
(set! cur-cycle-length (add1 cur-cycle-length))
|
|
(hash-table-put! current-cycle n #t)))
|
|
(retrieve-current-cycle
|
|
(lambda () (hash-table-map current-cycle (lambda (key v) key))))
|
|
|
|
(componentize
|
|
(lambda (node successors member?)
|
|
(unless (already-in-cycle? node)
|
|
;(printf "componentize ~a ~a ~a~n" node successors member?)
|
|
(let ((added? #f)
|
|
(cur-length cur-cycle-length))
|
|
(when (and (not member?) (current-cycle-memq successors))
|
|
(set! added? #t)
|
|
(add-to-current-cycle node))
|
|
(hash-table-put! marks node 'in-progress)
|
|
(for-each
|
|
(lambda (successor)
|
|
(unless (or (in-current-cycle? successor)
|
|
(eq? 'in-progress (hash-table-get marks successor)))
|
|
(componentize successor (get-connected-nodes successor) #f)))
|
|
successors)
|
|
;(printf "finished successors for ~a~n" node)
|
|
(if (or added? (= cur-length cur-cycle-length))
|
|
(hash-table-put! marks node 'no-info)
|
|
(componentize node successors #f)))))))
|
|
|
|
(for-each-node graph (lambda (n) (hash-table-put! marks n 'no-info)))
|
|
|
|
(for-each-node graph
|
|
(lambda (node)
|
|
(when (eq? (hash-table-get marks node) 'no-info)
|
|
(set! current-cycle (make-hash-table))
|
|
(add-to-current-cycle node)
|
|
(for-each (lambda (node) (componentize node (get-connected-nodes node) #f))
|
|
(get-connected-nodes node))
|
|
(set! strongly-connecteds (cons (retrieve-current-cycle) strongly-connecteds))
|
|
(hash-table-for-each
|
|
current-cycle
|
|
(lambda (n v) (hash-table-put! marks n 'in-a-cycle))))))
|
|
|
|
strongly-connecteds)))
|
|
|
|
;order-defs: (list def) -> (list def)
|
|
(define (order-defs defs)
|
|
(reverse
|
|
(let loop ((ordered-defs null)
|
|
(local-defs defs))
|
|
(cond
|
|
((null? local-defs) ordered-defs)
|
|
((add-def? (car local-defs) local-defs ordered-defs)
|
|
(loop (cons (car local-defs) ordered-defs)
|
|
(cdr local-defs)))
|
|
(else
|
|
(loop ordered-defs (append (cdr local-defs) (list (car local-defs)))))))))
|
|
|
|
;add-def? def (list def) (list def) -> bool
|
|
(define (add-def? def local-defs ordered-defs)
|
|
(andmap (lambda (e)
|
|
(satisfied-extend? e local-defs ordered-defs))
|
|
(append (header-extends (def-header def))
|
|
(header-implements (def-header def)))))
|
|
|
|
;satisified-extend? id (list def) (list def) -> bool
|
|
(define (satisfied-extend? extend local-defs ordered-defs)
|
|
(or (null? extend)
|
|
(not (member (id-string (name-id extend))
|
|
(map id-string (map def-name local-defs))))
|
|
(member (id-string (name-id extend))
|
|
(map id-string (map def-name ordered-defs)))))
|
|
|
|
;make-composite-name: def -> string
|
|
(define (make-composite-name d)
|
|
(build-identifier (string-append (id-string (header-id (def-header d))) "-composite")))
|
|
|
|
;translate-defs: (list def) type-records -> (values (list syntax) (list reqs))
|
|
(define (translate-defs defs type-recs)
|
|
(module-name (make-composite-name (car defs)))
|
|
(module-require (if (to-file)
|
|
(let ((location (build-path (begin (send type-recs set-location! (def-file (car defs)))
|
|
(send type-recs get-compilation-location) "compiled")
|
|
(string-append (symbol->string (module-name)) ".zo"))))
|
|
(for-each
|
|
(lambda (def)
|
|
(send type-recs set-composite-location (id-string (def-name def)) location))
|
|
defs)
|
|
`(file ,(path->string (build-path (string-append (symbol->string (module-name)) ".zo")))))
|
|
(module-name)))
|
|
(let* ((translated-defs (map (lambda (d)
|
|
(if (class-def? d)
|
|
(translate-class d type-recs 0)
|
|
(translate-interface d type-recs)))
|
|
defs))
|
|
(group-reqs (apply append (map (lambda (d)
|
|
(map (lambda (r) (list (def-file d) r)) (def-uses d)))
|
|
defs)))
|
|
(reqs (filter-reqs group-reqs defs type-recs)))
|
|
(values (if (> (length translated-defs) 1)
|
|
(cons (make-syntax #f `(module ,(module-name) mzscheme
|
|
(require (lib "class.ss")
|
|
(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))
|
|
(prefix c: (lib "contract.ss"))
|
|
,@(remove-dup-syntax (translate-require reqs type-recs)))
|
|
,@(map car translated-defs))
|
|
#f)
|
|
(map cadr translated-defs))
|
|
(list (make-syntax #f
|
|
`(module ,(build-identifier (regexp-replace "-composite"
|
|
(symbol->string (module-name))
|
|
""))
|
|
mzscheme
|
|
(require (lib "class.ss")
|
|
(prefix javaRuntime: (lib "runtime.scm" "profj" "libs" "java"))
|
|
(prefix c: (lib "contract.ss"))
|
|
,@(remove-dup-syntax
|
|
(translate-require (map (lambda (r) (list (def-file (car defs)) r))
|
|
(def-uses (car defs)))
|
|
type-recs)))
|
|
,(car (car translated-defs)))
|
|
#f)))
|
|
(filter (lambda (req) (not (member req reqs)))
|
|
(map (lambda (r-pair) (cadr r-pair)) group-reqs)))))
|
|
|
|
;filter-reqs: (list (list location req)) (list def) type-records -> (list req)
|
|
(define (filter-reqs reqs defs type-recs)
|
|
(if (null? reqs)
|
|
null
|
|
(if (or (reference (car reqs) defs type-recs)
|
|
(req-member (car reqs) (cdr reqs)))
|
|
(filter-reqs (cdr reqs) defs type-recs)
|
|
(cons (car reqs) (filter-reqs (cdr reqs) defs type-recs)))))
|
|
|
|
;reference: (list req location) (list def) type-records -> bool
|
|
(define (reference req defs type-recs)
|
|
(and (not (null? defs))
|
|
(or (and (equal? (req-path (cadr req)) (get-package (car defs) type-recs))
|
|
(equal? (req-class (cadr req)) (id-string (def-name (car defs)))))
|
|
(reference req (cdr defs) type-recs))))
|
|
|
|
;req-member: (list location req) (list (list location req)) -> bool
|
|
(define (req-member req reqs)
|
|
(and (not (null? reqs))
|
|
(or (equal? (cadr req) (cadr (car reqs)))
|
|
(req-member req (cdr reqs)))))
|
|
|
|
;remove-dup-syntax: (list syntax) -> (list syntax)
|
|
(define (remove-dup-syntax syn)
|
|
(letrec ((remove
|
|
(lambda (duped syn)
|
|
(if (null? syn)
|
|
null
|
|
(if (eq? duped (car syn))
|
|
(remove duped (cdr syn))
|
|
(cons (car syn) (remove duped (cdr syn)))))))
|
|
(remove-dups
|
|
(lambda (syn)
|
|
(if (null? syn)
|
|
null
|
|
(if (memq (car syn) (cdr syn))
|
|
(cons (car syn) (remove-dups (remove (car syn) (cdr syn))))
|
|
(cons (car syn) (remove-dups (cdr syn))))))))
|
|
(remove-dups syn)))
|
|
|
|
;translate-interact-require: (list reg) type-record -> (list syntax)
|
|
(define (translate-interact-require reqs type-recs)
|
|
(if (null? reqs)
|
|
null
|
|
(let ((req (car reqs)))
|
|
(cons (begin (send type-recs set-location! 'interactions)
|
|
(send type-recs get-require-syntax
|
|
(send type-recs require-prefix?
|
|
(cons (req-class req) (req-path req))
|
|
(lambda () #f))
|
|
(cons (req-class req) (req-path req))
|
|
(lambda () #f)))
|
|
(translate-interact-require (cdr reqs) type-recs)))))
|
|
|
|
;translate-require: (list (list location req)) type-records -> (list syntax)
|
|
(define (translate-require reqs type-recs)
|
|
(cond
|
|
((null? reqs) null)
|
|
((member (cadr (car reqs))
|
|
(list (make-req "Class" '("java" "lang"))
|
|
(make-req "PrintStream" '("java" "io"))
|
|
(make-req "PrintWriter" '("java" "io"))))
|
|
(translate-require (cdr reqs) type-recs))
|
|
(else
|
|
(let* ((req (cadr (car reqs)))
|
|
(err (lambda ()
|
|
(error 'translate-require
|
|
(format "Internal Error: (make-req ~a ~a) not found"
|
|
(req-class req) (req-path req))))))
|
|
(cons (begin (send type-recs set-location! (car (car reqs)))
|
|
(send type-recs get-require-syntax
|
|
(send type-recs require-prefix?
|
|
(cons (req-class req) (req-path req))
|
|
err)
|
|
(cons (req-class req) (req-path req))
|
|
err))
|
|
(translate-require (cdr reqs) type-recs))))))
|
|
|
|
;translate-implements: (list name) -> (list syntax)
|
|
(define (translate-implements imp)
|
|
(map (lambda (i)
|
|
(let* ((id (name-id i))
|
|
(st (id-string id))
|
|
(path (name-path i)))
|
|
(if (null? path)
|
|
(translate-id st (id-src id))
|
|
(create-syntax #f (build-identifier (append (map id-string path) (list st)))
|
|
(build-src (name-src i))))))
|
|
imp))
|
|
|
|
;translate-class: class-def type-records -> (list syntax syntax)
|
|
(define (translate-class class type-recs depth)
|
|
;Let's grab onto the enclosing class-specific info incase depth > 0
|
|
(let ((old-class-name (class-name))
|
|
(old-parent-name (parent-name))
|
|
(old-override-table (class-override-table)))
|
|
(unless (> depth 0) (loc (def-file class)))
|
|
|
|
(let*-values (((header) (def-header class))
|
|
((kind) (def-kind class))
|
|
((closure-args) (def-closure-args class))
|
|
((parent parent-src extends-object?)
|
|
(if (null? (header-extends header))
|
|
(values "Object" #f #t)
|
|
(let-values (((p p-s) (get-parent (header-extends header))))
|
|
(values p p-s
|
|
(class-record-object?
|
|
(send type-recs get-class-record
|
|
(name->type (car (header-extends header)) #f #f 'full type-recs)))))))
|
|
((class*) (create-syntax #f 'class* (build-src (def-key-src class))))
|
|
((class-members) (separate-members (def-members class)))
|
|
((methods) (separate-methods (members-method class-members) (make-accesses null null null null null null)))
|
|
((fields) (separate-fields (members-field class-members) (make-accesses null null null null null null))))
|
|
|
|
;set class specific parameters - old ones are safe
|
|
(class-name (id-string (header-id header)))
|
|
(parent-name parent)
|
|
(class-override-table (make-hash-table))
|
|
|
|
(let* ((class (translate-id (class-name) (id-src (header-id header))))
|
|
(overridden-methods (get-overridden-methods (append (accesses-public methods)
|
|
(accesses-package methods)
|
|
(accesses-protected methods))))
|
|
(restricted-methods (make-method-names ;(append (accesses-package methods)
|
|
(accesses-protected methods);)
|
|
overridden-methods))
|
|
#;(make-gen-name
|
|
(lambda (m)
|
|
(build-generic-name (class-name)
|
|
((if (constructor? (id-string (method-name m))) build-constructor-name mangle-method-name)
|
|
(id-string (method-name m))
|
|
(method-record-atypes (method-rec m))))))
|
|
#;(providable-generics
|
|
(map make-gen-name
|
|
(append (accesses-public methods)
|
|
(accesses-package methods)
|
|
(accesses-protected methods))))
|
|
#;(private-generics (map make-gen-name (accesses-private methods)))
|
|
(names-for-dynamic (generate-dynamic-names (append (accesses-public methods)
|
|
(accesses-package methods)
|
|
(accesses-protected methods))
|
|
overridden-methods))
|
|
#;(dynamic-method-defs (generate-dyn-method-defs names-for-dynamic))
|
|
(wrapper-classes (append (generate-wrappers (class-name)
|
|
(parent-name)
|
|
(filter
|
|
(lambda (m) (not (or (private? (method-record-modifiers m))
|
|
(static? (method-record-modifiers m)))))
|
|
(class-record-methods (send type-recs get-class-record (list (class-name)))))
|
|
(append (accesses-public fields) (accesses-package fields)
|
|
(accesses-protected fields)))
|
|
(generate-contract-defs (class-name))))
|
|
(static-method-names (make-static-method-names (accesses-static methods) type-recs))
|
|
(static-field-names (make-static-field-names (accesses-static fields)))
|
|
(static-field-setters (make-static-field-setters-names
|
|
(filter (lambda (f) (not (final?
|
|
(map modifier-kind (field-modifiers f)))))
|
|
(accesses-static fields))))
|
|
(field-getters/setters (make-field-accessor-names (append (accesses-public fields)
|
|
(accesses-package fields)
|
|
(accesses-protected fields))))
|
|
(provides `(provide ,(build-identifier (class-name))
|
|
,@(map build-identifier (list (format "guard-convert-~a" (class-name))
|
|
(format "convert-assert-~a" (class-name))
|
|
(format "wrap-convert-assert-~a" (class-name))
|
|
(format "dynamic-~a/c" (class-name))
|
|
(format "static-~a/c" (class-name))))
|
|
;,@restricted-methods
|
|
,@(map build-identifier static-method-names)
|
|
,@(map build-identifier static-field-names)
|
|
,@static-field-setters
|
|
#;,@(map build-identifier providable-generics)
|
|
,@field-getters/setters)))
|
|
|
|
(let ((class-syntax
|
|
(create-syntax
|
|
#f
|
|
`(begin ,(unless (or (memq 'private (map modifier-kind (header-modifiers header)))
|
|
(eq? 'anonymous kind)
|
|
(eq? 'statement kind))
|
|
provides)
|
|
,@(if (null? restricted-methods)
|
|
null
|
|
(list (create-local-names (append (make-method-names (accesses-private methods) null)
|
|
restricted-methods))))
|
|
(define ,class
|
|
(,class* ,(if extends-object?
|
|
(translate-id parent parent-src)
|
|
`(Object-Mix ,(translate-id parent parent-src)))
|
|
,(translate-implements (header-implements header))
|
|
|
|
(super-instantiate ())
|
|
|
|
,@(if (> depth 0)
|
|
`((init-field
|
|
,@(let loop ((d depth))
|
|
(cond
|
|
((= d 0) null)
|
|
(else
|
|
(cons (string->symbol (format "encl-this-~a~~f" d))
|
|
(loop (sub1 d))))))))
|
|
null)
|
|
|
|
,@(if (null? closure-args)
|
|
null
|
|
`((init-field
|
|
,@(let loop ((args
|
|
(map id-string closure-args)))
|
|
(cond
|
|
((null? args) null)
|
|
(else (cons (string->symbol (format "~a~~f" (car args)))
|
|
(loop (cdr args)))))))))
|
|
,@(map (lambda (f) (translate-field (map modifier-kind (field-modifiers f))
|
|
(field-type-spec f)
|
|
(field-name f)
|
|
(and (var-init? f) f)
|
|
(if (var-init? f)
|
|
(var-init-src f)
|
|
(var-decl-src f))
|
|
#f))
|
|
(append (accesses-public fields)
|
|
(accesses-package fields)
|
|
(accesses-protected fields)
|
|
(accesses-private fields)))
|
|
,@(create-private-setters/getters (accesses-private fields))
|
|
|
|
,@(generate-inner-makers (members-inner class-members)
|
|
depth type-recs)
|
|
|
|
|
|
,@(map (lambda (m) (translate-method (method-type m)
|
|
(map modifier-kind (method-modifiers m))
|
|
(method-name m)
|
|
(method-parms m)
|
|
(method-body m)
|
|
(method-all-tail? m)
|
|
(method-src m)
|
|
(> depth 0)
|
|
depth
|
|
(method-rec m)
|
|
type-recs))
|
|
(append (accesses-public methods)
|
|
(accesses-package methods)
|
|
(accesses-protected methods)
|
|
(accesses-private methods)))
|
|
|
|
;,@dynamic-method-defs
|
|
|
|
(define/override (my-name) ,(class-name))
|
|
|
|
,@(let ((non-static-fields
|
|
(append (accesses-public fields)
|
|
(accesses-package fields)
|
|
(accesses-protected fields)
|
|
(accesses-private fields))))
|
|
(if (null? non-static-fields)
|
|
null
|
|
`((define/override (field-names)
|
|
(append (super field-names)
|
|
(list ,@(map
|
|
(lambda (n) (id-string (field-name n)))
|
|
non-static-fields
|
|
))))
|
|
(define/override (field-values)
|
|
(append (super field-values)
|
|
(list ,@(map
|
|
(lambda (n) (build-identifier (build-var-name (id-string (field-name n)))))
|
|
non-static-fields)))))))
|
|
|
|
(define field-accessors ,(build-field-table create-get-name 'get fields))
|
|
(define field-setters ,(build-field-table create-set-name 'set fields))
|
|
(define private-methods
|
|
,(if (null? (accesses-private methods))
|
|
'(make-hash-table)
|
|
(build-method-table (accesses-private methods) null #;private-generics)))
|
|
|
|
,@(map (lambda (i) (translate-initialize (initialize-static i)
|
|
(initialize-block i)
|
|
(initialize-src i)
|
|
type-recs))
|
|
(members-init class-members))
|
|
|
|
))
|
|
|
|
,@wrapper-classes
|
|
|
|
#;,@(create-generic-methods (append (accesses-public methods)
|
|
(accesses-package methods)
|
|
(accesses-protected methods)
|
|
(accesses-private methods)))
|
|
|
|
,@(create-field-accessors field-getters/setters
|
|
(append (accesses-public fields)
|
|
(accesses-package fields)
|
|
(accesses-protected fields)))
|
|
,@(map (lambda (def) (translate-class def type-recs (add1 depth)))
|
|
(members-inner class-members))
|
|
,@(create-static-methods (append static-method-names
|
|
(make-static-method-names
|
|
(accesses-private-static methods)
|
|
type-recs))
|
|
(append (accesses-static methods)
|
|
(accesses-private-static methods))
|
|
type-recs)
|
|
,@(create-static-fields (append static-field-names
|
|
(make-static-field-names (accesses-private-static fields)))
|
|
(append (accesses-static fields)
|
|
(accesses-private-static fields)))
|
|
,@(create-static-setters static-field-setters
|
|
(filter (lambda (f) (not (final?
|
|
(map modifier-kind (field-modifiers f)))))
|
|
(accesses-static fields)))
|
|
,@(map (lambda (i) (translate-initialize (initialize-static i)
|
|
(initialize-block i)
|
|
(initialize-src i)
|
|
type-recs))
|
|
(members-static-init class-members))
|
|
|
|
)
|
|
#f)))
|
|
|
|
;reset the old class-specific info if in inner-class
|
|
(begin0
|
|
(if (> depth 0)
|
|
class-syntax
|
|
(list class-syntax
|
|
(make-syntax
|
|
#f
|
|
`(module ,(build-identifier (class-name)) mzscheme (require ,(module-require)) ,provides)
|
|
#f)))
|
|
(when (> depth 0)
|
|
(class-name old-class-name)
|
|
(parent-name old-parent-name)
|
|
(class-override-table old-override-table))))))))
|
|
|
|
;generate-contract-defs: string -> (list sexp)
|
|
(define (generate-contract-defs class-name)
|
|
`((define ,(build-identifier (string-append "dynamic-" class-name "/c"))
|
|
(c:flat-named-contract ,class-name
|
|
(lambda (v) (is-a? v ,(build-identifier (string-append "convert-assert-" class-name))))))
|
|
(define ,(build-identifier (string-append "static-" class-name "/c"))
|
|
(c:flat-named-contract ,class-name
|
|
(lambda (v) (is-a? v ,(build-identifier (string-append "guard-convert-" class-name))))))))
|
|
|
|
;generate-wrappers: string (list method-record) (list field) -> (list sexp)
|
|
(define (generate-wrappers class-name super-name methods fields)
|
|
(let* ((wrapped-methods
|
|
(filter
|
|
(lambda (m)
|
|
#;(printf "~a (~a : ~a ~a)~n" (method-record-name m) (method-record-class m) class-name
|
|
(method-record-override m))
|
|
(and (not (eq? (method-record-rtype m) 'ctor))
|
|
(equal? (car (method-record-class m)) class-name)
|
|
(not (method-record-override m))))
|
|
methods))
|
|
(add-ca
|
|
(lambda (name) (build-identifier (string-append "convert-assert-" name))))
|
|
(add-gc
|
|
(lambda (name) (build-identifier (string-append "guard-convert-" name))))
|
|
(class-text
|
|
(lambda (name super-name from-dynamic? extra-methods)
|
|
`(define ,name
|
|
(class ,super-name
|
|
(init w* p* n* s* c*)
|
|
(define-values (wrapped-obj pos-blame neg-blame src* cc-marks) (values null null null null null))
|
|
(set! wrapped-obj w*)
|
|
(set! pos-blame p*)
|
|
(set! neg-blame n*)
|
|
(set! src* s*)
|
|
(set! cc-marks c*)
|
|
(super-instantiate (w* p* n* s* c*))
|
|
|
|
,(generate-wrapper-fields fields from-dynamic?)
|
|
|
|
,@(generate-wrapper-methods
|
|
(filter (lambda (m) (not (eq? (method-record-rtype m) 'ctor)))
|
|
wrapped-methods) #f from-dynamic?)
|
|
,@extra-methods
|
|
))))
|
|
(dynamic-callables (refine-method-list wrapped-methods)))
|
|
(list
|
|
`(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c)
|
|
(let ((raise-error
|
|
(lambda (method-name num-args)
|
|
(raise (make-exn:fail
|
|
(format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args"
|
|
n p method-name num-args) s)))))
|
|
(and ,@(map method->check/error
|
|
(filter (lambda (m) (not (eq? 'ctor (method-record-rtype m)))) wrapped-methods))))
|
|
#;(c:contract ,(methods->contract (filter (lambda (m) (not (eq? 'ctor (method-record-rtype m))))
|
|
methods)) obj p n s)
|
|
(make-object ,(add-ca class-name) obj p n s c))
|
|
(class-text (add-ca class-name) (add-ca super-name) #t null)
|
|
(class-text (add-gc class-name) (add-gc super-name) #f
|
|
(generate-wrapper-methods dynamic-callables #t #f)))))
|
|
|
|
;generate-wrapper-fields: (list field) boolean -> sexp
|
|
(define (generate-wrapper-fields fields from-dynamic?)
|
|
`(field ,@(map (lambda (field)
|
|
(let* ((field-name (id-string (field-name field)))
|
|
(value `(,(create-get-name field-name) wrapped-obj)))
|
|
`(,(build-identifier (build-var-name field-name))
|
|
,(convert-value (if from-dynamic? (assert-value value (field-type field) #t 'field field-name) value)
|
|
(field-type field)
|
|
from-dynamic?))))
|
|
fields)))
|
|
|
|
;generate-wrapper-methods: (list method-record) boolean boolean -> (list sexp)
|
|
;When is dynamic-callable?, will define methods callable from a dynamic context
|
|
(define (generate-wrapper-methods methods dynamic-callable? from-dynamic?)
|
|
(map (lambda (method)
|
|
(let* ((call-name (mangle-method-name (method-record-name method)
|
|
(method-record-atypes method)))
|
|
(define-name (if dynamic-callable? (java-name->scheme (method-record-name method)) call-name))
|
|
(list-of-args (map (lambda (a) (gensym "arg-")) (method-record-atypes method))))
|
|
(cond
|
|
((and dynamic-callable? (equal? define-name call-name))
|
|
`(void))
|
|
(from-dynamic?
|
|
`(define/public (,(build-identifier define-name) ,@list-of-args)
|
|
,(convert-value (assert-value `(send wrapped-obj ,(build-identifier call-name)
|
|
,@(map (lambda (arg type)
|
|
(convert-value (assert-value arg type #f) type #f))
|
|
list-of-args (method-record-atypes method)))
|
|
(method-record-rtype method) from-dynamic? 'method-ret (method-record-name method))
|
|
(method-record-rtype method)
|
|
from-dynamic?)))
|
|
(else
|
|
`(define/public (,(build-identifier define-name) . args)
|
|
(unless (= (length args) ,(length list-of-args))
|
|
(raise (make-exn:fail:contract:arity
|
|
(string->immutable-string
|
|
(format "~a broke the contract with ~a here, method ~a of ~a called with ~a args, instead of ~a"
|
|
neg-blame pos-blame ,(method-record-name method) ,(class-name) (length args) ,(length list-of-args)))
|
|
cc-marks)))
|
|
(let (,@(map (lambda (arg type ref)
|
|
`(,arg ,(convert-value (assert-value `(list-ref args ,ref) type #t 'method-arg (method-record-name method)) type #t)))
|
|
list-of-args (method-record-atypes method) (list-from 0 (length list-of-args))))
|
|
,(convert-value `(send wrapped-obj ,(build-identifier call-name)
|
|
,@list-of-args) (method-record-rtype method) #f)))))))
|
|
methods))
|
|
|
|
(define (list-from from to)
|
|
(cond
|
|
((= from to) null)
|
|
(else (cons from (list-from (add1 from) to)))))
|
|
|
|
;methods->contract: (list method-record) -> sexp
|
|
(define (methods->contract methods)
|
|
`(c:object-contract ,@(map (lambda (m)
|
|
`(,(build-identifier (mangle-method-name (method-record-name m)
|
|
(method-record-atypes m)))
|
|
(c:-> ,@(map (lambda (a) 'c:any/c) (method-record-atypes m)) c:any/c)))
|
|
methods)))
|
|
|
|
;method->check/error: method-record -> sexp
|
|
(define (method->check/error method)
|
|
(let* ((name (method-record-name method))
|
|
(m-name (mangle-method-name name (method-record-atypes method)))
|
|
(num-args (length (method-record-atypes method))))
|
|
`(or (object-method-arity-includes? obj
|
|
(quote ,(build-identifier m-name))
|
|
,num-args)
|
|
(raise-error ,name ,num-args))))
|
|
|
|
;convert-value: sexp type boolean -> sexp
|
|
(define (convert-value value type from-dynamic?)
|
|
(cond
|
|
((symbol? type)
|
|
(case type
|
|
((int byte short long float double char boolean dynamic void) value)
|
|
((string) (if from-dynamic?
|
|
`(make-java-string ,value)
|
|
`(send ,value get-mzscheme-string)))))
|
|
((dynamic-val? type) value)
|
|
((array-type? type) value
|
|
#;(if from-dynamic?
|
|
`(wrap-convert-assert-array ,value pos-blame neg-blame src* cc-marks)
|
|
`(make-object guard-convert-array ,value pos-blame neg-blame src* cc-marks)))
|
|
((ref-type? type)
|
|
(cond
|
|
((and (equal? string-type type) from-dynamic?) `(make-java-string ,value))
|
|
((equal? string-type type) `(send ,value get-mzscheme-string))
|
|
((member type (list
|
|
(make-ref-type "Class" '("java" "lang"))
|
|
(make-ref-type "PrintStream" '("java" "io"))
|
|
(make-ref-type "PrintWriter" '("java" "io")))) value)
|
|
(from-dynamic? `(,(build-identifier (string-append "wrap-convert-assert-" (ref-type-class/iface type)))
|
|
,value pos-blame neg-blame src* cc-marks))
|
|
(else `(make-object ,(build-identifier (string-append "guard-convert-" (ref-type-class/iface type)))
|
|
,value pos-blame neg-blame src* cc-marks))))
|
|
(else value)))
|
|
|
|
;assert-value: sexp type boolean -> sexp
|
|
(define assert-value
|
|
(opt-lambda (value type from-dynamic? (kind 'unspecified) (name #f))
|
|
(cond
|
|
((symbol? type)
|
|
(let ((check
|
|
(lambda (ok?)
|
|
`(let ((v-1 ,value))
|
|
(if (,ok? v-1) v-1
|
|
(raise (make-exn:fail (string->immutable-string
|
|
,(case kind
|
|
((unspecified)
|
|
`(format "~a broke the contract with ~a here, type-mismatch expected ~a given ~a"
|
|
neg-blame pos-blame (quote ,type) v-1))
|
|
((field)
|
|
`(format "~a broke the contract with ~a here, type-mismatch for field ~a of class ~a: expected ~a given ~a"
|
|
neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1))
|
|
((method-arg)
|
|
`(format "~a broke the contract with ~a here, type-mismatch for method argument of ~a in class ~a: expected ~a given ~a"
|
|
neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1))
|
|
((method-ret)
|
|
`(format "~a broke the contract with ~a here, type-mismatch for method return of ~a in ~a: expected ~a given ~a"
|
|
neg-blame pos-blame ,name ,(class-name) (quote ,type) v-1)))
|
|
) cc-marks)))))))
|
|
(case type
|
|
((int byte short long) (check 'integer?))
|
|
((float double) (check 'real?))
|
|
((char) (check 'char?))
|
|
((string) (check 'string?))
|
|
((boolean) (check 'boolean?))
|
|
((dynamic) value))))
|
|
((and (ref-type? type) (equal? string-type type))
|
|
(assert-value value 'string from-dynamic? kind name))
|
|
(else value))))
|
|
|
|
;Removes from the list all methods that are not callable from a dynamic context
|
|
;refine-method-list: (list method-record) -> (list method-record)
|
|
(define (refine-method-list methods)
|
|
(cond
|
|
((null? methods) methods)
|
|
((method-record-override (car methods))
|
|
(refine-method-list (cdr methods)))
|
|
((eq? 'ctor (method-record-rtype (car methods)))
|
|
(refine-method-list (cdr methods)))
|
|
(else
|
|
(let ((overloaded-removed
|
|
(filter (lambda (m) (not (equal? (method-record-name (car methods))
|
|
(method-record-name m))))
|
|
(cdr methods))))
|
|
(if (> (length (cdr methods))
|
|
(length overloaded-removed))
|
|
(refine-method-list overloaded-removed)
|
|
(cons (car methods) (refine-method-list (cdr methods))))))))
|
|
|
|
|
|
;generate-dynamic-names: (list method) (list method)-> (list (list string method))
|
|
(define (generate-dynamic-names methods overridden-methods)
|
|
(map (lambda (method)
|
|
(list (java-name->scheme (id-string (method-name method)))
|
|
method))
|
|
(refine-method-list-old methods overridden-methods)))
|
|
|
|
;refine-method-list-old: (list method) (list method) -> (list method)
|
|
(define (refine-method-list-old methods overridden-methods)
|
|
(if (null? methods)
|
|
methods
|
|
(let ((overloaded-removed
|
|
(filter (lambda (method)
|
|
(not (equal? (id-string (method-name (car methods)))
|
|
(id-string (method-name method)))))
|
|
(cdr methods))))
|
|
(cond
|
|
((> (length (cdr methods))
|
|
(length overloaded-removed))
|
|
(refine-method-list-old overloaded-removed overridden-methods))
|
|
((memq (car methods) overridden-methods)
|
|
(refine-method-list-old (cdr methods) overridden-methods))
|
|
((eq? 'ctor (method-record-rtype (method-rec (car methods))))
|
|
(refine-method-list-old (cdr methods) overridden-methods))
|
|
(else (cons (car methods) (refine-method-list-old (cdr methods) overridden-methods)))))))
|
|
|
|
;generate-dyn-method-defs: (list (list string method)) -> (list syntax)
|
|
(define (generate-dyn-method-defs methods)
|
|
(map (lambda (name-method)
|
|
(let ((args (map (lambda (arg)
|
|
(build-identifier (id-string (var-decl-name arg))))
|
|
(method-parms (cadr name-method)))))
|
|
(create-syntax
|
|
#f
|
|
`(define/public (,(build-identifier (car name-method)) ,@args)
|
|
(,(build-identifier (mangle-method-name (id-string (method-name (cadr name-method)))
|
|
(method-record-atypes (method-rec (cadr name-method)))))
|
|
,@args))
|
|
#f)))
|
|
(filter (lambda (name-method)
|
|
(not (equal? (car name-method) (id-string (method-name (cadr name-method))))))
|
|
methods)))
|
|
|
|
;build-method-table: (list method) (list symbol) -> sexp
|
|
(define (build-method-table methods generics)
|
|
`(let ((table (make-hash-table)))
|
|
(for-each (lambda (method generic)
|
|
(hash-table-put! table (string->symbol method) generic))
|
|
(list ,@(map (lambda (m)
|
|
(mangle-method-name (id-string (method-name m))
|
|
(method-record-atypes (method-rec m))))
|
|
methods))
|
|
(list ,@generics))
|
|
table))
|
|
|
|
;build-field-table: (string->string) symbol accesses -> sexp
|
|
(define (build-field-table maker type fields)
|
|
`(let ((table (make-hash-table)))
|
|
(for-each (lambda (field field-method)
|
|
(hash-table-put! table (string->symbol field) field-method))
|
|
,@(let ((non-private-fields (map (lambda (n) (id-string (field-name n)))
|
|
(append (accesses-public fields)
|
|
(accesses-package fields)
|
|
(accesses-protected fields))))
|
|
(private-fields (map (lambda (n) (id-string (field-name n)))
|
|
(accesses-private fields))))
|
|
(list `(list ,@(append non-private-fields private-fields))
|
|
`(list ,@(append
|
|
(map (lambda (n) (build-identifier (maker n))) non-private-fields)
|
|
(map (if (eq? 'get type)
|
|
(lambda (n)
|
|
`(lambda (class-obj)
|
|
(send class-obj ,(build-identifier (maker n)))))
|
|
(lambda (n)
|
|
`(lambda (class-obj new-val)
|
|
(send class-obj ,(build-identifier (maker n)) new-val))))
|
|
private-fields))))))
|
|
table))
|
|
|
|
|
|
;generate-inner-makers: (list def) int type-records -> (list syntax)
|
|
(define (generate-inner-makers defs depth type-recs)
|
|
(apply append
|
|
(map (lambda (d) (build-inner-makers d depth type-recs))
|
|
(filter (lambda (d) (not (memq (def-kind d) '(anonymous statement)))) defs))))
|
|
|
|
;build-inner-makers: def int type-records -> (list syntax)
|
|
(define (build-inner-makers def depth type-recs)
|
|
(let* ((class-name (id-string (def-name def)))
|
|
(ctor-name (string-append "construct-" class-name))
|
|
(parms (map method-parms (get-ctors (def-members def) type-recs))))
|
|
(map (build-inner-maker class-name ctor-name depth type-recs) parms)))
|
|
|
|
;build-inner-maker: string string int type-records -> ((list field) -> syntax)
|
|
(define (build-inner-maker class-name ctor-name depth type-recs)
|
|
(lambda (parms)
|
|
(let ((translated-parms (translate-parms parms))
|
|
(encls-this (reverse (let loop ((d depth))
|
|
(cond
|
|
((= d 0) null)
|
|
(else (cons (string->symbol (format "encl-this-~a~~f" d))
|
|
(loop (sub1 d))))))))
|
|
(parm-types (map field-type #;(lambda (p) (type-spec-to-type (field-type-spec p) #f 'full type-recs)) parms)))
|
|
(make-syntax #f
|
|
`(define/public (,(build-identifier (mangle-method-name ctor-name parm-types)) ,@translated-parms)
|
|
(let ((temp-obj (make-object ,(build-identifier class-name)
|
|
this ,@encls-this)))
|
|
(send temp-obj ,(build-identifier (build-constructor-name class-name parm-types))
|
|
,@translated-parms)
|
|
temp-obj))
|
|
#f))))
|
|
|
|
;get-ctors: (list member) -> (list method)
|
|
(define (get-ctors members type-recs)
|
|
(filter
|
|
(lambda (member)
|
|
(and (method? member)
|
|
(eq? 'ctor (type-spec-to-type (method-type member) #f 'full type-recs))))
|
|
members))
|
|
|
|
;Code to separate different member types for easier access
|
|
;(make-accesses (list member) (list member) (list member) ...)
|
|
(define-struct accesses (private protected static public package private-static))
|
|
;(make-members (list method) (list field) (list init) (list init) (list def) (list def))
|
|
(define-struct members (method field static-init init nested inner))
|
|
|
|
;update: ('a 'b -> void) 'a ('b -> (list 'a)) 'b) -> 'b
|
|
;Allows a set! to be passed in and applied
|
|
(define (update set add-on access struct)
|
|
(set struct (cons add-on (access struct)))
|
|
struct)
|
|
|
|
;separate-members: (list member) -> members
|
|
(define (separate-members members)
|
|
(letrec ((my-members (make-members null null null null null null))
|
|
(separate
|
|
(lambda (m h)
|
|
(cond
|
|
((null? m) h)
|
|
((method? (car m))
|
|
(separate (cdr m) (update set-members-method! (car m) members-method h)))
|
|
((field? (car m))
|
|
(separate (cdr m) (update set-members-field! (car m) members-field h)))
|
|
((initialize? (car m))
|
|
(separate (cdr m)
|
|
(if (initialize-static (car m))
|
|
(update set-members-static-init! (car m) members-static-init h)
|
|
(update set-members-init! (car m) members-init h))))
|
|
((def? (car m))
|
|
(separate (cdr m)
|
|
(if (or (interface-def? (car m))
|
|
(memq 'static (map modifier-kind (header-modifiers (def-header (car m))))))
|
|
(update set-members-nested! (car m) members-nested h)
|
|
(update set-members-inner! (car m) members-inner h))))
|
|
(else (error 'separate "not something expected: ~e" (car m)))))))
|
|
(separate members my-members)))
|
|
|
|
;make-access-separator: ('a -> (list symbol)) -> ((list 'a) accesses -> accesses)
|
|
(define (make-access-separator get-modifiers)
|
|
(letrec ((separate
|
|
(lambda (m h)
|
|
(if (null? m) h
|
|
(separate (cdr m)
|
|
(let* ((current (car m))
|
|
(modifiers (map modifier-kind (get-modifiers current))))
|
|
(cond
|
|
((private? modifiers)
|
|
(if (static? modifiers)
|
|
(update set-accesses-private-static! current accesses-private-static h)
|
|
(update set-accesses-private! current accesses-private h)))
|
|
((static? modifiers) (update set-accesses-static! current accesses-static h))
|
|
((protected? modifiers) (update set-accesses-protected! current accesses-protected h))
|
|
((public? modifiers) (update set-accesses-public! current accesses-public h))
|
|
(else (update set-accesses-package! current accesses-package h)))))))))
|
|
separate))
|
|
|
|
;separate-methods: (list method) accesses -> accesses
|
|
(define separate-methods (make-access-separator method-modifiers))
|
|
;separate-fields: (list field) accesses -> accesses
|
|
(define separate-fields (make-access-separator field-modifiers))
|
|
|
|
;get-parent: name -> (values string src)
|
|
(define get-parent
|
|
(lambda (parent)
|
|
(when (= (length parent) 1) (set! parent (car parent)))
|
|
(when (null? parent) (set! parent (make-name (make-id "Object" #f) null #f)))
|
|
(if (null? (name-path parent))
|
|
(values (id-string (name-id parent)) (id-src (name-id parent)))
|
|
(values (string-append (apply string-append (map (lambda (p)
|
|
(format "~s." p))
|
|
(map id-string (name-path parent))))
|
|
(id-string (name-id parent)))
|
|
(name-src parent)))))
|
|
|
|
;create-local-names: (list symbol) -> syntax
|
|
(define (create-local-names names)
|
|
(create-syntax #f `(define-local-member-name ,@names) #f))
|
|
|
|
;translate-parents: (list name) -> (list syntax)
|
|
(define (translate-parents extends)
|
|
(map (lambda (n)
|
|
(if (null? (name-path n))
|
|
(translate-id (id-string (name-id n))
|
|
(id-src (name-id n)))
|
|
(create-syntax #f (build-identifier (append (map id-string (name-path n))
|
|
(list (id-string (name-id n)))))
|
|
(build-src (name-src n)))))
|
|
extends))
|
|
|
|
;translate-interface: interface-def type-records-> (list syntax)
|
|
(define (translate-interface iface type-recs)
|
|
(let* ((header (def-header iface))
|
|
(name (build-identifier (id-string (header-id header))))
|
|
(syntax-name (translate-id (id-string (header-id header))
|
|
(id-src (header-id header))))
|
|
(source (build-src (def-src iface)))
|
|
(interface (create-syntax #f 'interface (build-src (def-key-src iface))))
|
|
(members (separate-members (def-members iface))))
|
|
|
|
(loc (def-file iface))
|
|
(class-name (id-string (header-id header)))
|
|
(send type-recs set-location! (loc))
|
|
|
|
(let* ((static-field-names (map build-identifier (make-static-field-names (members-field members))))
|
|
(provides `(provide ,name ,@static-field-names
|
|
,@(map build-identifier (list (format "guard-convert-~a" (class-name))
|
|
(format "convert-assert-~a" (class-name))
|
|
(format "wrap-convert-assert-~a" (class-name))
|
|
(format "dynamic-~a/c" (class-name))
|
|
(format "static-~a/c" (class-name)))))))
|
|
|
|
(list `(begin ,provides
|
|
(define ,syntax-name (,interface ,(translate-parents (header-extends header))
|
|
,@(make-iface-method-names (members-method members))))
|
|
,@(create-static-fields static-field-names (members-field members))
|
|
,@(append (generate-wrappers (class-name)
|
|
"Object"
|
|
(class-record-methods
|
|
(send type-recs get-class-record (list (class-name))))
|
|
null)
|
|
(generate-contract-defs (class-name)))
|
|
)
|
|
(make-syntax #f `(module ,name mzscheme (requires ,(module-name)) ,provides) #f)))))
|
|
|
|
;-----------------------------------------------------------------------------------------------------------------
|
|
;Member translation functions
|
|
|
|
;translate-inner-class: def type-records int -> (U syntax (list syntax syntax))
|
|
|
|
|
|
;------------------------------------------------------------
|
|
;;Method translation functions
|
|
|
|
;override?: symbol type-records -> bool
|
|
(define (override? method-name type-recs)
|
|
(let* ((internal-error
|
|
(lambda () (error 'override "Internal Error class or it's parent not in class record table")))
|
|
(class-record
|
|
(get-record (send type-recs get-class-record
|
|
(make-ref-type (class-name)
|
|
(send type-recs lookup-path (class-name) (lambda () null)))
|
|
#f
|
|
internal-error) type-recs))
|
|
(parent-record (send type-recs get-class-record
|
|
(car (class-record-parents class-record)) #f internal-error)))
|
|
(memq method-name
|
|
(map (lambda (m) (string->symbol (mangle-method-name (method-record-name m)
|
|
(method-record-atypes m))))
|
|
(class-record-methods parent-record)))))
|
|
|
|
;get-overridden-names: (list method) -> (list method)
|
|
(define (get-overridden-methods methods)
|
|
(filter (lambda (m)
|
|
(let ((mname (id-string (method-name m))))
|
|
(and (method-record-override (method-rec m))
|
|
(hash-table-put! (class-override-table)
|
|
(build-identifier
|
|
((if (constructor? mname) build-constructor-name mangle-method-name)
|
|
mname
|
|
(method-record-atypes (method-rec m)))) #t))))
|
|
methods))
|
|
|
|
;create-generic-methods: (list method) -> (list syntax)
|
|
(define (create-generic-methods methods)
|
|
(map (lambda (method)
|
|
(let* ((m-name (id-string (method-name method)))
|
|
(name ((if (eq? 'ctor (method-record-rtype (method-rec method)))
|
|
build-constructor-name mangle-method-name)
|
|
m-name
|
|
(method-record-atypes (method-rec method)))))
|
|
(make-syntax #f `(define ,(build-identifier (build-generic-name (class-name) name))
|
|
(generic ,(build-identifier (class-name)) ,(build-identifier name)))
|
|
(build-src (method-src method)))))
|
|
methods))
|
|
|
|
;make-iface-method-names: (list method) -> (list symbol)
|
|
(define (make-iface-method-names methods)
|
|
(letrec ((mangle-name (lambda (method)
|
|
(build-identifier
|
|
(mangle-method-name (method-record-name (method-rec method))
|
|
(method-record-atypes (method-rec method))))))
|
|
(maker
|
|
(lambda (methods)
|
|
(cond
|
|
((null? methods) methods)
|
|
((method-record-override (method-rec (car methods)))
|
|
(maker (cdr methods)))
|
|
(else (cons (mangle-name (car methods)) (maker (cdr methods))))))))
|
|
(maker methods)))
|
|
|
|
;make-method-names: (list methods) (list methods) -> (list symbol)
|
|
(define (make-method-names methods minus-methods)
|
|
(if (null? methods)
|
|
null
|
|
(if (memq (car methods) minus-methods)
|
|
(make-method-names (cdr methods) minus-methods)
|
|
(cons
|
|
(build-identifier ((if (constructor? (id-string (method-name (car methods))))
|
|
build-constructor-name
|
|
mangle-method-name)
|
|
(id-string (method-name (car methods)))
|
|
(method-record-atypes (method-rec (car methods)))))
|
|
(make-method-names (cdr methods) minus-methods)))))
|
|
|
|
;translate-method: type-spec (list symbol) id (list parm) statement bool
|
|
; src bool int method-record type-records -> syntax
|
|
(define (translate-method type modifiers id parms block all-tail? src inner? depth rec type-recs)
|
|
(let* ((final (final? modifiers))
|
|
(ctor? (eq? 'ctor (method-record-rtype rec)));(constructor? (id-string id)))
|
|
(method-string ((if ctor? build-constructor-name mangle-method-name)
|
|
(id-string id)
|
|
(method-record-atypes rec)))
|
|
(method-name (translate-id method-string (id-src id)))
|
|
(over? (method-record-override rec))
|
|
(definition (cond
|
|
((and over? final) 'define/override-final)
|
|
(over? 'define/override)
|
|
(final 'define/public-final)
|
|
(else 'define/public))))
|
|
(unless (static? modifiers) (current-depth depth))
|
|
(current-local-classes null)
|
|
(create-syntax #f
|
|
`(,definition ,method-name
|
|
,(translate-method-body method-string parms block modifiers type
|
|
all-tail? ctor? inner? depth type-recs))
|
|
(build-src src))))
|
|
|
|
;make-static-method-names: (list method) type-recs -> (list string)
|
|
(define (make-static-method-names methods type-recs)
|
|
(map (lambda (m)
|
|
(build-static-name (mangle-method-name (id-string (method-name m))
|
|
(method-record-atypes (method-rec m)))))
|
|
methods))
|
|
|
|
;create-static-methods: (list string) (list method) type-records -> (list syntax)
|
|
(define (create-static-methods names methods type-recs)
|
|
(if (null? names)
|
|
null
|
|
(let ((name (car names))
|
|
(method (car methods)))
|
|
(cons (create-syntax #f
|
|
`(define ,(translate-id name (id-src (method-name method)))
|
|
,(translate-method-body name
|
|
(method-parms method)
|
|
(method-body method)
|
|
(map modifier-kind (method-modifiers method))
|
|
(method-type method)
|
|
(method-all-tail? method)
|
|
#f
|
|
#f
|
|
0
|
|
type-recs))
|
|
(build-src (method-src method)))
|
|
(create-static-methods (cdr names) (cdr methods) type-recs)))))
|
|
|
|
(define static-method (make-parameter #f))
|
|
|
|
;translate-method-body: string (list field) statement (list symbol) type-spec bool bool bool int type-record -> syntax
|
|
(define (translate-method-body method-name parms block modifiers rtype all-tail? ctor? inner? depth type-recs)
|
|
(let ((parms (translate-parms parms))
|
|
(void? (eq? (type-spec-name rtype) 'void))
|
|
(native? (memq 'native modifiers))
|
|
(static? (memq 'static modifiers))
|
|
(native-method-name (build-identifier
|
|
(string-append method-name #;(substring method-name 0 (- (string-length method-name) 2))
|
|
"-native"))))
|
|
|
|
(static-method static?)
|
|
(make-syntax #f
|
|
(cond
|
|
((and block void?)
|
|
`(lambda ,parms
|
|
(let/ec return-k
|
|
,(translate-statement block type-recs)
|
|
(void))))
|
|
((and block (not void?) all-tail?)
|
|
`(lambda ,parms
|
|
,(translate-statement block type-recs)))
|
|
((and block (not void?))
|
|
`(lambda ,parms
|
|
(let/ec return-k
|
|
,(translate-statement block type-recs))))
|
|
((and (not block) (memq 'abstract modifiers))
|
|
`(lambda ,parms (void)))
|
|
((and (not block) native? void? (not static?))
|
|
`(lambda ,parms
|
|
(,native-method-name
|
|
this field-accessors field-setters private-methods ,@parms)
|
|
(void)))
|
|
((and (not block) native? (not static?))
|
|
`(lambda ,parms
|
|
(,native-method-name
|
|
this field-accessors field-setters private-methods ,@parms)))
|
|
((and (not block) native? void? static?)
|
|
`(lambda ,parms
|
|
(,native-method-name ,@parms)
|
|
(void)))
|
|
((and (not block) native? static?)
|
|
`(lambda ,parms
|
|
(,native-method-name ,@parms))))
|
|
#f)))
|
|
|
|
;translate-parms: (list field) -> (list syntax)
|
|
(define (translate-parms parms)
|
|
(map (lambda (parm)
|
|
(translate-id (build-var-name (id-string (field-name parm)))
|
|
(id-src (field-name parm))))
|
|
parms))
|
|
|
|
;----------------------------------------------------------------
|
|
;Field translation functions
|
|
|
|
;make-field-accessor-names: (list fields) -> (list symbol)
|
|
(define (make-field-accessor-names fields)
|
|
(if (null? fields)
|
|
null
|
|
(let ((name (id-string (field-name (car fields)))))
|
|
(append (cons (create-get-name name)
|
|
(if (final? (map modifier-kind (field-modifiers (car fields))))
|
|
null
|
|
(list (create-set-name name))))
|
|
(make-field-accessor-names (cdr fields))))))
|
|
|
|
(define (create-field-accessors names fields)
|
|
(if (null? fields)
|
|
null
|
|
(let* ((field (car fields))
|
|
(class (build-identifier (class-name)))
|
|
(ca-class (build-identifier (string-append "convert-assert-" (class-name))))
|
|
(quote-name (build-identifier (build-var-name (id-string (field-name field)))))
|
|
(getter (car names))
|
|
(setter (cadr names))
|
|
(final (final? (map modifier-kind (field-modifiers field)))))
|
|
(append (cons (make-syntax #f
|
|
`(define ,getter
|
|
(let ((normal-get (class-field-accessor ,class ,quote-name))
|
|
(dyn-get (class-field-accessor ,ca-class ,quote-name)))
|
|
(lambda (obj)
|
|
(if (is-a? obj ,class)
|
|
(normal-get obj)
|
|
(dyn-get obj)))))
|
|
#f)
|
|
(if (not final)
|
|
(list
|
|
(make-syntax #f
|
|
`(define ,setter
|
|
(let ((normal-set (class-field-mutator ,class ,quote-name))
|
|
(dyn-set (class-field-mutator ,ca-class ,quote-name)))
|
|
(lambda (obj val)
|
|
(if (is-a? obj ,class)
|
|
(normal-set obj val)
|
|
(dyn-set obj val)))))
|
|
#f))
|
|
null))
|
|
(create-field-accessors (if final (cdr names) (cddr names)) (cdr fields))))))
|
|
|
|
(define (make-static-field-setters-names fields)
|
|
(map (lambda (f) (create-set-name (id-string (field-name f)))) fields))
|
|
|
|
(define (create-static-setters names fields)
|
|
(if (null? names)
|
|
null
|
|
(let ((name (car names))
|
|
(field (car fields)))
|
|
(cons (make-syntax #f
|
|
`(define (,name my-val)
|
|
(set! ,(build-identifier (build-var-name (build-static-name (id-string (field-name field)))))
|
|
my-val))
|
|
#f)
|
|
(create-static-setters (cdr names) (cdr fields))))))
|
|
|
|
;create-private-setters/getters fields -> (list syntax)
|
|
(define (create-private-setters/getters fields)
|
|
(if (null? fields)
|
|
null
|
|
(let* ((field (car fields))
|
|
(s-name (id-string (field-name field)))
|
|
(name (build-identifier (build-var-name s-name)))
|
|
(getter (create-get-name s-name))
|
|
(setter (create-set-name s-name)))
|
|
(append (list (make-syntax #f `(define/public (,getter my-val) ,name) (build-src (id-src (field-name field))))
|
|
(make-syntax #f `(define/public (,setter m-obj my-val) (set! ,name my-val))
|
|
(build-src (id-src (field-name field)))))
|
|
(create-private-setters/getters (cdr fields))))))
|
|
|
|
;make-static-fiel-names: (list field) -> (list string)
|
|
(define (make-static-field-names fields)
|
|
(map (lambda (f) (build-static-name (build-var-name (id-string (field-name f))))) fields))
|
|
|
|
;create-static-fields: (list string) (list field) -> (list syntax)
|
|
(define (create-static-fields names fields)
|
|
(if (null? names)
|
|
null
|
|
(let ((name (car names))
|
|
(f (car fields)))
|
|
(cons (make-syntax #f
|
|
`(define ,(translate-id name (id-src (field-name f)))
|
|
,(translate-field-body (and (var-init? f) f) (field-type-spec f)))
|
|
(build-src (if (var-init? f) (var-init-src f) (var-decl-src f))))
|
|
(create-static-fields (cdr names) (cdr fields))))))
|
|
|
|
;translate-field: (list symbol) type-spec id (U #f var-init) src bool -> syntax
|
|
(define (translate-field access type name init? src static?)
|
|
(let ((value (translate-field-body init? type))
|
|
(field-name (translate-id (build-var-name (if static? (build-static-name (id-string name)) (id-string name)))
|
|
(id-src name))))
|
|
(if (or static? (private? access))
|
|
(make-syntax #f `(define ,field-name ,value) (build-src src))
|
|
(make-syntax #f `(field (,field-name ,value)) (build-src src)))))
|
|
|
|
;translate-field-body (U bool var-init) type-spec -> syntax
|
|
(define (translate-field-body init? type)
|
|
(cond
|
|
(init?
|
|
(let ((actual-type (if (array-init? (var-init-init init?))
|
|
'dynamic ;Problem: array type needed here
|
|
(expr-types (var-init-init init?))))
|
|
(body-syntax (if (array-init? (var-init-init init?))
|
|
(initialize-array (array-init-vals (var-init-init init?))
|
|
type)
|
|
(translate-expression (var-init-init init?)))))
|
|
(if (or (eq? 'dynamic (field-type init?))
|
|
(dynamic-val? (field-type init?)))
|
|
(make-syntax #f (guard-convert-value body-syntax actual-type) body-syntax)
|
|
body-syntax)))
|
|
(else (get-default-value type))))
|
|
|
|
;translate-initialize: bool block src string type-records -> syntax
|
|
(define (translate-initialize static? body src type-recs)
|
|
(translate-block (block-stmts body) (block-src body) type-recs))
|
|
|
|
|
|
;-------------------------------------------------------------------------------------------------------------------------
|
|
;translate-statement
|
|
;translates a Java statement into a Scheme expresion.
|
|
;raises an error if it has no implementation for a statement type
|
|
|
|
;Converted
|
|
;translate-statement: statement string type-records -> syntax
|
|
(define translate-statement
|
|
(lambda (statement type-recs)
|
|
(cond
|
|
((ifS? statement)
|
|
(translate-if (translate-expression (ifS-cond statement))
|
|
(translate-statement (ifS-then statement) type-recs)
|
|
(if (ifS-else statement)
|
|
(translate-statement (ifS-else statement) type-recs)
|
|
'void)
|
|
(ifS-key-src statement)
|
|
(ifS-src statement)))
|
|
((throw? statement)
|
|
(translate-throw (translate-expression (throw-expr statement))
|
|
(throw-key-src statement)
|
|
(throw-src statement)))
|
|
((return? statement)
|
|
(translate-return (if (return-expr statement)
|
|
(translate-expression (return-expr statement))
|
|
(make-syntax #f '(void) #f))
|
|
(return-in-tail? statement)
|
|
(return-src statement)))
|
|
((while? statement)
|
|
(translate-while (translate-expression (while-cond statement))
|
|
(translate-statement (while-loop statement) type-recs)
|
|
(while-src statement)))
|
|
((doS? statement)
|
|
(translate-do (translate-statement (doS-loop statement) type-recs)
|
|
(translate-expression (doS-cond statement))
|
|
(doS-src statement)))
|
|
((for? statement)
|
|
(translate-for (for-init statement)
|
|
(translate-expression (for-cond statement))
|
|
(map translate-expression (for-incr statement))
|
|
(translate-statement (for-loop statement) type-recs)
|
|
(for-src statement)
|
|
type-recs))
|
|
((try? statement)
|
|
(translate-try (translate-statement (try-body statement) type-recs)
|
|
(try-catches statement)
|
|
(and (try-finally statement)
|
|
(translate-statement (try-finally statement) type-recs))
|
|
(try-key-src statement)
|
|
(try-src statement)
|
|
type-recs))
|
|
((switch? statement)
|
|
(translate-switch (translate-expression (switch-expr statement))
|
|
(switch-cases statement)
|
|
(switch-src statement)
|
|
type-recs))
|
|
((block? statement)
|
|
(translate-block (block-stmts statement) (block-src statement) type-recs))
|
|
((def? statement)
|
|
(current-local-classes (cons statement (current-local-classes)))
|
|
(create-syntax #f '(void) #f))
|
|
((break? statement)
|
|
(translate-break (break-label statement) (break-src statement)))
|
|
((continue? statement)
|
|
(translate-continue (continue-label statement) (continue-src statement)))
|
|
((label? statement)
|
|
(translate-label (label-label statement)
|
|
(translate-statement (label-stmt statement) type-recs)
|
|
(label-src statement)))
|
|
((synchronized? statement)
|
|
(translate-synchronized (translate-expression (synchronized-expr statement))
|
|
(translate-statement (synchronized-stmt statement) type-recs)
|
|
(synchronized-src statement)))
|
|
((statement-expression? statement)
|
|
(translate-expression statement))
|
|
(else
|
|
(error 'translate-statement (format "translate-statement given unsupported: ~s" statement))))))
|
|
|
|
|
|
;Converted
|
|
;translate-if: syntax syntax syntax src src -> syntax
|
|
(define translate-if
|
|
(lambda (if? then else key src)
|
|
(create-syntax #f `(,(create-syntax #f `if (build-src key)) ,if? ,then ,else) (build-src src))))
|
|
|
|
;Converted
|
|
;translate-throw: syntax src src -> syntax
|
|
(define translate-throw
|
|
(lambda (expr key src)
|
|
(create-syntax #f `(let* ((obj ,expr)
|
|
(exn (make-java:exception
|
|
(string->immutable-string (send (send obj |getMessage|) get-mzscheme-string))
|
|
(current-continuation-marks) obj)))
|
|
(send obj set-exception! exn)
|
|
(,(create-syntax #f 'raise (build-src key)) exn))
|
|
(build-src src))))
|
|
|
|
;return -> call to a continuation
|
|
;Presently a no-op in the interactions window, although this is incorrect for advanced and full
|
|
;translate-return: syntax bool src -> syntax
|
|
(define (translate-return expr in-tail? src)
|
|
(if (or (interactions?) in-tail?)
|
|
(make-syntax #f expr #f)
|
|
(make-syntax #f `(return-k ,expr) (build-src src))))
|
|
|
|
;translate-while: syntax syntax src -> syntax
|
|
(define (translate-while cond body src)
|
|
(make-syntax #f `(let/ec loop-k
|
|
(let loop ((dummy #f))
|
|
(when ,cond
|
|
,body
|
|
(loop #f))))
|
|
(build-src src)))
|
|
|
|
;translate-do: syntax syntax src -> syntax
|
|
(define (translate-do body cond src)
|
|
(make-syntax #f `(let/ec loop-k
|
|
(let loop ((dummy #f))
|
|
,body
|
|
(when ,cond (loop #f))))
|
|
(build-src src)))
|
|
|
|
;translate-for: (U (list statement) (list field)) syntax (list syntax) syntax src type-records-> syntax
|
|
(define (translate-for init condi incr body src type-recs)
|
|
(let ((loop `(let/ec loop-k
|
|
(let loop ((continue? #f))
|
|
(when continue? ,@(if (null? incr) '((void)) incr))
|
|
(when ,condi
|
|
,body
|
|
,@incr
|
|
(loop #f)))))
|
|
(source (build-src src)))
|
|
(if (and (pair? init) (field? (car init)))
|
|
(make-syntax #f `(letrec (,@(map (lambda (var)
|
|
`(,(translate-id (build-var-name (id-string (field-name var)))
|
|
(id-src (field-name var)))
|
|
,(cond
|
|
((var-init? var)
|
|
(let ((actual-type
|
|
(if (array-init? (var-init-init var))
|
|
'dynamic ;Problem: need array-type here
|
|
(expr-types (var-init-init var))))
|
|
(var-value
|
|
(if (array-init? (var-init-init var))
|
|
(initialize-array (array-init-vals (var-init-init var))
|
|
(field-type-spec var))
|
|
(translate-expression (var-init-init var)))))
|
|
(if (or (eq? 'dynamic (field-type var))
|
|
(dynamic-val? (field-type var)))
|
|
(make-syntax #f (guard-convert-value var-value actual-type) var-value)
|
|
var-value)))
|
|
(else (get-default-value (field-type-spec var))))))
|
|
init))
|
|
,loop) source)
|
|
(make-syntax #f `(begin
|
|
,@(map (lambda (s) (translate-statement s type-recs)) init)
|
|
,loop)
|
|
source))))
|
|
|
|
;Converted
|
|
;initialize-array: (list (U expression array-init)) type-spec-> syntax
|
|
(define (initialize-array inits type)
|
|
(cond
|
|
((null? inits)
|
|
(make-syntax #f `(make-java-array ,(translate-type-spec type) 0 null) #f))
|
|
; (error 'initialize-array "Given empty list"))
|
|
((array-init? (car inits))
|
|
(make-syntax #f
|
|
`(make-java-array ,(translate-type-spec type)
|
|
0
|
|
(reverse (list ,@(map (lambda (a) (initialize-array (array-init-vals a)
|
|
(make-type-spec (type-spec-name type)
|
|
(sub1 (type-spec-dim type))
|
|
(type-spec-src type))))
|
|
inits))))
|
|
(build-src (array-init-src (car inits)))))
|
|
(else
|
|
(make-syntax #f
|
|
`(make-java-array ,(translate-type-spec type)
|
|
0
|
|
(reverse (list ,@(map translate-expression inits))))
|
|
(build-src (if (name? (car inits)) (name-src (car inits)) (expr-src (car inits))))))))
|
|
|
|
;Converted
|
|
;translate-try: syntax (list catch) (U syntax boolean) src src type-records-> syntax
|
|
(define translate-try
|
|
(lambda (block catches finally key src type-recs)
|
|
(let* ((handle (create-syntax #f 'with-handlers (build-src key)))
|
|
(handlers (make-syntax #f `(,handle [ ,@(make-predicates catches type-recs) ]
|
|
,block)
|
|
(build-src src))))
|
|
(if finally
|
|
(make-syntax #f
|
|
`(dynamic-wind void
|
|
(lambda () ,handlers)
|
|
(lambda () ,finally))
|
|
#f)
|
|
handlers))))
|
|
|
|
;Converted
|
|
;make-predicates: (list catch) type-records-> (list syntax)
|
|
(define make-predicates
|
|
(lambda (catches type-recs)
|
|
(map (lambda (catch)
|
|
(let* ((catch-var (catch-cond catch))
|
|
(var-src (var-decl-src catch-var))
|
|
(class-name (get-class-name (field-type-spec catch-var)))
|
|
(isRuntime? (descendent-Runtime? (field-type-spec catch-var) type-recs))
|
|
(type
|
|
(if isRuntime?
|
|
(make-syntax #f `exn? (build-src var-src))
|
|
(make-syntax #f
|
|
`(exception-is-a? ,class-name)
|
|
(build-src var-src))))
|
|
(parm (translate-id (build-var-name (id-string (field-name catch-var)))
|
|
(id-src (field-name catch-var))))
|
|
(block (make-syntax #f
|
|
`(lambda (,parm)
|
|
,(translate-statement (catch-body catch) type-recs))
|
|
(build-src (catch-src catch)))))
|
|
(make-syntax #f `(,type
|
|
,(if isRuntime?
|
|
`(lambda (exn)
|
|
(if (javaException:supported-runtime-exception? exn)
|
|
(,block (javaException:exception-to-class exn))
|
|
(raise exn)))
|
|
block))
|
|
(build-src (catch-src catch)))))
|
|
catches)))
|
|
|
|
;Determines if the given type represents a class that is a descendent of the RuntimeException class
|
|
;descendent-Runtime?: type-spec type-records -> bool
|
|
(define descendent-Runtime?
|
|
(lambda (type type-recs)
|
|
(let ((class-record (send type-recs get-class-record (type-spec-to-type type #f 'full type-recs) #f
|
|
(lambda () (error 'descendent-Runtime "Internal Error: class record is not in table")))))
|
|
(member `("java" "lang" "RuntimeException") (class-record-parents class-record)))))
|
|
|
|
;Converted
|
|
;translate-switch: syntax (list CaseStatements) src type-records -> syntax
|
|
(define translate-switch
|
|
(lambda (expr cases src type-recs)
|
|
(make-syntax #f
|
|
`(case ,expr
|
|
,@(map (lambda (case)
|
|
(if (eq? (caseS-constant case) 'default)
|
|
(if (null? (caseS-body case))
|
|
`(else (void))
|
|
`(else ,(translate-block (caseS-body case) (caseS-src case) type-recs)))
|
|
`((,(translate-expression (caseS-constant case))
|
|
,(translate-block (caseS-body case) (caseS-src case) type-recs)))))
|
|
cases))
|
|
(build-src src))))
|
|
|
|
;Converted
|
|
;translate-block: (list (U Statement (U var-decl var-init))) src type-recs -> syntax
|
|
(define translate-block
|
|
(lambda (statements src type-recs)
|
|
;(list (U Statement (U var-decl var-init))) -> (list syntax)
|
|
(letrec ((translate
|
|
(lambda (statements)
|
|
(if (null? statements)
|
|
null
|
|
(let ((statement (car statements)))
|
|
(if (field? statement)
|
|
(translate-var (car statements) (cdr statements))
|
|
(cons (translate-statement statement type-recs)
|
|
(translate (cdr statements))))))))
|
|
(translate-var
|
|
(lambda (var statements)
|
|
(let* ((is-var-init? (var-init? var))
|
|
(id (translate-id (build-var-name (id-string (field-name var))) (id-src (field-name var)))))
|
|
(list (make-syntax #f
|
|
`(letrec
|
|
((,id ,(cond
|
|
(is-var-init?
|
|
(let ((actual-type (if (array-init? (var-init-init var))
|
|
'dynamic ;Problem: need array type here
|
|
(expr-types (var-init-init var))))
|
|
(var-value (if (array-init? (var-init-init var))
|
|
(initialize-array (array-init-vals (var-init-init var))
|
|
(field-type-spec var))
|
|
(translate-expression (var-init-init var)))))
|
|
(if (or (eq? 'dynamic (field-type var))
|
|
(dynamic-val? (field-type var)))
|
|
(guard-convert-value var-value actual-type)
|
|
var-value)))
|
|
(else (get-default-value (field-type-spec var))))))
|
|
,@(if (null? statements)
|
|
(list `(void))
|
|
(translate statements)))
|
|
(build-src (if is-var-init?
|
|
(var-init-src var)
|
|
(var-decl-src var)))))))))
|
|
(if (null? statements)
|
|
(make-syntax #f `void (build-src src))
|
|
(make-syntax #f `(begin ,@(translate statements)) (build-src src))))))
|
|
|
|
;translate-break: (U id #f) src -> syntax
|
|
(define (translate-break id src)
|
|
(if (not id)
|
|
(make-syntax #f `(loop-k (void)) (build-src src))
|
|
(make-syntax #f `(,(translate-id (string-append (id-string id "-k")) (id-src id)) void) (build-src src))))
|
|
|
|
;Converted
|
|
;translate-continue: (U string #f) src -> syntax
|
|
(define (translate-continue id src)
|
|
(if (not id)
|
|
(make-syntax #f `(loop-k (loop #t)) (build-src src))
|
|
(make-syntax #f `(,(translate-id (string-append (id-string id) "-k") (id-src id))
|
|
(,(build-identifier (string-append (id-string id) "-continue"))))
|
|
(build-src src))))
|
|
|
|
;translate-label: id syntax src -> syntax
|
|
;NOTE: probably does not have correct behavior
|
|
(define translate-label
|
|
(lambda (label stmt src)
|
|
(make-syntax #f
|
|
`(let/ec ,(translate-id (string-append (id-string label) "-k") (id-src label))
|
|
(letrec ((,(build-identifier (string-append (id-string label) "-continue"))
|
|
(lambda () ,stmt)))
|
|
(,(build-identifier (string-append (id-string label) "-continue")))))
|
|
(build-src src))))
|
|
|
|
;translate-synchronized: syntax syntax src -> syntax
|
|
;PROBLEM! Does nothing
|
|
(define translate-synchronized
|
|
(lambda (expr stmt src)
|
|
(make-syntax #f
|
|
`(begin ,expr ,stmt)
|
|
(build-src src))))
|
|
|
|
;------------------------------------------------------------------------------------------------------------------
|
|
;translate-contract
|
|
;translates types into contracts
|
|
|
|
;type->contract: type boolean -> sexp
|
|
(define (type->contract type from-dynamic? . stop?)
|
|
(cond
|
|
((dynamic-val? type)
|
|
(if (null? stop?)
|
|
(type->contract (dynamic-val-type type) from-dynamic?)
|
|
(type->contract (dynamic-val-type type) from-dynamic? #t)))
|
|
((symbol? type)
|
|
(case type
|
|
((int short long byte) 'integer?)
|
|
((double float) '(c:and/c number? (c:union inexact? integer?)))
|
|
((boolean) 'boolean?)
|
|
((char) 'char?)
|
|
((string String)
|
|
(if from-dynamic?
|
|
`string?
|
|
`(c:is-a?/c ,(if (send (types) require-prefix? '("String" "java" "lang") (lambda () #f))
|
|
'java.lang.String 'String))))
|
|
((dynamic void) 'c:any/c)))
|
|
((ref-type? type)
|
|
(if (equal? type string-type)
|
|
(type->contract 'string from-dynamic?)
|
|
`(c:union (c:is-a?/c object%) string?)))
|
|
((unknown-ref? type)
|
|
(if (not (null? stop?))
|
|
`(c:union (c:is-a?/c object%) string?)
|
|
(cond
|
|
((method-contract? (unknown-ref-access type))
|
|
`(c:object-contract (,(string->symbol (java-name->scheme (method-contract-name (unknown-ref-access type))))
|
|
,(type->contract (unknown-ref-access type) from-dynamic?))))
|
|
((field-contract? (unknown-ref-access type))
|
|
`(c:object-contract (field ,(build-identifier (string-append (field-contract-name (unknown-ref-access type)) "~f"))
|
|
,(type->contract (field-contract-type (unknown-ref-access type)) from-dynamic?)))))))
|
|
((method-contract? type)
|
|
`(c:-> ,@(map (lambda (a) (type->contract a from-dynamic?)) (method-contract-args type))
|
|
,(type->contract (method-contract-return type) from-dynamic? #t)))
|
|
((not type) 'c:any/c)
|
|
))
|
|
|
|
;guard-convert-value syntax type -> sexp
|
|
(define (guard-convert-value val type)
|
|
(cond
|
|
((dynamic-val? type) val)
|
|
((symbol? type)
|
|
(case type
|
|
((int short long byte float double boolean char dynamic void) val)
|
|
((string String) `(send ,val get-mzscheme-string))))
|
|
((ref-type? type)
|
|
(if (equal? type string-type)
|
|
`(send ,val get-mzscheme-string)
|
|
(let ((prefix (if (send (types) require-prefix? (cons (ref-type-class/iface type) (ref-type-path type))
|
|
(lambda () #f))
|
|
(apply string-append (map (lambda (s) (string-append s ".")) (ref-type-path type)))
|
|
"")))
|
|
`(make-object ,(build-identifier (string-append prefix "guard-convert-" (ref-type-class/iface type)))
|
|
,val (quote ,(string->symbol (class-name))) '|| #`,val (current-continuation-marks)))))
|
|
(else val)))
|
|
;convert-assert-value: syntax type -> sexp
|
|
(define (convert-assert-value val type)
|
|
(cond
|
|
((dynamic-val? type) (convert-assert-value val (dynamic-val-type type)))
|
|
((symbol? type)
|
|
(case type
|
|
((int short long byte float double boolean char dynamic void) val)
|
|
((string String)
|
|
`(let ((val ,val))
|
|
(if (string? val)
|
|
(make-java-string val)
|
|
(raise (make-exn:fail (string->immutable-string
|
|
(format "~a broke infered contract here: expected String received ~a"
|
|
,(class-name) val)) (current-continuation-marks))))))))
|
|
((unknown-ref? type)
|
|
`(let ((val ,val))
|
|
(if (string? val)
|
|
(make-java-string val)
|
|
val)))
|
|
((ref-type? type)
|
|
(cond
|
|
((equal? type string-type)
|
|
(convert-assert-value val 'string))
|
|
(else
|
|
(let ((prefix (if (send (types) require-prefix? (cons (ref-type-class/iface type) (ref-type-path type))
|
|
(lambda () #f))
|
|
(apply string-append (map (lambda (s) (string-append s ".")) (ref-type-path type)))
|
|
"")))
|
|
`(,(build-identifier (string-append prefix "wrap-convert-assert-" (ref-type-class/iface type)))
|
|
,val (quote ,(string->symbol (class-name))) '|| #`,val (current-continuation-marks))))))
|
|
(else val)))
|
|
|
|
;------------------------------------------------------------------------------------------------------------------------
|
|
;translate-expression
|
|
;translates a Java expression into a Scheme expression.
|
|
;raises an error if it has no implementation for an expression type
|
|
|
|
;translate-expression: Expression -> syntax
|
|
(define (translate-expression expr)
|
|
(cond
|
|
((literal? expr) (translate-literal (expr-types expr)
|
|
(literal-val expr)
|
|
(expr-src expr)))
|
|
((bin-op? expr) (translate-bin-op (bin-op-op expr)
|
|
(translate-expression (bin-op-left expr))
|
|
(expr-types (bin-op-left expr))
|
|
(translate-expression (bin-op-right expr))
|
|
(expr-types (bin-op-right expr))
|
|
(bin-op-key-src expr)
|
|
(expr-src expr)
|
|
(expr-types expr)))
|
|
((access? expr) (translate-access (access-name expr)
|
|
(expr-types expr)
|
|
(expr-src expr)))
|
|
((special-name? expr) (translate-special-name (special-name-name expr)
|
|
(expr-src expr)))
|
|
((specified-this? expr) (translate-specified-this (specified-this-var expr) (expr-src expr)))
|
|
((call? expr) (translate-call (call-expr expr)
|
|
(call-method-name expr)
|
|
(map translate-expression (call-args expr))
|
|
(map expr-types (call-args expr))
|
|
(call-method-record expr)
|
|
(expr-types expr)
|
|
(expr-src expr)))
|
|
((class-alloc? expr) (translate-class-alloc (class-alloc-name expr)
|
|
(map expr-types (class-alloc-args expr))
|
|
(map translate-expression (class-alloc-args expr))
|
|
(expr-src expr)
|
|
(class-alloc-class-inner? expr)
|
|
(class-alloc-local-inner? expr)
|
|
(class-alloc-ctor-record expr)))
|
|
((inner-alloc? expr) (translate-inner-alloc (translate-expression (inner-alloc-obj expr))
|
|
(inner-alloc-name expr)
|
|
(map translate-expression (inner-alloc-args expr))
|
|
(expr-src expr)
|
|
(inner-alloc-ctor-record expr)))
|
|
((array-alloc? expr)(translate-array-alloc (array-alloc-name expr)
|
|
(map translate-expression (array-alloc-size expr))
|
|
(expr-src expr)))
|
|
((array-alloc-init? expr)(translate-array-alloc-init (array-alloc-init-name expr)
|
|
(array-alloc-init-dim expr)
|
|
(array-alloc-init-init expr)
|
|
(expr-src expr)))
|
|
((cond-expression? expr) (translate-cond (translate-expression (cond-expression-cond expr))
|
|
(translate-expression (cond-expression-then expr))
|
|
(translate-expression (cond-expression-else expr))
|
|
(expr-src expr)))
|
|
((array-access? expr) (translate-array-access (translate-expression (array-access-name expr))
|
|
(translate-expression (array-access-index expr))
|
|
(expr-src expr)))
|
|
((post-expr? expr) (translate-post-expr (translate-expression (post-expr-expr expr))
|
|
(post-expr-op expr)
|
|
(post-expr-key-src expr)
|
|
(expr-src expr)))
|
|
((pre-expr? expr) (translate-pre-expr (pre-expr-op expr)
|
|
(translate-expression (pre-expr-expr expr))
|
|
(pre-expr-key-src expr)
|
|
(expr-src expr)))
|
|
((unary? expr) (translate-unary (unary-op expr)
|
|
(translate-expression (unary-expr expr))
|
|
(unary-key-src expr)
|
|
(expr-src expr)))
|
|
((cast? expr) (translate-cast (cast-type expr)
|
|
(translate-expression (cast-expr expr))
|
|
(expr-types expr)
|
|
(expr-src expr)))
|
|
((instanceof? expr) (translate-instanceof (translate-expression (instanceof-expr expr))
|
|
(instanceof-type expr)
|
|
(expr-src expr)))
|
|
((assignment? expr) (translate-assignment (assignment-left expr)
|
|
(assignment-op expr)
|
|
(translate-expression (assignment-right expr))
|
|
(assignment-right expr)
|
|
(expr-types expr)
|
|
(assignment-key-src expr)
|
|
(expr-src expr)))
|
|
(else
|
|
(error 'translate-expression (format "Translate Expression given unrecognized expression ~s" expr)))))
|
|
|
|
;All of the following functions translate Java Expressions into syntax.
|
|
;Straightforward unless otherwise noted
|
|
|
|
;translate-literal: symbol value src -> syntax
|
|
(define (translate-literal type value src)
|
|
(let ((make-string `(let ((temp-obj (make-object String)))
|
|
(send temp-obj make-mzscheme-string ,value)
|
|
temp-obj))
|
|
(make-image
|
|
(lambda ()
|
|
`(let ((temp-obj (make-object ,(if (send (types) require-prefix?
|
|
'("Image" "draw2") (lambda () #f))
|
|
'draw2.Image
|
|
'Image))))
|
|
(send temp-obj Image-constructor-dynamic ,value)
|
|
temp-obj))))
|
|
(create-syntax #f
|
|
(case type
|
|
((char int long float double boolean) value)
|
|
((String string) make-string)
|
|
((image) (make-image))
|
|
((null) 'null)
|
|
(else
|
|
(cond
|
|
((eq? type string-type) make-string)
|
|
((and (equal? "Image" (ref-type-class/iface type))
|
|
(equal? '("draw2") (ref-type-path type)))
|
|
(make-image))
|
|
(else
|
|
(error 'translate-literal (format "Translate literal given unknown type: ~s" type))))))
|
|
(build-src src))))
|
|
|
|
;;make-is-test sym -> (type -> bool)
|
|
(define (make-is-test kind)
|
|
(lambda (type)
|
|
(if (dynamic-val? type)
|
|
(eq? (dynamic-val-type type) kind)
|
|
(eq? type kind))))
|
|
|
|
;;is-string? type -> bool
|
|
(define is-string? (make-is-test 'string))
|
|
;;is-int? type -> bool
|
|
(define is-int? (make-is-test 'int))
|
|
;;is-char? type -> bool
|
|
(define is-char? (make-is-test 'char))
|
|
;;is-double?
|
|
(define (is-double? type)
|
|
(or ((make-is-test 'float) type)
|
|
((make-is-test 'double) type)))
|
|
|
|
;translate-bin-op: symbol syntax type syntax type src src type-> syntax
|
|
(define (translate-bin-op op left left-type right right-type key src type)
|
|
(let* ((source (build-src src))
|
|
(key-src (build-src key))
|
|
(op-syntax (create-syntax #f op key-src))
|
|
(left (cond
|
|
((is-char? left-type)
|
|
(make-syntax #f `(char->integer ,left) #f))
|
|
((and (dynamic-val? type) (not (memq op '(== != & ^ or && oror))))
|
|
(create-syntax #f `(c:contract number? ,left (quote ,(string->symbol (class-name))) '||) left))
|
|
(else left)))
|
|
(right (cond
|
|
((is-char? right-type)
|
|
(make-syntax #f `(char->integer ,right) #f))
|
|
((and (dynamic-val? type) (not (memq op '(== != & ^ or && oror))))
|
|
(create-syntax #f `(c:contract number? ,right (quote ,(string->symbol (class-name))) '||) right))
|
|
(else right)))
|
|
(result
|
|
(case op
|
|
;Mathematical operations
|
|
;PROBLEM! + and - do not take into account the possibility of overflow
|
|
((+)
|
|
(create-syntax #f
|
|
(cond
|
|
((and (is-string-type? type) (is-string-type? left-type))
|
|
`(send ,left concat-java.lang.String (javaRuntime:convert-to-string ,right)))
|
|
((and (is-string-type? type) (is-string-type? right-type))
|
|
`(send (javaRuntime:convert-to-string ,left) concat-java.lang.String ,right))
|
|
((is-string-type? type)
|
|
`(send (javaRuntime:convert-to-string ,left) concat-java.lang.String
|
|
(javaRuntime:convert-to-string ,right)))
|
|
(else
|
|
`(,op-syntax ,left ,right))) source))
|
|
((- *)
|
|
(create-syntax #f `(,op-syntax ,left ,right) source))
|
|
((/)
|
|
(let ((div-op
|
|
(cond
|
|
((or (is-double? left-type) (is-double? right-type))
|
|
'javaRuntime:divide-float)
|
|
((or (dynamic-val? left-type) (dynamic-val? right-type))
|
|
'javaRuntime:divide-dynamic)
|
|
(else
|
|
'javaRuntime:divide-int))))
|
|
(make-syntax #f `(,(create-syntax #f div-op key-src) ,left ,right) source)))
|
|
((%) (make-syntax #f `(,(create-syntax #f 'javaRuntime:mod key-src) ,left ,right) source))
|
|
;Shift operations
|
|
((<< >> >>>)
|
|
(make-syntax #f
|
|
`(,(create-syntax #f 'javaRuntime:shift key-src) (quote ,op) ,left ,right) source))
|
|
;comparisons
|
|
((< > <= >=) (make-syntax #f `(,op-syntax ,left ,right) source))
|
|
((==)
|
|
(make-syntax #f
|
|
(cond
|
|
((or (dynamic-val? left-type) (dynamic-val? right-type))
|
|
`(,(create-syntax #f 'eq? key-src) ,left ,right))
|
|
((and (prim-numeric-type? left-type) (prim-numeric-type? right-type))
|
|
`(,(create-syntax #f '= key-src) ,left ,right))
|
|
(else
|
|
`(,(create-syntax #f 'eq? key-src) ,left ,right))) source))
|
|
((!=)
|
|
(make-syntax #f `(,(create-syntax #f 'javaRuntime:not-equal key-src) ,left ,right) source))
|
|
;logicals
|
|
((& ^ or)
|
|
(make-syntax #f
|
|
`(,(create-syntax #f 'javaRuntime:bitwise key-src) (quote ,op) ,left ,right) source))
|
|
;boolean
|
|
((&&) (make-syntax #f `(,(create-syntax #f 'javaRuntime:and key-src) ,left ,right) source))
|
|
((oror) (make-syntax #f `(,(create-syntax #f 'javaRuntime:or key-src) ,left ,right) source))
|
|
(else
|
|
(error 'translate-op (format "Translate op given unknown operation ~s" op))))))
|
|
(if (dynamic-val? type)
|
|
(make-syntax #f
|
|
(convert-assert-value
|
|
(make-syntax #f `(c:contract ,(type->contract (dynamic-val-type type) #t) ,result
|
|
(quote ,(string->symbol (class-name))) '||) source)
|
|
type)
|
|
source)
|
|
result)))
|
|
|
|
;translate-access: (U field-access local-access) type src -> syntax
|
|
(define (translate-access name type src)
|
|
(cond
|
|
((local-access? name)
|
|
(let ((var (translate-id (build-var-name (id-string (local-access-name name)))
|
|
(id-src (local-access-name name)))))
|
|
(if (dynamic-val? type)
|
|
(let ((local-syntax (cond
|
|
((unknown-ref? (dynamic-val-type type))
|
|
`(let ((val-1 ,var))
|
|
(if (string? val-1)
|
|
(make-java-string val-1)
|
|
val-1)))
|
|
(else var))))
|
|
(make-syntax #f
|
|
(convert-assert-value
|
|
(make-syntax #f
|
|
`(c:contract ,(type->contract (dynamic-val-type type) #t)
|
|
,local-syntax (quote ,(string->symbol (class-name))) '||)
|
|
(build-src (id-src (local-access-name name))))
|
|
(dynamic-val-type type)) (build-src (id-src (local-access-name name)))))
|
|
var)))
|
|
((field-access? name)
|
|
(let* ((field-string (id-string (field-access-field name)))
|
|
(field-src (id-src (field-access-field name)))
|
|
(access (field-access-access name))
|
|
(obj (field-access-object name))
|
|
(cant-be-null? (never-null? obj))
|
|
(expr (if obj (translate-expression obj))))
|
|
(cond
|
|
((var-access-static? access)
|
|
(let ((static-name (build-static-name field-string (var-access-class access))))
|
|
(if (dynamic-val? type)
|
|
(let ((access-syntax (cond
|
|
((unknown-ref? (dynamic-val-type type))
|
|
`(let ((val-1 ,(translate-id static-name field-src)))
|
|
(if (string? val-1)
|
|
(make-java-string val-1)
|
|
val-1)))
|
|
(else (translate-id static-name field-src)))))
|
|
(make-syntax #f
|
|
(convert-assert-value
|
|
(make-syntax #f
|
|
`(c:contract ,(type->contract (dynamic-val-type type) #t)
|
|
,access-syntax
|
|
(quote ,(string->symbol (class-name))) '||)
|
|
(build-src field-src))
|
|
(dynamic-val-type type)) (build-src field-src)))
|
|
(translate-id (build-var-name static-name) field-src))))
|
|
((eq? 'array (var-access-class access))
|
|
(if cant-be-null?
|
|
(make-syntax #f `(send ,expr ,(translate-id field-string field-src)) (build-src src))
|
|
(make-syntax #f
|
|
`(if (null? ,expr)
|
|
(javaRuntime:nullError 'field)
|
|
(send ,expr ,(translate-id field-string field-src)))
|
|
(build-src src))))
|
|
((and (eq? (var-access-access access) 'private) (static-method))
|
|
(let* ((id (create-get-name field-string (var-access-class access)))
|
|
(getter `(send ,expr ,id ,expr))
|
|
(get-syntax (if cant-be-null?
|
|
(make-syntax #f getter (build-src src))
|
|
(make-syntax #f `(if (null? ,expr)
|
|
(javaRuntime:nullError 'field)
|
|
,getter)
|
|
(build-src src)))))
|
|
(if (dynamic-val? type)
|
|
(let ((access-syntax (cond
|
|
((unknown-ref? (dynamic-val-type type))
|
|
`(let ((val-1 ,get-syntax))
|
|
(if (string? val-1)
|
|
(make-java-string val-1)
|
|
val-1)))
|
|
(else get-syntax))))
|
|
(make-syntax #f
|
|
(convert-assert-value
|
|
(make-syntax #f
|
|
`(c:contract ,(type->contract (dynamic-val-type type) #t)
|
|
,access-syntax (quote ,(string->symbol (class-name))) '||)
|
|
(build-src field-src))
|
|
(dynamic-val-type type)) (build-src field-src)))
|
|
get-syntax)))
|
|
(else
|
|
(let* ((id (create-get-name field-string (var-access-class access)))
|
|
(get-syntax
|
|
(if cant-be-null?
|
|
(make-syntax #f `(,id ,expr) (build-src src))
|
|
(make-syntax #f
|
|
`(if (null? ,expr)
|
|
(javaRuntime:nullError 'field)
|
|
(,id ,expr))
|
|
(build-src src)))))
|
|
(if (dynamic-val? type)
|
|
(let ((access-syntax (cond
|
|
((unknown-ref? (dynamic-val-type type))
|
|
`(let ((val-1 ,get-syntax))
|
|
(if (string? val-1)
|
|
(make-java-string val-1)
|
|
val-1)))
|
|
(else get-syntax))))
|
|
(make-syntax #f
|
|
(convert-assert-value
|
|
(make-syntax #f
|
|
`(c:contract ,(type->contract (dynamic-val-type type) #t)
|
|
,access-syntax (quote ,(string->symbol (class-name))) '||)
|
|
(build-src field-src))
|
|
(dynamic-val-type type)) (build-src field-src)))
|
|
get-syntax))))))))
|
|
|
|
;translate-special-name: string src -> syntax
|
|
(define (translate-special-name name src)
|
|
(let ((id (build-identifier name)))
|
|
(make-syntax #f id (build-src src))))
|
|
|
|
;translate-specified-this: string src -> syntax
|
|
(define (translate-specified-this var src)
|
|
(make-syntax #f (build-identifier (string-append var "~f")) (build-src src)))
|
|
|
|
;translate-call: (U expression #f) (U special-name id) (list syntax) (list type) method-record type src-> syntax
|
|
(define (translate-call expr method-name args arg-types method-record rtype src)
|
|
(let ((cant-be-null? (never-null? expr))
|
|
(expression (if expr (translate-expression expr) #f))
|
|
(unique-name (gensym))
|
|
(translated-args
|
|
(if (method-contract? method-record)
|
|
(map (lambda (arg type)
|
|
(guard-convert-value arg type))
|
|
args arg-types)
|
|
(map (lambda (arg type call-type)
|
|
(if (eq? 'dynamic call-type)
|
|
(guard-convert-value arg type)
|
|
arg))
|
|
args arg-types (method-record-atypes method-record)))))
|
|
(cond
|
|
;Constructor case
|
|
((special-name? method-name)
|
|
(let* ((name (if (equal? (special-name-name method-name) "super")
|
|
(parent-name)
|
|
(class-name)))
|
|
(c-name (build-identifier (build-constructor-name name
|
|
(method-record-atypes method-record))))
|
|
(generic-c-name (build-identifier (build-generic-name name c-name))))
|
|
#;(create-syntax #f
|
|
(cond
|
|
((equal? (special-name-name method-name) "this")
|
|
`(,c-name ,@args))
|
|
((equal? (parent-name) "Object")
|
|
`(send ,(if expr expression 'this) ,c-name ,@args))
|
|
((and expr cant-be-null?)
|
|
`(send-generic ,expression ,generic-c-name ,@args))
|
|
((not expr)
|
|
`(send-generic this ,generic-c-name ,@args))
|
|
(else
|
|
`(let ((,unique-name ,expression))
|
|
(if (null? ,unique-name)
|
|
(javaRuntime:nullError 'method)
|
|
(send-generic ,unique-name ,generic-c-name ,@args)))))
|
|
(build-src src))
|
|
|
|
(if cant-be-null?
|
|
(create-syntax #f `(send ,(if expr expression 'this) ,c-name ,@translated-args) (build-src src))
|
|
(create-syntax #f
|
|
`(let ((,unique-name ,expression))
|
|
(if (null? ,unique-name)
|
|
(javaRuntime:nullError 'method)
|
|
(send ,unique-name ,c-name ,@translated-args)))
|
|
(build-src src)))))
|
|
|
|
;Normal case
|
|
((id? method-name)
|
|
(let* ((static? (and (not (method-contract? method-record))
|
|
(memq 'static (method-record-modifiers method-record))))
|
|
(temp (unless (method-contract? method-record)
|
|
(mangle-method-name (method-record-name method-record)
|
|
(method-record-atypes method-record))))
|
|
(m-name (cond
|
|
((method-contract? method-record)
|
|
(if (method-contract-prefix method-record)
|
|
(build-static-name
|
|
(java-name->scheme (method-contract-name method-record))
|
|
(method-contract-prefix method-record))
|
|
(java-name->scheme (method-contract-name method-record))))
|
|
(static?
|
|
(build-static-name temp (car (method-record-class method-record))))
|
|
(else temp)))
|
|
(generic-name (unless (method-contract? method-record)
|
|
(build-generic-name (car (method-record-class method-record)) m-name))))
|
|
(cond
|
|
((special-name? expr)
|
|
(let* ((over? (and (overridden? (string->symbol m-name)) (equal? "super" (special-name-name expr))))
|
|
(name (translate-id m-name (id-src method-name)))
|
|
(new-exp (cond
|
|
(static? (create-syntax #f `(,name ,@translated-args) (build-src src)))
|
|
(over? (create-syntax #f `(super ,name ,@translated-args) (build-src src)))
|
|
(else (create-syntax #f `(send this ,name ,@translated-args) (build-src src))))))
|
|
(if (or (method-contract? method-record)
|
|
(dynamic-val? rtype))
|
|
(make-syntax #f (convert-assert-value new-exp (if (method-contract? method-record)
|
|
(method-contract-return method-record)
|
|
(dynamic-val-type rtype))) (build-src src))
|
|
new-exp)))
|
|
((not expr)
|
|
(cond
|
|
((method-contract? method-record)
|
|
(make-syntax #f (convert-assert-value
|
|
(create-syntax #f `((c:contract ,(type->contract method-record #t)
|
|
,(build-identifier m-name #;(java-name->scheme (method-contract-name method-record)))
|
|
(quote ,(string->symbol (class-name))) '||)
|
|
,@translated-args) (build-src src))
|
|
(method-contract-return method-record))
|
|
(build-src src)))
|
|
((or static? (memq 'private (method-record-modifiers method-record)))
|
|
(let ((call-syn
|
|
(create-syntax #f `(,(translate-id m-name (id-src method-name)) ,@translated-args) (build-src src))))
|
|
(if (dynamic-val? rtype)
|
|
(make-syntax #f (convert-assert-value call-syn (dynamic-val-type rtype)) (build-src src))
|
|
call-syn)))
|
|
(else
|
|
(let ((call-syn
|
|
(create-syntax #f `(send this ,(translate-id m-name (id-src method-name)) ,@translated-args)
|
|
(build-src src))))
|
|
(if (dynamic-val? rtype)
|
|
(make-syntax #f (convert-assert-value call-syn (dynamic-val-type rtype)) (build-src src))
|
|
call-syn)))))
|
|
(else
|
|
(let* ((name (translate-id m-name (id-src method-name)))
|
|
(call
|
|
(cond
|
|
((and cant-be-null? (not static?))
|
|
(create-syntax #f `(send ,expression ,name ,@translated-args) (build-src src)))
|
|
(static? (create-syntax #f `(,name ,@translated-args) (build-src src)))
|
|
(else
|
|
(create-syntax #f
|
|
`(let ((,unique-name ,expression))
|
|
(if (null? ,unique-name)
|
|
(javaRuntime:nullError 'method)
|
|
(send ,unique-name ,name ,@translated-args)))
|
|
(build-src src))))))
|
|
(if (or (method-contract? method-record)
|
|
(dynamic-val? rtype))
|
|
(make-syntax #f (convert-assert-value call
|
|
(if (method-contract? method-record)
|
|
(method-contract-return method-record)
|
|
(dynamic-val-type rtype))) (build-src src))
|
|
call))))))
|
|
(else (error 'translate-call (format "Translate call given ~s as method-name" method-name))))))
|
|
|
|
;Add more checks perhaps to see in other cases if it can be null
|
|
;never-null? expression -> bool
|
|
(define (never-null? expr)
|
|
(cond
|
|
((not expr) #t)
|
|
((special-name? expr) #t)
|
|
((class-alloc? expr) #t)
|
|
((and (access? expr)
|
|
(local-access? (access-name expr))
|
|
(regexp-match "encl-this-" (id-string (local-access-name (access-name expr))))) #t)
|
|
(else #f)))
|
|
|
|
(define (overridden? name)
|
|
(hash-table-get (class-override-table) name (lambda () #f)))
|
|
|
|
;translate-class-alloc: (U name id def) (list type) (list syntax) src bool bool method-record-> syntax
|
|
(define (translate-class-alloc class-type arg-types args src inner? local-inner? ctor-record)
|
|
(when (id? class-type) (set! class-type (make-name class-type null (id-src class-type))))
|
|
(let* ((class-string
|
|
(if (def? class-type)
|
|
(get-class-string (make-name (def-name class-type) null #f))
|
|
(get-class-string class-type)))
|
|
(class-id (if (def? class-type)
|
|
(def-name class-type)
|
|
(name-id class-type)))
|
|
(default-name (translate-id class-string (id-src class-id)))
|
|
(default-ctor (translate-id (build-constructor-name
|
|
(cond
|
|
(local-inner?
|
|
(regexp-replace "-[0-9]*" (method-record-name ctor-record) ""))
|
|
((and (name? class-type) (null? (name-path class-type)))
|
|
class-string)
|
|
(else (id-string (name-id class-type))))
|
|
(method-record-atypes ctor-record))
|
|
(id-src class-id))))
|
|
(make-syntax
|
|
#f
|
|
(cond
|
|
(local-inner?
|
|
`(let ((new-o (make-object ,default-name
|
|
,@(if (static-method)
|
|
null
|
|
(let loop ((d (current-depth)))
|
|
(cond
|
|
((= d 0) '(this))
|
|
(else (cons (build-identifier (format "encl-this-~a~~f" d))
|
|
(loop (sub1 d)))))))
|
|
,@(let loop ((args (def-closure-args
|
|
(if (def? class-type)
|
|
class-type
|
|
(find-inner class-string (current-local-classes))))))
|
|
(cond
|
|
((null? args) null)
|
|
(else (cons (translate-id (string-append (id-string (car args)) "~f") #f)
|
|
(loop (cdr args)))))))))
|
|
(send new-o ,default-ctor ,@args)
|
|
new-o))
|
|
(inner?
|
|
`(send this ,(translate-id (mangle-method-name (string-append "construct-" class-string)
|
|
(method-record-atypes ctor-record))
|
|
(id-src class-id))
|
|
,@args))
|
|
(else `(let ((new-o (make-object ,default-name)))
|
|
(send new-o ,default-ctor ,@args)
|
|
new-o)))
|
|
(build-src src))))
|
|
|
|
;find-inner: string (list def) -> def
|
|
(define (find-inner name classes)
|
|
(cond
|
|
((equal? name (id-string (def-name (car classes))))
|
|
(car classes))
|
|
(else (find-inner name (cdr classes)))))
|
|
|
|
|
|
;translate-inner-alloc: syntax id (list syntax) src method-record -> syntax
|
|
(define (translate-inner-alloc obj class args src ctor-record)
|
|
(make-syntax #f `(send ,obj ,(translate-id (mangle-method-name (string-append "construct-"
|
|
(get-class-string (make-name class null #f)))
|
|
(method-record-atypes ctor-record))
|
|
(id-src class))
|
|
,@args)
|
|
(build-src src)))
|
|
|
|
;translate-array-alloc: type-spec (list syntax) src -> syntax
|
|
(define (translate-array-alloc type sizes src)
|
|
(create-array sizes (translate-type-spec type) src))
|
|
|
|
;create-array: (list syntax) type src -> syntax
|
|
(define (create-array sizes type src)
|
|
(cond
|
|
((null? sizes)
|
|
(error 'create-array "Internal Error: create array given a null list"))
|
|
((null? (cdr sizes))
|
|
(make-syntax #f `(make-java-array ,type ,(car sizes) null) (build-src src)))
|
|
(else
|
|
(make-syntax #f `(make-java-array ,type (list ,@sizes) null) (build-src src)))))
|
|
|
|
;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)))
|
|
|
|
;translate-type-spec: type-spec -> syntax
|
|
(define (translate-type-spec type)
|
|
(make-syntax #f
|
|
`(make-runtime-type ,(if (symbol? (type-spec-name type))
|
|
`(quote ,(type-spec-name type))
|
|
(build-identifier
|
|
(if (null? (name-path (type-spec-name type)))
|
|
(id-string (name-id (type-spec-name type)))
|
|
(append (map id-string (name-path (type-spec-name type)))
|
|
(list (id-string (name-id (type-spec-name type))))))))
|
|
,(type-spec-dim type))
|
|
(build-src (type-spec-src type))))
|
|
|
|
;converted
|
|
;translate-array-access: syntax syntax src -> syntax
|
|
(define translate-array-access
|
|
(lambda (array index src)
|
|
(make-syntax #f `(send ,array access ,index)
|
|
(build-src src))))
|
|
|
|
;converted
|
|
;translate-cond: syntax syntax syntax src -> syntax
|
|
(define translate-cond
|
|
(lambda (if? then else src)
|
|
(make-syntax #f `(if ,if? ,then ,else) (build-src src))))
|
|
|
|
;converted
|
|
;translate-post-expr: syntax symbol src src -> syntax
|
|
(define translate-post-expr
|
|
(lambda (expr op key src)
|
|
(make-syntax #f `(begin0
|
|
,expr
|
|
(set! ,expr ( ,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))
|
|
,expr)))
|
|
(build-src src))))
|
|
|
|
;converted
|
|
;translate-pre-expr: symbol syntax src src -> syntax
|
|
(define translate-pre-expr
|
|
(lambda (op expr key src)
|
|
(make-syntax #f
|
|
`(begin
|
|
(set! ,expr (,(create-syntax #f (if (eq? op '++) 'add1 'sub1) (build-src key))
|
|
,expr))
|
|
,expr)
|
|
(build-src src))))
|
|
|
|
;converted
|
|
;translate-unary: symbol syntax src src -> syntax
|
|
(define translate-unary
|
|
(lambda (op expr key src)
|
|
(make-syntax #f (case op
|
|
((-) `(,(create-syntax #f '- (build-src key)) ,expr))
|
|
((!) `(,(create-syntax #f 'not (build-src key)) ,expr))
|
|
((~) `(,(create-syntax #f '- (build-src key)) (- ,expr) 1))
|
|
((+) expr))
|
|
(build-src src))))
|
|
|
|
;converted
|
|
;translate-cast: type-spec syntax type src
|
|
(define (translate-cast type expr expr-type src)
|
|
(cond
|
|
((eq? 'dynamic (type-spec-name type))
|
|
(make-syntax #f (guard-convert-value expr expr-type) (build-src src)))
|
|
((dynamic-val? expr-type)
|
|
(make-syntax #f (convert-assert-value
|
|
(create-syntax #f `(c:contract ,(type->contract expr-type #t) ,expr
|
|
(quote ,(string->symbol (class-name))) '||)
|
|
(build-src src)) expr-type)
|
|
(build-src src)))
|
|
((symbol? (type-spec-name type))
|
|
(make-syntax #f `(javaRuntime:cast-primitive ,expr (quote ,(type-spec-name type)) ,(type-spec-dim type))
|
|
(build-src src)))
|
|
(else
|
|
(make-syntax #f `(javaRuntime:cast-reference ,expr ,(get-class-name type)
|
|
,(type-spec-dim type)
|
|
(quote ,(get-class-name type)))
|
|
(build-src src)))))
|
|
|
|
;translate-instanceof: syntax type-spec src -> syntax
|
|
(define (translate-instanceof expr type src)
|
|
(if (> (type-spec-dim type) 0)
|
|
(make-syntax #f
|
|
(if (symbol? (type-spec-name type))
|
|
`(javaRuntime:instanceof-array #t ,expr (quote ,(type-spec-name type)) ,(type-spec-dim type))
|
|
`(javaRuntime:instanceof-array #f ,expr ,(get-class-name type) ,(type-spec-dim type)))
|
|
(build-src src))
|
|
(let ((syntax-type (get-class-name type)))
|
|
(if (or (eq? (syntax-e syntax-type) 'Object) (eq? (syntax-e syntax-type) 'java.lang.Object))
|
|
(make-syntax #f `(is-a? ,expr ObjectI) (build-src src))
|
|
(make-syntax #f `(is-a? ,expr ,syntax-type) (build-src src))))))
|
|
|
|
;translate-assignment: (U access array-access) symbol syntax expression type src src -> syntax
|
|
(define (translate-assignment name op expr assign-to type key src)
|
|
(let ((expression (lambda (name)
|
|
(let ((expanded-expr
|
|
(case op
|
|
((=) expr)
|
|
((*=) `(* ,name ,expr))
|
|
((/=) `(/ ,name ,expr))
|
|
((+=) `(+ ,name ,expr))
|
|
((-=) `(- ,name ,expr))
|
|
((>>=) `(javaRuntime:shift '>> ,name ,expr))
|
|
((<<=) `(javaRuntime:shift '<< ,name ,expr))
|
|
((>>>=) `(javaRuntime:shift '>>> ,name ,expr))
|
|
((%= &= ^= or=)
|
|
(error 'translate-assignment "Only supports =, +=, -=, *=, & /= >>= <<= >>>= at this time")))))
|
|
(if (or (eq? type 'dynamic) (dynamic-val? type))
|
|
(guard-convert-value (make-syntax #f expanded-expr (build-src src)) (expr-types assign-to))
|
|
expanded-expr)))))
|
|
(cond
|
|
((array-access? name)
|
|
(translate-array-mutation name expression assign-to src))
|
|
((access? name)
|
|
(let* ((access (access-name name))
|
|
(src-h (build-src src))
|
|
(set-h
|
|
(lambda (id)
|
|
(make-syntax #f `(begin (,(create-syntax #f 'set! (build-src key))
|
|
,id ,(expression id)) ,id) src-h))))
|
|
(cond
|
|
((local-access? access)
|
|
(set-h (translate-id (build-var-name (id-string (local-access-name access)))
|
|
(id-src (local-access-name access)))))
|
|
((field-access? access)
|
|
(let* ((field (id-string (field-access-field access)))
|
|
(field-src (id-src (field-access-field access)))
|
|
(vaccess (field-access-access access))
|
|
(obj (field-access-object access))
|
|
(expr (if obj (translate-expression obj))))
|
|
(cond
|
|
((var-access-static? vaccess)
|
|
(set-h (build-identifier (build-static-name (build-var-name field)
|
|
(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)
|
|
(make-syntax #f
|
|
`(lambda (my-dummy new-val)
|
|
((class-field-mutator ,(build-identifier (var-access-class vaccess))
|
|
,(build-identifier field))
|
|
this new-val))
|
|
#f)
|
|
(create-set-name field (var-access-class vaccess))))
|
|
(getter (create-get-name field (var-access-class vaccess)))
|
|
(name (gensym 'field-obj))
|
|
(new-val (gensym 'val)))
|
|
(make-syntax #f
|
|
`(let* ((,name ,expr)
|
|
(,new-val ,(expression `(,getter ,name))))
|
|
(,setter ,name ,new-val)
|
|
,new-val)
|
|
src-h))))))))))))
|
|
|
|
;translate-array-mutation: array-access (syntax -> (list symbol syntax syntax)) expression src -> syntax
|
|
(define (translate-array-mutation array expression expr src)
|
|
(let ((array-name (translate-expression (array-access-name array)))
|
|
(array-index (translate-expression (array-access-index array)))
|
|
(name (gensym 'my-expr))
|
|
(index (gensym 'my-index))
|
|
(new-val (gensym 'val)))
|
|
(make-syntax #f
|
|
`(let* ((,name ,array-name)
|
|
(,index ,array-index)
|
|
(,new-val ,(expression `(send ,name access ,index))))
|
|
(send ,name set ,index ,new-val)
|
|
,new-val)
|
|
(build-src src))))
|
|
|
|
;translate-id: string src -> syntax
|
|
(define translate-id
|
|
(lambda (id src)
|
|
(create-syntax #f (build-identifier id) (build-src src))))
|
|
|
|
) |