1447 lines
67 KiB
Scheme
1447 lines
67 KiB
Scheme
(module Object-composite scheme/base
|
|
|
|
(require scheme/class
|
|
(prefix-in c: scheme/contract)
|
|
errortrace
|
|
|
|
profj/libs/java/lang/Comparable
|
|
profj/libs/java/io/Serializable)
|
|
#;(require "compile-lang-syntax.ss")
|
|
|
|
(define make-hash-table make-hash)
|
|
(define hash-table-put! hash-set!)
|
|
|
|
;Runtime needed code
|
|
(define (javaRuntime:convert-to-string data)
|
|
(cond
|
|
((number? data) (make-java-string (number->string data)))
|
|
((boolean? data)
|
|
(make-java-string (if data "true" "false")))
|
|
((char? data) (make-java-string (string data)))
|
|
((is-a? data ObjectI) (send data toString))
|
|
((is-a? data object%) (make-java-string "SchemeObject"))
|
|
(else (error 'JavaRuntime:Internal_Error:convert-to-string
|
|
(format "Convert to string given unsupported data: ~s" data)))))
|
|
|
|
|
|
;
|
|
; ;; ;
|
|
; ;;; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ;;;; ;;;; ;;; ;;; ;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ;;;;; ; ;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ;;; ; ;;; ;;; ;;;
|
|
; ;
|
|
; ;
|
|
; ;;;
|
|
|
|
;Object.java
|
|
(provide ObjectI Object-Mix Object
|
|
wrap-convert-assert-Object convert-assert-Object guard-convert-Object dynamic-Object/c static-Object/c)
|
|
|
|
;Object interface, and a mixin to create objects from.
|
|
|
|
(define ObjectI
|
|
(interface () Object-constructor clone equals-java.lang.Object finalize getClass
|
|
hashCode notify notifyAll toString wait wait-long wait-long-int my-name
|
|
equals hash-code to-string get-class))
|
|
|
|
(define Object-Mix
|
|
(lambda (parent)
|
|
(class* parent (ObjectI)
|
|
(inspect #f)
|
|
(define/public (Object-constructor) (void))
|
|
|
|
;Needs to do something
|
|
(define/public clone (lambda () void))
|
|
|
|
(define/public (equals-java.lang.Object obj)
|
|
(or (eq? this obj)
|
|
(and (is-a? obj wrapper)
|
|
(send obj compare this obj))))
|
|
(define/public (equals obj) (send this equals-java.lang.Object obj))
|
|
|
|
;Needs to do something
|
|
(define/public (finalize) void)
|
|
|
|
(public-final getClass get-class)
|
|
(define (getClass)
|
|
(error 'ProfessorJ:getClass
|
|
(format "ProfessorJ does not support getClass calls. ~e"
|
|
(send this toString))))
|
|
(define (get-class) (getClass))
|
|
|
|
(define/public (hashCode) (eq-hash-code this))
|
|
(define/public (hash-code) (send this hashCode))
|
|
|
|
;Needs to do something when Threads more implemented
|
|
(public-final notify |notifyAll|)
|
|
(define (notify) void)
|
|
(define (notifyAll) void)
|
|
|
|
(define/public (my-name) "Object")
|
|
(define/public (toString)
|
|
(make-java-string (format "~a@~a" (send this my-name) (send this hashCode))))
|
|
(define/public (to-string) (send this toString))
|
|
|
|
(public-final wait wait-long wait-long-int)
|
|
(define wait (lambda () void))
|
|
(define wait-long (lambda (l) void))
|
|
(define wait-long-int (lambda (l i) void))
|
|
|
|
(define/public (field-names) null)
|
|
(define/public (field-values) null)
|
|
|
|
(define/public (fields-for-display)
|
|
(let ((field-name-list (send this field-names))
|
|
(field-value-list (send this field-values)))
|
|
(lambda ()
|
|
(if (null? field-name-list)
|
|
#f
|
|
(begin0 (list (car field-name-list) (car field-value-list))
|
|
(set! field-name-list (cdr field-name-list))
|
|
(set! field-value-list (cdr field-value-list)))))))
|
|
|
|
(super-instantiate ()))))
|
|
|
|
(define Object (Object-Mix object%))
|
|
|
|
(define (wrap-convert-assert-Object obj p n s c)
|
|
(if (string? obj)
|
|
(make-java-string string)
|
|
(begin
|
|
(c:contract (object-contract
|
|
(clone (c:-> c:any/c))
|
|
(equals-java.lang.Object (c:-> c:any/c c:any/c))
|
|
(finalize (c:-> c:any/c))
|
|
(getClass (c:-> c:any/c))
|
|
(hashCode (c:-> c:any/c))
|
|
(notify (c:-> c:any/c))
|
|
(notifyAll (c:-> c:any/c))
|
|
(toString (c:-> c:any/c))
|
|
(wait (c:-> c:any/c))
|
|
(wait-long (c:-> c:any/c c:any/c))
|
|
(wait-long-int (c:-> c:any/c c:any/c c:any/c))) obj p n s)
|
|
(make-object convert-assert-Object obj p n s c))))
|
|
|
|
(define-local-member-name get-wrapped)
|
|
(define wrapper (interface () get-wrapped))
|
|
(provide wrapper)
|
|
|
|
(define convert-assert-Object
|
|
(class* object% (wrapper)
|
|
|
|
(init w)
|
|
(init-field pos-blame neg-blame src cc-marks)
|
|
|
|
(define wrapped null)
|
|
(set! wrapped w)
|
|
|
|
(define/public (get-wrapped) wrapped)
|
|
(define/public (compare obj1 obj2)
|
|
(cond
|
|
((and (is-a? obj1 wrapper) (is-a? obj2 wrapper))
|
|
(compare (send obj1 get-wrapped) (send obj2 get-wrapped)))
|
|
((is-a? obj1 wrapper)
|
|
(compare (send obj1 get-wrapped) obj2))
|
|
((is-a? obj2 wrapper)
|
|
(compare obj1 (send obj2 get-wrapped)))
|
|
(else (eq? obj1 obj2))))
|
|
|
|
(define/public (down-cast class wrapped-class)
|
|
(and (check-instance class)
|
|
(make-object wrapped-class wrapped pos-blame neg-blame src cc-marks)))
|
|
|
|
(define/public (check-instance class)
|
|
(if (is-a? wrapped wrapper)
|
|
(send wrapped check-instance class)
|
|
(is-a? wrapped class)))
|
|
|
|
(define/public (clone) (send wrapped clone))
|
|
(define/public (equals-java.lang.Object obj)
|
|
(let ((val (send wrapped equals-java.lang.Object
|
|
(make-object guard-convert-Object obj pos-blame neg-blame src cc-marks))))
|
|
(unless (boolean? val)
|
|
(raise (make-exn:fail (format "~a broke ~a contract here; Object's equals expects boolean return, given ~a"
|
|
pos-blame neg-blame val)
|
|
cc-marks)))
|
|
val))
|
|
|
|
(define/public (finalize) (send wrapped finalize))
|
|
(define/public (getClass) (send wrapped getClass))
|
|
|
|
(define/public (hashCode)
|
|
(let ((val (send wrapped hashCode)))
|
|
(unless (integer? val)
|
|
(raise (make-exn:fail
|
|
(format "~a broke ~a contract here; Object's hashCode expects int return, given ~a"
|
|
pos-blame neg-blame val)
|
|
cc-marks)))
|
|
val))
|
|
|
|
(define/public (notify) (send wrapped notify))
|
|
(define/public (notifyAll) (send wrapped notifyAll))
|
|
(define/public (toString)
|
|
(let ((val (send wrapped toString)))
|
|
(unless (string? val)
|
|
(raise (make-exn:fail
|
|
(format "~a broke ~a contract here: Object's toString expects String return, given ~a"
|
|
pos-blame neg-blame val)
|
|
cc-marks)))
|
|
(make-java-string val)))
|
|
(define/public (wait) (send wrapped wait))
|
|
(define/public (wait-long l) (send wrapped wait-long l))
|
|
(define/public (wait-long-int l i) (send wrapped wait-long l i))
|
|
(define/public (my-name) (send wrapped my-name))
|
|
(define/public (field-names) (send wrapped field-names))
|
|
(define/public (field-values) (send wrapped field-values))
|
|
(define/public (fields-for-display) (send wrapped fields-for-display))
|
|
|
|
(public-final pos-blame* neg-blame* src* cc-marks*)
|
|
(define (pos-blame*) (ca-pos-blame* this))
|
|
(define (neg-blame*) (ca-neg-blame* this))
|
|
(define (src*) (ca-src* this))
|
|
(define (cc-marks*) (ca-cc-marks* this))
|
|
|
|
(super-instantiate ())))
|
|
|
|
(define ca-pos-blame* (class-field-accessor convert-assert-Object pos-blame))
|
|
(define ca-neg-blame* (class-field-accessor convert-assert-Object neg-blame))
|
|
(define ca-src* (class-field-accessor convert-assert-Object src))
|
|
(define ca-cc-marks* (class-field-accessor convert-assert-Object cc-marks))
|
|
|
|
(define dynamic-Object/c
|
|
(c:flat-named-contract "Object" (lambda (v) (is-a? v convert-assert-Object))))
|
|
|
|
(define guard-convert-Object
|
|
(class* object% (wrapper)
|
|
|
|
(init w)
|
|
(init-field pos-blame neg-blame src cc-marks)
|
|
|
|
(define wrapped null)
|
|
(set! wrapped w)
|
|
|
|
(define/public (get-wrapped) wrapped)
|
|
|
|
(define/public (compare obj1 obj2)
|
|
(cond
|
|
((and (is-a? obj1 wrapper) (is-a? obj2 wrapper))
|
|
(compare (send obj1 get-wrapped) (send obj2 get-wrapped)))
|
|
((is-a? obj1 wrapper)
|
|
(compare (send obj1 get-wrapped) obj2))
|
|
((is-a? obj2 wrapper)
|
|
(compare obj1 (send obj2 get-wrapped)))
|
|
(else (eq? obj1 obj2))))
|
|
|
|
(define/public (down-cast class wrapped-class)
|
|
(and (check-instance class)
|
|
(make-object wrapped-class wrapped pos-blame neg-blame src cc-marks)))
|
|
|
|
(define/public (check-instance class)
|
|
(if (is-a? wrapped wrapper)
|
|
(send wrapped check-instance class)
|
|
(is-a? wrapped class)))
|
|
|
|
(define/public (clone) (send wrapped clone))
|
|
(define/public (equals-java.lang.Object . obj)
|
|
(unless (= (length obj) 1)
|
|
(raise (make-exn:fail:contract:arity
|
|
(format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n"
|
|
pos-blame neg-blame (length obj))
|
|
cc-marks)))
|
|
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
|
|
(define/public (equals . obj)
|
|
(unless (= (length obj) 1)
|
|
(raise (make-exn:fail:contract:arity
|
|
(format "~a broke ~a contract here: Object's equals expects to be called with 1 argument, given ~n"
|
|
pos-blame neg-blame (length obj))
|
|
cc-marks)))
|
|
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
|
|
(define/public (finalize) (send wrapped finalize))
|
|
(define/public (getClass) (send wrapped getClass))
|
|
(define/public (get-class) (send wrapped getClass))
|
|
(define/public (hashCode) (send wrapped hashCode))
|
|
(define/public (hash-code) (send wrapped hashCode))
|
|
(define/public (notify) (send wrapped notify))
|
|
(define/public (notifyAll) (send wrapped notifyAll))
|
|
(define/public (notify-all) (send wrapped notifyAll))
|
|
(define/public (toString)
|
|
(send (send wrapped toString) get-mzscheme-string))
|
|
(define/public (to-string) (send (send wrapped toString) get-mzscheme-string))
|
|
(define/public (wait) (send wrapped wait))
|
|
(define/public (wait-long . l)
|
|
(unless (= (length l) 1)
|
|
(raise (make-exn:fail:contract:arity
|
|
(format "~a broke ~a contract here: Object's wait-long expects to be called with 1 argument, given ~n"
|
|
pos-blame neg-blame (length l))
|
|
cc-marks)))
|
|
(unless (integer? (car l))
|
|
(raise (make-exn:fail
|
|
(format "~a broke ~a contract here: Object's wait that takes a long argument expected long, given ~a"
|
|
pos-blame neg-blame (car l))
|
|
cc-marks)))
|
|
(send wrapped wait-long (car l)))
|
|
(define/public (wait-long-int . l)
|
|
(unless (= (length l) 2)
|
|
(raise (make-exn:fail:contract:arity
|
|
(format "~a broke ~a contract here: Object's wait-long-int expects to be called with 2 arguments, given ~n"
|
|
pos-blame neg-blame (length l))
|
|
cc-marks)))
|
|
(unless (integer? (car l))
|
|
(raise (make-exn:fail
|
|
(format "~a broke ~a contract here: Object's wait-long-int expected long, given ~a"
|
|
pos-blame neg-blame (car l))
|
|
cc-marks)))
|
|
(unless (integer? (cadr l))
|
|
(raise (make-exn:fail
|
|
(format "~a broke ~a contract here: Object's wait-long-int expected int, given ~a"
|
|
pos-blame neg-blame (cadr l))
|
|
cc-marks)))
|
|
(send wrapped wait-long (car l) (cadr l)))
|
|
(define/public (my-name) (send wrapped my-name))
|
|
(define/public (field-names) (send wrapped field-names))
|
|
(define/public (field-values) (send wrapped field-values))
|
|
(define/public (fields-for-display) (send wrapped fields-for-display))
|
|
(define/public (get-pos) (gc-pos-blame* this))
|
|
|
|
(public-final pos-blame* neg-blame* src* cc-marks*)
|
|
(define (pos-blame*) (gc-pos-blame* this))
|
|
(define (neg-blame*) (gc-neg-blame* this))
|
|
(define (src*) (gc-src* this))
|
|
(define (cc-marks*) (gc-cc-marks* this))
|
|
|
|
(super-instantiate ())))
|
|
|
|
(define gc-pos-blame* (class-field-accessor guard-convert-Object pos-blame))
|
|
(define gc-neg-blame* (class-field-accessor guard-convert-Object neg-blame))
|
|
(define gc-src* (class-field-accessor guard-convert-Object src))
|
|
(define gc-cc-marks* (class-field-accessor guard-convert-Object cc-marks))
|
|
|
|
(define static-Object/c
|
|
(c:flat-named-contract "Object" (lambda (v) (is-a? v guard-convert-Object))))
|
|
|
|
;
|
|
;
|
|
; ;;;
|
|
; ;
|
|
; ; ; ; ;;; ; ;;; ;;;; ;;; ;;;
|
|
; ; ; ; ; ; ; ;
|
|
; ;;;;; ; ; ;;;; ; ;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;;;
|
|
; ;;; ;;; ;;;; ;;;; ;;; ; ;
|
|
; ;
|
|
; ;
|
|
; ;;
|
|
|
|
;;array implementation:
|
|
(provide make-java-array is-java-array? make-runtime-type array->list)
|
|
|
|
(define java-array
|
|
(class* Object ()
|
|
(inspect #f)
|
|
(define array null)
|
|
(define rt #f)
|
|
(define/public (get-rt) rt)
|
|
|
|
(define/private (check-runtime-type val)
|
|
(if (<= (runtime-type-dim rt) 1)
|
|
(if (symbol? (runtime-type-type rt))
|
|
(case (runtime-type-type rt)
|
|
((byte short int long) (and (number? val) (not (inexact? val))))
|
|
((char) (char? val))
|
|
((float double) (number? val) #;(and (number? val) (inexact? val))))
|
|
(is-a? val (runtime-type-type rt)))
|
|
(and
|
|
(is-a? val java-array)
|
|
(= (sub1 (runtime-type-dim rt))
|
|
(runtime-type-dim (send val get-rt)))
|
|
(eq? (runtime-type-type rt) (runtime-type-type (send val get-rt))))))
|
|
|
|
(define/public (check-prim-type type dim)
|
|
(and (eq? (runtime-type-type rt) type)
|
|
#;(= dim (runtime-type-dim rt))))
|
|
(define/public (check-ref-type type dim)
|
|
(and (eq? (runtime-type-type rt) type)
|
|
#;(= dim (runtime-type-dim rt))))
|
|
|
|
(define/private (default-val)
|
|
(if (and (= 1(runtime-type-dim rt)) (symbol? (runtime-type-type rt)))
|
|
(case (runtime-type-type rt)
|
|
((byte short int long float double) 0)
|
|
((char) #\null)
|
|
((boolean) #f))
|
|
null))
|
|
|
|
(define/public (length) (vector-length array))
|
|
|
|
(define/private (array-out-of-bounds i)
|
|
(raise (create-java-exception ArrayIndexOutOfBoundsException
|
|
(format "Array index out of bounds. Range is 0 to ~a, given ~a"
|
|
(sub1 (vector-length array)) i)
|
|
(lambda (obj msg)
|
|
(send obj ArrayIndexOutOfBoundsException-constructor-java.lang.String msg))
|
|
(current-continuation-marks))))
|
|
|
|
(define/public (access index)
|
|
(when (or (< index 0) (>= index (length)))
|
|
(array-out-of-bounds index))
|
|
(vector-ref array index))
|
|
|
|
(define/public (set index val)
|
|
(when (or (< index 0) (>= index (length)))
|
|
(array-out-of-bounds index))
|
|
(if (check-runtime-type val)
|
|
(vector-set! array index val)
|
|
(raise (create-java-exception ArrayStoreException
|
|
"Array given incompatible type"
|
|
(lambda (obj msg)
|
|
(send obj ArrayStoreException-constructor-java.lang.String msg))
|
|
(current-continuation-marks)))))
|
|
|
|
(define/public (make-uninitialized size type)
|
|
(when (< size 0)
|
|
(raise (create-java-exception NegativeArraySizeException
|
|
(format "Size for the array must be greater than 0, given ~a" size)
|
|
(lambda (obj msg)
|
|
(send obj NegativeArraySizeException-constructor-java.lang.String msg))
|
|
(current-continuation-marks))))
|
|
(set! rt type)
|
|
(set! array (make-vector size (default-val))))
|
|
|
|
(define/public (make-initialized type vals)
|
|
(set! rt type)
|
|
(set! array (list->vector vals)))
|
|
|
|
(define/public (make-multi-dimension type size default-val)
|
|
(set! rt type)
|
|
(set! array (make-vector size default-val)))
|
|
|
|
(define/public (make-uninit-multi type sizes)
|
|
(set! rt type)
|
|
(set! array
|
|
(if (null? (cdr sizes))
|
|
(make-vector (car sizes) (default-val))
|
|
(let ((vec (make-vector (car sizes))))
|
|
(let loop ((idx 0))
|
|
(unless (>= idx (car sizes))
|
|
(vector-set! vec idx (make-java-array (make-runtime-type (runtime-type-type type)
|
|
(sub1 (runtime-type-dim type)))
|
|
(cdr sizes) null))
|
|
(loop (add1 idx))))
|
|
vec))))
|
|
|
|
(define/override (my-name) "array")
|
|
|
|
(super-instantiate ())))
|
|
|
|
(define (make-java-array type size vals)
|
|
(let ((array (make-object java-array)))
|
|
(cond
|
|
((list? size) (send array make-uninit-multi type size))
|
|
((null? vals) (send array make-uninitialized size type))
|
|
((list? vals) (send array make-initialized type vals))
|
|
(else (send array make-multi-dimension type size vals)))
|
|
array))
|
|
|
|
(define (is-java-array? obj) (is-a? obj java-array))
|
|
|
|
(define-struct runtime-type (type dim) #:transparent)
|
|
|
|
(define (array->list array start stop)
|
|
(if (= start stop)
|
|
null
|
|
(cons (send array access start)
|
|
(array->list array (add1 start) stop))))
|
|
|
|
|
|
;
|
|
; ;
|
|
; ;;;; ;
|
|
; ; ; ;
|
|
; ; ;;;;; ; ;;; ;;; ; ;;; ;;; ;
|
|
; ;;; ; ; ; ;; ; ; ;
|
|
; ;;; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;;; ;;; ;;;; ;;;;; ;;; ;; ;;;;
|
|
; ;
|
|
; ;
|
|
; ;;;
|
|
|
|
;;String.java
|
|
(provide make-java-string String String-valueOf-java.lang.Object String-valueOf-char1
|
|
String-valueOf-char1-int-int String-copyValueOf-char1-int-int String-copyValueOf-char1
|
|
String-valueOf-boolean String-valueOf-char String-valueOf-int String-valueOf-long
|
|
String-valueOf-float String-valueOf-double)
|
|
|
|
(define (make-java-string s)
|
|
(let ((obj (make-object String)))
|
|
(send obj make-mzscheme-string s)
|
|
obj))
|
|
|
|
(define String
|
|
(class* Object (Comparable Serializable)
|
|
|
|
(inspect #f)
|
|
;private field containing scheme string
|
|
(define text "")
|
|
;Accessor for scheme string
|
|
(define/public (get-mzscheme-string) text)
|
|
|
|
;Constructors
|
|
(define/public (String-constructor) (send this Object-constructor))
|
|
|
|
(define/public (String-constructor-java.lang.String string)
|
|
(send this Object-constructor)
|
|
(set! text (send string get-mzscheme-string)))
|
|
|
|
(define/public (String-constructor-char1 chars)
|
|
(send this Object-constructor)
|
|
(set! text (list->string (array->list chars 0 (send chars length)))))
|
|
|
|
(define/public (String-constructor-char1-int-int chars offset count)
|
|
(send this Object-constructor)
|
|
(set! text (list->string (array->list chars offset count))))
|
|
|
|
;Does not take into account char-set: PROBLEM
|
|
(define/public (String-constructor-byte1-int-int-java.lang.String ascii offset len char-set)
|
|
(send this Object-constructor)
|
|
(set! text (list->string (map integer->char (array->list ascii offset len)))))
|
|
(define/public (|String-constructor-byte1-java.lang.String| ascii char-set)
|
|
(send this Object-constructor)
|
|
(set! text (list->string (map integer->char (array->list ascii 0 (send ascii length))))))
|
|
|
|
;currently broken until I figure out how to deal appropriately with hi bytes
|
|
(define/public (String-constructor-byte1-int-int-int ascii hi offset count)
|
|
(send this Object-constructor))
|
|
(define/public (String-constructor-byte1-int ascii hi)
|
|
(send this Object-constructor))
|
|
|
|
(define/public (String-constructor-StringBuffer buffer)
|
|
(send this Object-constructor)
|
|
(set! text (substring (send (send buffer toString) get-mzscheme-string)
|
|
0
|
|
(send buffer length))))
|
|
|
|
;Constructor to use when a string is constructed by ""
|
|
(define/public (make-mzscheme-string str)
|
|
(send this Object-constructor)
|
|
(set! text str))
|
|
|
|
(define/override (toString) this)
|
|
|
|
; -> int
|
|
(define/public (length) (string-length text))
|
|
; int -> char
|
|
(define/public (charAt-int index) (string-ref text index))
|
|
(define/public (char-at i) (charAt-int i))
|
|
|
|
;-> void
|
|
(define/public (getChars-int-int-char1-int begin end dest i)
|
|
(letrec ((build-char-array
|
|
(lambda (offset index)
|
|
(if (= offset end)
|
|
(void)
|
|
(begin
|
|
(send dest set index (string-ref text offset))
|
|
(build-char-array (add1 offset) (add1 index)))))))
|
|
(build-char-array begin i)))
|
|
(define/public (get-chars b e d i) (getChars-int-int-char1-int b e d i))
|
|
|
|
;Does not mess with charset
|
|
(define/public (getBytes)
|
|
(letrec ((array (make-java-array (make-runtime-type 'byte) (length) null))
|
|
(build-byte-array
|
|
(lambda (index)
|
|
(if (= index (length))
|
|
array
|
|
(begin
|
|
(send array set index (char->integer (string-ref text index)))
|
|
(build-byte-array (add1 index)))))))
|
|
(build-byte-array 0)))
|
|
(define/public (getBytes-java.lang.String charset)
|
|
(getBytes))
|
|
|
|
(define/public (getBytes-int-int-byte1-int begin end dest i)
|
|
(letrec ((build-byte-array
|
|
(lambda (offset index)
|
|
(if (= offset end)
|
|
(void)
|
|
(begin
|
|
(send dest set index (char->integer (string-ref text offset)))
|
|
(build-byte-array (add1 offset) (add1 index)))))))
|
|
(build-byte-array begin i)))
|
|
|
|
(define/public (contentEquals-java.lang.StringBuffer buf)
|
|
(equals-java.lang.Object (send buf toString)))
|
|
(define/public (content-equals b) (contentEquals-java.lang.StringBuffer b))
|
|
|
|
;Object -> boolean
|
|
(define/override (equals-java.lang.Object obj)
|
|
(and (is-a? obj String)
|
|
(equal? text (send (send obj toString) get-mzscheme-string))))
|
|
|
|
;Object -> boolean
|
|
(define/public (equalsIgnoreCase-java.lang.String str)
|
|
(string-ci=? text (send str get-mzscheme-string)))
|
|
(define/public (equals-ignore-case s) (equalsIgnoreCase-java.lang.String s))
|
|
|
|
;find-diff-chars: int int string-> (values int int)
|
|
(define/private (find-diff-chars i stop-length compare-string)
|
|
(if (>= i stop-length)
|
|
(values #f #f)
|
|
(if (not (equal? (string-ref text i) (string-ref compare-string i)))
|
|
(values (char->integer (string-ref text i)) (char->integer (string-ref compare-string i)))
|
|
(find-diff-chars (add1 i) stop-length compare-string))))
|
|
|
|
;min: int int -> int
|
|
(define/private (min x y)
|
|
(cond
|
|
((= x y) x)
|
|
((< x y) x)
|
|
(else y)))
|
|
|
|
;String -> int
|
|
(define/public (compareTo-java.lang.String str)
|
|
(let* ((string (send str get-mzscheme-string))
|
|
(text-l (string-length text))
|
|
(str-l (string-length string)))
|
|
(cond
|
|
((equals-java.lang.Object str) 0)
|
|
(else
|
|
(let-values (((int-text int-str) (find-diff-chars 0 (min text-l str-l) string)))
|
|
(if int-text
|
|
(- int-text int-str)
|
|
(- text-l str-l)))))))
|
|
|
|
;Object -> int: Throws ClassCastException
|
|
(define/public (compareTo-java.lang.Object obj)
|
|
(if (is-a? obj String)
|
|
(compareTo-java.lang.String obj)
|
|
(raise (create-java-exception ClassCastException
|
|
(format "ClassCastException: Expected argument of class String given ~a"
|
|
(send (send obj toString) get-mzscheme-string))
|
|
(lambda (obj msg) (send obj ClassCastException-constructor-String msg))
|
|
(current-continuation-marks)))))
|
|
|
|
;String -> int
|
|
(define/public (compareToIgnoreCase-java.lang.String str)
|
|
(letrec ((string (send str get-mzscheme-string))
|
|
(find-diff-chars
|
|
(lambda (i)
|
|
(if (>= i (length text))
|
|
(error 'comparetostring "Opps, internal error")
|
|
(if (not (char-ci=? (string-ref text i) (string-ref string i)))
|
|
(values (char->integer (string-ref text i)) (char->integer (string-ref string i)))
|
|
(find-diff-chars (add1 i))))))
|
|
(text-l (string-length text))
|
|
(str-l (string-length string)))
|
|
(cond
|
|
((equalsIgnoreCase-java.lang.String str) 0)
|
|
((string-ci<? text string)
|
|
(if (= text-l str-l)
|
|
(let-values (((int-text int-str) (find-diff-chars 0)))
|
|
(- int-text int-str))
|
|
(- text-l str-l)))
|
|
((string-ci>? text string)
|
|
(if (= text-l str-l)
|
|
(let-values (((int-text int-str) (find-diff-chars 0)))
|
|
(- int-text int-str))
|
|
(- text-l str-l))))))
|
|
(define/public (compare->ignore-case s) (compareToIgnoreCase-java.lang.String s))
|
|
|
|
;int String int int -> boolean
|
|
(define/public (regionMatches-int-java.lang.String-int-int toffset jstr ooffset len)
|
|
(let ((str (send jstr get-mzscheme-string)))
|
|
(and (not (negative? toffset))
|
|
(not (negative? ooffset))
|
|
(<= (+ toffset len) (string-length text))
|
|
(<= (+ ooffset len) (string-length str))
|
|
(string=? (substring text toffset (+ toffset len))
|
|
(substring str ooffset (+ ooffset len))))))
|
|
|
|
;.... -> boolean
|
|
(define/public (regionMatches-boolean-int-java.lang.String-int-int case? toffset jstr ooffset len)
|
|
(let ((str (send jstr get-mzscheme-string)))
|
|
(and (not (negative? toffset))
|
|
(not (negative? ooffset))
|
|
(<= (+ toffset len) (string-length text))
|
|
(<= (+ ooffset len) (string-length str))
|
|
((if case? string=? string-ci=?) (substring text toffset (+ toffset len))
|
|
(substring str ooffset (+ ooffset len))))))
|
|
|
|
; .... -> boolean
|
|
(define/public (startsWith-java.lang.String-int Jprefix offset)
|
|
(let ((prefix (send Jprefix get-mzscheme-string)))
|
|
(and (not (negative? offset))
|
|
(<= (+ offset (string-length prefix)) (string-length text))
|
|
(string=? prefix (substring text offset (+ offset (string-length prefix)))))))
|
|
|
|
;..... -> boolean
|
|
(define/public (startsWith-java.lang.String Jprefix)
|
|
(let ((prefix (send Jprefix get-mzscheme-string)))
|
|
(and (<= (string-length prefix) (string-length text))
|
|
(string=? prefix (substring text 0 (string-length prefix))))))
|
|
|
|
(define/public (endsWith-java.lang.String Jsuffix)
|
|
(let ((suffix (send Jsuffix get-mzscheme-string)))
|
|
(and (<= (string-length suffix) (string-length text))
|
|
(string=? suffix (substring text (- (string-length text) (string-length suffix)) (string-length text))))))
|
|
(define/public (ends-with s) (endsWith-java.lang.String s))
|
|
|
|
; -> int
|
|
(define/override (hashCode)
|
|
(let ((hash 0))
|
|
(let loop ([index 0])
|
|
(unless (>= index (string-length text))
|
|
(set! hash (+ hash (* (char->integer (string-ref text index))
|
|
(expt 31 (- (string-length text) (add1 index))))))
|
|
(loop (add1 index))))
|
|
hash))
|
|
|
|
; character int -> int
|
|
(define/private (find-char ch pos)
|
|
(if (>= pos (string-length text))
|
|
-1
|
|
(if (char=? ch (string-ref text pos))
|
|
pos
|
|
(find-char ch (add1 pos)))))
|
|
|
|
;character int int -> int
|
|
(define/private (find-last-char ch pos lpos)
|
|
(if (>= pos (string-length text))
|
|
lpos
|
|
(if (char=? ch (string-ref text pos))
|
|
(find-last-char ch (add1 pos) pos)
|
|
(find-last-char ch (add1 pos) lpos))))
|
|
|
|
; string int -> int
|
|
(define/private (find-str sch-str str pos)
|
|
(if (> (+ pos (string-length sch-str)) (string-length text))
|
|
-1
|
|
(if (startsWith-java.lang.String-int str pos)
|
|
pos
|
|
(find-str sch-str str (add1 pos)))))
|
|
|
|
; string int int -> int
|
|
(define/private (find-last-string sch-str str pos lpos)
|
|
(if (> (+ pos (string-length sch-str)) (string-length text))
|
|
lpos
|
|
(if (startsWith-java.lang.String-int str pos)
|
|
(find-last-string sch-str str (add1 pos) pos)
|
|
(find-last-string sch-str str (add1 pos) lpos))))
|
|
|
|
(define/public (indexOf-int ch) (find-char (if (number? ch) (integer->char ch) ch) 0))
|
|
(define/public (indexOf-int-int ch offset) (find-char (if (number? ch) (integer->char ch) ch) offset))
|
|
(define/public (indexOf-java.lang.String str) (find-str (send str get-mzscheme-string) str 0))
|
|
(define/public (indexOf-java.lang.String-int str offset) (find-str (send str get-mzscheme-string) str offset))
|
|
|
|
(define/public (lastIndexOf-int ch)
|
|
(find-last-char (if (number? ch) (integer->char ch) ch) 0 -1))
|
|
(define/public (lastIndexOf-int-int ch offset)
|
|
(find-last-char (if (number? ch) (integer->char ch) ch) offset -1))
|
|
(define/public (lastIndexOf-java.lang.String str) (find-last-string (send str get-mzscheme-string) str 0 -1))
|
|
(define/public (lastIndexOf-java.lang.String-int str offset) (find-last-string (send str get-mzscheme-string) str offset -1))
|
|
|
|
;int -> String
|
|
(define/public (substring-int index)
|
|
(substring-int-int index (sub1 (string-length text))))
|
|
|
|
;... -> String
|
|
(define/public (substring-int-int begin end)
|
|
(when (< begin 0)
|
|
(raise (make-runtime-error
|
|
(format "First argument to substring must be greater than 0, given ~a." begin))))
|
|
(when (>= begin (string-length text))
|
|
(raise (make-runtime-error
|
|
(format "First argument to substring must be smaller than the string's length ~a, given ~a." (string-length text) begin))))
|
|
(when (> end (string-length text))
|
|
(raise (make-runtime-error
|
|
(format "Second argument to substring must be smaller than the string's length ~a, given ~a." (string-length text) end))))
|
|
(when (< end 0)
|
|
(raise (make-runtime-error
|
|
(format "Second argument to substring must be greater than 0, given ~a." end))))
|
|
(when (> begin end)
|
|
(raise (make-runtime-error
|
|
(format "First argument to substring must be less than the second, given ~a and ~a." begin end))))
|
|
(make-java-string (substring text begin end)))
|
|
|
|
(define/public (subSequence-int-int begin end)
|
|
(error 'subSequence "Internal Error: subsequence is unimplemented because charSequence is unimplemented"))
|
|
(define/public (sub-sequence i j) (subSequence-int-int i j))
|
|
|
|
;String -> String
|
|
(define/public (concat-java.lang.String Jstr)
|
|
(let ((str (send Jstr get-mzscheme-string)))
|
|
(make-java-string (string-append text str))))
|
|
(define/public (concat s) (concat-java.lang.String s))
|
|
|
|
; .. -> String
|
|
(define/public (replace-char-char old new)
|
|
(let ((new-text (apply string-append (map string (string->list text)))))
|
|
(let loop ([index 0])
|
|
(let ((pos (find-char old index)))
|
|
(unless (= -1 pos)
|
|
(string-set! new-text pos new)
|
|
(loop (add1 index)))))
|
|
(make-java-string new-text)))
|
|
(define/public (replace c1 c2) (replace-char-char c1 c2))
|
|
|
|
;Does not currently work. Needs to replace regex in text with replace and return new string; PROBLEM
|
|
(define/public (replaceAll-java.lang.String-java.lang.String regex replace)
|
|
(error 'replaceAll "Internal error: replaceAll is unimplemented at this time"))
|
|
(define/public (replace-all s s2) (replaceAll-java.lang.String-java.lang.String s s2))
|
|
|
|
(define/public (replaceFirst-java.lang.String-java.lang.String regex replace)
|
|
(error 'replaceFirst "Internal error: replaceFirst is unimplemented at this time"))
|
|
(define/public (replace-first s s2) (replaceFirst-java.lang.String-java.lang.String s s2))
|
|
|
|
(define/public (matches-java.lang.String regex)
|
|
(error 'matches "Internal error: matches is unimplemented at this time"))
|
|
(define/public (matches s) (matches-java.lang.String s))
|
|
|
|
(define/public (split-java.lang.String-int regex limit)
|
|
(error 'split "Internal error: split is unimplemented at this time"))
|
|
|
|
(define/public (split-java.lang.String regex)
|
|
(error 'split "Internal error: split is unimplemented at this time"))
|
|
|
|
; -> String
|
|
(define/public (toLowerCase)
|
|
(make-java-string (apply string-append (map string (map char-downcase (string->list text))))))
|
|
|
|
;Does not take Locale into account
|
|
(define/public (toLowerCase-java.util.Locale locale)
|
|
(toLowerCase))
|
|
|
|
(define/public (toUpperCase)
|
|
(make-java-string (apply string-append (map string (map char-upcase (string->list text))))))
|
|
|
|
;Does not take Locale into account: Problem
|
|
(define/public (toUpperCase-java.util.Locale locale)
|
|
(toUpperCase))
|
|
|
|
;... -> String
|
|
(define/public (trim)
|
|
(error 'trim "Internal error: trim is unimplemented at this time."))
|
|
|
|
(define/public (toCharArray) (make-java-array 'char 0 (string->list text)))
|
|
(define/public (to-char-array) (toCharArray))
|
|
|
|
;PROBLEM I am not sure what the side effects of this should be in context! PROBLEM!
|
|
(define/public intern
|
|
(lambda () this))
|
|
|
|
(define/override (my-name) "String")
|
|
(super-instantiate ())))
|
|
|
|
;valueOf -> String
|
|
(define (String-valueOf-java.lang.Object obj)
|
|
(if (null? obj)
|
|
(make-java-string "null")
|
|
(send obj |toString|)))
|
|
(define (String-valueOf-char1 data)
|
|
(make-java-string (list->string (array->list data 0 (send data length)))))
|
|
|
|
;Should throw exceptions
|
|
(define (String-valueOf-char1-int-int data offset len)
|
|
(make-java-string (list->string (array->list data offset len))))
|
|
|
|
(define (String-valueOf-boolean b) (make-java-string (if b "true" "false")))
|
|
(define (String-valueOf-char c) (make-java-string (string c)))
|
|
(define (String-valueOf-int i) (make-java-string (number->string i)))
|
|
(define (String-valueOf-long l) (make-java-string (number->string l)))
|
|
(define (String-valueOf-float f) (make-java-string (number->string f)))
|
|
(define (String-valueOf-double d) (make-java-string (number->string d)))
|
|
|
|
;copyValueOf -> String
|
|
(define (String-copyValueOf-char1-int-int data offset count)
|
|
(String-valueOf-char1-int-int data offset count))
|
|
(define (String-copyValueOf-char1 data) (String-valueOf-char1 data))
|
|
|
|
;Comparator
|
|
(define String-CASE_INSENSITIVE_ORDER null)
|
|
|
|
|
|
;
|
|
; ;; ;; ;;;
|
|
; ;;;;;;; ; ; ;
|
|
; ; ; ; ; ; ;
|
|
; ; ; ; ; ;; ; ;;; ;;; ;;; ;;; ;;;; ;;;; ; ;;;
|
|
; ; ;; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;;;; ; ; ; ;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;;;; ;;; ;;; ;;;; ;;; ; ; ;;; ;; ;;; ;;;;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
;Throwable and exceptions
|
|
|
|
(provide Throwable (struct-out java:exception)
|
|
exception-is-a? handle-exception create-java-exception)
|
|
|
|
(define Throwable
|
|
(class* Object (Serializable)
|
|
|
|
(inspect #f)
|
|
;private fields
|
|
;message: String
|
|
(define message (make-java-string ""))
|
|
;stack: continuation-mark-set
|
|
(define stack null)
|
|
;java:exception
|
|
(define exception null)
|
|
;cause: Throwable
|
|
(define cause null)
|
|
|
|
;Constructors, set the stack and message
|
|
(define/public (Throwable-constructor)
|
|
(set! stack (current-continuation-marks))
|
|
(send this Object-constructor))
|
|
|
|
(define/public (Throwable-constructor-java.lang.String msg)
|
|
(set! message msg)
|
|
(set! stack (current-continuation-marks))
|
|
(send this Object-constructor))
|
|
|
|
(define/public (Throwable-constructor-java.lang.String-java.lang.Throwable msg cse)
|
|
(set! message msg)
|
|
(set! cause cse)
|
|
(set! stack (current-continuation-marks))
|
|
(send this Object-constructor))
|
|
|
|
(define/public (Throwable-constructor-java.lang.Throwable cse)
|
|
(set! message (if (null? cse) null (send cse toString)))
|
|
(set! cause cse)
|
|
(set! stack (current-continuation-marks))
|
|
(send this Object-constructor))
|
|
|
|
(public-final set-exception! get-mzscheme-exception)
|
|
;Used to interoperate with mzscheme exceptions: set and get the current exception
|
|
(define (set-exception! exn)
|
|
(set! exception exn)
|
|
(set! stack (exn-continuation-marks exn)))
|
|
(define (get-mzscheme-exception) exception)
|
|
|
|
;Needs to throw exceptions. Needs to be callable only once per object
|
|
(define/public (initCause-java.lang.Throwable cse)
|
|
(set! cause cse)
|
|
this)
|
|
|
|
; -> String
|
|
(define/public (getMessage) message)
|
|
(define/public (getCause) cause)
|
|
(define/public (getLocalizedMessage) (send this getMessage))
|
|
(define/public (get-message) (send this getMessage))
|
|
(define/public (get-cause) (send this getCause))
|
|
(define/public (get-localized-message) (send this getLocalizedMessage))
|
|
|
|
(define/public (setStackTrace-java.lang.StackTraceElement1 elments)
|
|
(error 'setStackTrace "Internal error: setStackTrace will not be implemented until strack trace element s implemented"))
|
|
(define/public (getStackTrace)
|
|
(error 'getStackTrace "Internal error: getStackTrace will not be implemented until StackTraceElement is implemented"))
|
|
(define/public (set-stack-trace e) (send this setStackTrace-java.lang.StackTraceElement1 e))
|
|
(define/public (get-stack-trace) (send this getStackTrace))
|
|
|
|
; -> string
|
|
(define/override (toString)
|
|
(if (null? message)
|
|
(make-java-string (send this my-name))
|
|
(make-java-string (format "~a: ~a"
|
|
(send this my-name)
|
|
(send (send this getMessage) get-mzscheme-string)))))
|
|
|
|
; -> void
|
|
(define/public (printStackTrace)
|
|
(print-error-trace (current-output-port) (make-exn message stack)))
|
|
|
|
;These functions do not work correctly yet, and won't until printStreams are implemented
|
|
(define/public printStackTrace-PrintStream (lambda (printStream) void))
|
|
(define/public printStackTrace-PrintWriter (lambda (pW) void))
|
|
|
|
;This function does nothing at this time
|
|
(define/public (fillInStackTrace) this)
|
|
(define/public (fill-in-stack-trace) (send this fillInStackTrace))
|
|
|
|
; -> string
|
|
(define/override (my-name) "Throwable")
|
|
|
|
(define/override (field-names)
|
|
(cond
|
|
[(and (null? cause)
|
|
(equal? "" (send message get-mzscheme-string))) null]
|
|
[(null? cause) (list "message")]
|
|
[(equal? "" (send message get-mzscheme-string)) (list "cause")]
|
|
[else (list "message" "cause")]))
|
|
(define/override (field-values)
|
|
(cond
|
|
[(and (null? cause)
|
|
(equal? "" (send message get-mzscheme-string))) null]
|
|
[(null? cause) (list message)]
|
|
[(equal? "" (send message get-mzscheme-string)) (list cause)]
|
|
[else (list message cause)]))
|
|
|
|
(super-instantiate ())))
|
|
|
|
;(make-java-exception string continuation-mark-set Throwable)
|
|
;Where Throwable is an object descending from class Throwable
|
|
(define-struct (java:exception exn) (object) #:mutable)
|
|
|
|
;exception-is-a?: class -> (exn -> bool)
|
|
(define (exception-is-a? class)
|
|
(lambda (exn)
|
|
(is-a? (java:exception-object exn) class)))
|
|
|
|
(define (handle-exception actions)
|
|
(lambda (exn)
|
|
(actions (java:exception-object exn))))
|
|
|
|
;PROBLEM: create java exception misused by String implementation
|
|
(define (create-java-exception class msg constructor marks)
|
|
(let* ((exn (make-object class))
|
|
(str (make-java-string msg))
|
|
(scheme-exn (make-java:exception msg marks exn)))
|
|
(constructor exn str)
|
|
(send exn set-exception! scheme-exn)
|
|
scheme-exn))
|
|
|
|
(define (make-runtime-error t)
|
|
(create-java-exception
|
|
RuntimeException t
|
|
(lambda (exn str)
|
|
(send exn RuntimeException-constructor-java.lang.String
|
|
(make-java-string str)))
|
|
(current-continuation-marks)))
|
|
|
|
(provide convert-assert-Throwable wrap-convert-assert-Throwable dynamic-Throwable/c
|
|
guard-convert-Throwable static-Throwable/c)
|
|
|
|
(define (wrap-convert-assert-Throwable obj p n s c)
|
|
(c:contract (object-contract
|
|
(init-cause (c:-> c:any/c c:any/c))
|
|
(get-message (c:-> c:any/c))
|
|
(get-cause (c:-> c:any/c))
|
|
(get-localized-message (c:-> c:any/c))
|
|
(setStackTrace-java.lang.StackTraceElement1 (c:-> c:any/c c:any/c))
|
|
(get-stack-trace (c:-> c:any/c))
|
|
(printStackTrace (c:-> c:any/c))
|
|
(printStackTrace-PrintStream (c:-> c:any/c c:any/c))
|
|
(printStackTrace-PrintWriter (c:-> c:any/c c:any/c))
|
|
(fill-in-stack-trace (c:-> c:any/c))
|
|
(clone (c:-> c:any/c))
|
|
(equals-java.lang.Object (c:-> c:any/c c:any/c))
|
|
(finalize (c:-> c:any/c))
|
|
(get-class (c:-> c:any/c))
|
|
(hash-code (c:-> c:any/c))
|
|
(notify (c:-> c:any/c))
|
|
(notify-all (c:-> c:any/c))
|
|
(to-string (c:-> c:any/c))
|
|
(wait (c:-> c:any/c))
|
|
(wait-long (c:-> c:any/c c:any/c))
|
|
(wait-long-int (c:-> c:any/c c:any/c c:any/c))) obj p n s)
|
|
(make-object convert-assert-Throwable obj p n s c))
|
|
|
|
(define convert-assert-Throwable
|
|
(class convert-assert-Object
|
|
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))
|
|
|
|
(define wrapped null)
|
|
(set! wrapped w)
|
|
|
|
(define/public (set-exception! exn) (send wrapped set-exception! exn))
|
|
(define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception))
|
|
(define/public (initCause-java.lang.Throwable cse)
|
|
(let ([pb (send this pos-blame*)]
|
|
[nb (send this neg-blame*)]
|
|
[sr (send this src*)]
|
|
[cc (send this cc-marks*)])
|
|
(wrap-convert-assert-Throwable
|
|
(send wrapped initCause-java.lang.Throwable
|
|
(make-object guard-convert-Throwable cse pb nb sr cc))
|
|
pb nb sr cc)))
|
|
(define/public (getMessage)
|
|
(let ([val (send wrapped getMessage)]
|
|
[pb (send this pos-blame*)]
|
|
[nb (send this neg-blame*)]
|
|
[sr (send this src*)]
|
|
[cc (send this cc-marks*)])
|
|
(if (string? val)
|
|
(make-java-string val)
|
|
(raise
|
|
(make-exn:fail
|
|
(format "~a broke ~a contract here; Throwable's getMessage expects string return, given ~a"
|
|
pb nb val)
|
|
cc)))))
|
|
(define/public (getCause)
|
|
(let ([pb (send this pos-blame*)]
|
|
[nb (send this neg-blame*)]
|
|
[sr (send this src*)]
|
|
[cc (send this cc-marks*)])
|
|
(wrap-convert-assert-Throwable (send wrapped getCause) pb nb sr cc)))
|
|
(define/public (getLocalizedMessage)
|
|
(let ([val (send wrapped getLocalizedMessage)]
|
|
[pb (send this pos-blame*)]
|
|
[nb (send this neg-blame*)]
|
|
[sr (send this src*)]
|
|
[cc (send this cc-marks*)])
|
|
(if (string? val)
|
|
(make-java-string val)
|
|
(raise (make-exn:fail
|
|
(format "~a broke ~a contract here; Throwable's getLocalizedMessage expects string return, given ~a"
|
|
pb nb val)
|
|
cc)))))
|
|
(define/public (setStackTrace-java.lang.StackTraceElement1 elements)
|
|
(send wrapped setStackTrace-java.lang.StackTraceElement1 elements))
|
|
(define/public (getStackTrace) (send wrapped getStackTrace))
|
|
(define/public (printStackTrace) (send wrapped printStackTrace))
|
|
(define/public (printStackTrace-PrintStream printStream) (send wrapped printStackTrace-PrintStream))
|
|
(define/public (printStackTrace-PrintWriter pW) (send wrapped printStackTrace-PrintWriter))
|
|
(define/public (fillInStackTrace) (send wrapped fillInStackTrace))
|
|
))
|
|
|
|
(define dynamic-Throwable/c
|
|
(c:flat-named-contract "Throwable" (lambda (v) (is-a? v convert-assert-Throwable))))
|
|
|
|
(define guard-convert-Throwable
|
|
(class guard-convert-Object
|
|
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))
|
|
|
|
(define wrapped null)
|
|
(set! wrapped w)
|
|
|
|
(define/public (set-exception! exn) (send wrapped set-exception! exn))
|
|
(define/public (get-mzscheme-exception) (send wrapped get-mzscheme-exception))
|
|
(define/public (initCause-java.lang.Throwable . cse)
|
|
(let ([pb (send this pos-blame*)]
|
|
[nb (send this neg-blame*)]
|
|
[sr (send this src*)]
|
|
[cc (send this cc-marks*)])
|
|
(unless (= 1 (length cse))
|
|
(raise (make-exn:fail:contract:arity
|
|
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
|
|
pb nb (length cse))
|
|
cc)))
|
|
(make-object guard-convert-Throwable
|
|
(send wrapped initCause-java.lang.Throwable
|
|
(wrap-convert-assert-Throwable (car cse) pb nb sr cc)))))
|
|
(define/public (init-cause . cse)
|
|
(let ([pb (send this pos-blame*)]
|
|
[nb (send this neg-blame*)]
|
|
[sr (send this src*)]
|
|
[cc (send this cc-marks*)])
|
|
(unless (= 1 (length cse))
|
|
(raise (make-exn:fail:contract:arity
|
|
(format "~a broke ~a contract here: Throwable's initCause expects to be called with 1 argument, given ~n"
|
|
pb nb (length cse))
|
|
cc)))
|
|
(make-object guard-convert-Throwable
|
|
(send wrapped initCause-java.lang.Throwable
|
|
(wrap-convert-assert-Throwable (car cse) pb nb sr cc))
|
|
pb nb sr cc)))
|
|
(define/public (getMessage) (send (send wrapped getMessage) get-mzscheme-string))
|
|
(define/public (get-message) (send (send wrapped getMessage) get-mzscheme-string))
|
|
(define/public (getCause)
|
|
(let ([pb (send this pos-blame*)]
|
|
[nb (send this neg-blame*)]
|
|
[sr (send this src*)]
|
|
[cc (send this cc-marks*)])
|
|
(make-object guard-convert-Throwable (send wrapped getCause) pb nb sr cc)))
|
|
(define/public (get-cause)
|
|
(let ([pb (send this pos-blame*)]
|
|
[nb (send this neg-blame*)]
|
|
[sr (send this src*)]
|
|
[cc (send this cc-marks*)])
|
|
(make-object guard-convert-Throwable (send wrapped getCause) pb nb sr cc)))
|
|
(define/public (getLocalizedMessage) (send (send wrapped getLocalizedMessage) get-mzscheme-string))
|
|
(define/public (get-localized-message) (send (send wrapped getLocalizedMessage) get-mzscheme-string))
|
|
(define/public (setStackTrace-java.lang.StackTraceElement1 elements)
|
|
(send wrapped setStackTrace-java.lang.StackTraceElement1 elements))
|
|
(define/public (set-stack-trace t)
|
|
(send wrapped setStackTrace-java.lang.StackTraceElement1 t))
|
|
(define/public (getStackTrace) (send wrapped getStackTrace))
|
|
(define/public (get-stack-trace) (send wrapped getStackTrace))
|
|
(define/public (printStackTrace) (send wrapped printStackTrace))
|
|
(define/public (printStackTrace-PrintStream printStream) (send wrapped printStackTrace-PrintStream printStream))
|
|
(define/public (printStackTrace-PrintWriter pW) (send wrapped printStackTrace-PrintWriter pW))
|
|
(define/public (fillInStackTrace) (send wrapped fillInStackTrace))
|
|
(define/public (fill-in-stack-trace) (send wrapped fillInStackTrace))
|
|
|
|
))
|
|
|
|
(define static-Throwable/c
|
|
(c:flat-named-contract "Throwable" (lambda (v) (is-a? v guard-convert-Throwable))))
|
|
|
|
(provide wrap-convert-assert-Class guard-convert-Class wrap-convert-assert-PrintString wrap-convert-assert-PrintWriter)
|
|
|
|
(define (wrap-convert-assert-Class . args) (void))
|
|
(define guard-convert-Class (class object% (super-new)))
|
|
(define (wrap-convert-assert-PrintString . args) (void))
|
|
(define (wrap-convert-assert-PrintWriter . args) (void))
|
|
|
|
#;(compile-rest-of-lang (list "Object" "Throwable" "String" "Exception" "RuntimeException" "Comparable"))
|
|
|
|
(provide Exception guard-convert-Exception convert-assert-Exception wrap-convert-assert-Exception
|
|
dynamic-Exception/c static-Exception/c)
|
|
(define Exception
|
|
(class* Throwable ()
|
|
(super-instantiate ())
|
|
(define/public (Exception-constructor) (send this Throwable-constructor))
|
|
(define/public (Exception-constructor-java.lang.String s)
|
|
(send this Throwable-constructor-java.lang.String s))
|
|
(define/public (Exception-constructor-java.lang.string-java.lang.Throwable s cause)
|
|
(send this Throwable-constructor-java.lang.String-java.lang.Throwable s cause))
|
|
(define/public (Exception-constructor-java.lang.Throwable cause)
|
|
(send this Throwable-constructor-java.lang.Throwable cause))
|
|
(define/override (my-name) "Exception")))
|
|
(define (wrap-convert-assert-Exception obj p n s c)
|
|
(make-object convert-assert-Exception obj p n s c))
|
|
(define convert-assert-Exception
|
|
(class convert-assert-Throwable
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define guard-convert-Exception
|
|
(class guard-convert-Throwable
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define dynamic-Exception/c
|
|
(c:flat-named-contract "Exception" (lambda (c) (is-a? c convert-assert-Exception))))
|
|
(define static-Exception/c
|
|
(c:flat-named-contract "Exception" (lambda (c) (is-a? c guard-convert-Exception))))
|
|
|
|
(provide RuntimeException guard-convert-RuntimeException convert-assert-RuntimeException wrap-convert-assert-RuntimeException
|
|
dynamic-RuntimeException/c static-RuntimeException/c)
|
|
(define RuntimeException
|
|
(class* Exception ()
|
|
(super-instantiate ())
|
|
(define/public (RuntimeException-constructor) (send this Exception-constructor))
|
|
(define/public (RuntimeException-constructor-java.lang.String s)
|
|
(send this Exception-constructor-java.lang.String s))
|
|
(define/public (RuntimeException-constructor-java.lang.string-java.lang.Throwable s cause)
|
|
(send this Exception-constructor-java.lang.String-java.lang.Throwable s cause))
|
|
(define/public (RuntimeException-constructor-java.lang.Throwable cause)
|
|
(send this Exception-constructor-java.lang.Throwable cause))
|
|
(define/override (my-name) "RuntimeException")))
|
|
(define (wrap-convert-assert-RuntimeException obj p n s c)
|
|
(make-object convert-assert-RuntimeException obj p n s c))
|
|
(define convert-assert-RuntimeException
|
|
(class convert-assert-Exception
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define guard-convert-RuntimeException
|
|
(class guard-convert-Exception
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define dynamic-RuntimeException/c
|
|
(c:flat-named-contract "RuntimeException" (lambda (c) (is-a? c convert-assert-RuntimeException))))
|
|
(define static-RuntimeException/c
|
|
(c:flat-named-contract "RuntimeException" (lambda (c) (is-a? c guard-convert-RuntimeException))))
|
|
|
|
(provide IndexOutOfBoundsException guard-convert-IndexOutOfBoundsException convert-assert-IndexOutOfBoundsException wrap-convert-assert-IndexOutOfBoundsException
|
|
dynamic-IndexOutOfBoundsException/c static-IndexOutOfBoundsException/c)
|
|
(define IndexOutOfBoundsException
|
|
(class* RuntimeException ()
|
|
(super-instantiate ())
|
|
(define/public (IndexOutOfBoundsException-constructor) (send this RuntimeException-constructor))
|
|
(define/public (IndexOutOfBoundsException-constructor-java.lang.String s)
|
|
(send this RuntimeException-constructor-java.lang.String s))
|
|
(define/public (IndexOutOfBoundsException-constructor-java.lang.string-java.lang.Throwable s cause)
|
|
(send this RuntimeException-constructor-java.lang.String-java.lang.Throwable s cause))
|
|
(define/public (IndexOutOfBoundsException-constructor-java.lang.Throwable cause)
|
|
(send this RuntimeException-constructor-java.lang.Throwable cause))
|
|
(define/override (my-name) "IndexOutOfBoundsException")))
|
|
(define (wrap-convert-assert-IndexOutOfBoundsException obj p n s c)
|
|
(make-object convert-assert-IndexOutOfBoundsException obj p n s c))
|
|
(define convert-assert-IndexOutOfBoundsException
|
|
(class convert-assert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define guard-convert-IndexOutOfBoundsException
|
|
(class guard-convert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define dynamic-IndexOutOfBoundsException/c
|
|
(c:flat-named-contract "IndexOutOfBoundsException" (lambda (c) (is-a? c convert-assert-IndexOutOfBoundsException))))
|
|
(define static-IndexOutOfBoundsException/c
|
|
(c:flat-named-contract "IndexOutOfBoundsException" (lambda (c) (is-a? c guard-convert-IndexOutOfBoundsException))))
|
|
|
|
(provide ArrayIndexOutOfBoundsException guard-convert-ArrayIndexOutOfBoundsException convert-assert-ArrayIndexOutOfBoundsException wrap-convert-assert-ArrayIndexOutOfBoundsException
|
|
dynamic-ArrayIndexOutOfBoundsException/c static-ArrayIndexOutOfBoundsException/c)
|
|
(define ArrayIndexOutOfBoundsException
|
|
(class* IndexOutOfBoundsException ()
|
|
(super-instantiate ())
|
|
(define/public (ArrayIndexOutOfBoundsException-constructor) (send this IndexOutOfBoundsException-constructor))
|
|
(define/public (ArrayIndexOutOfBoundsException-constructor-java.lang.String s)
|
|
(send this IndexOutOfBoundsException-constructor-java.lang.String s))
|
|
(define/public (ArrayIndexOutOfBoundsException-constructor-java.lang.string-java.lang.Throwable s cause)
|
|
(send this IndexOutOfBoundsException-constructor-java.lang.String-java.lang.Throwable s cause))
|
|
(define/public (ArrayIndexOutOfBoundsException-constructor-java.lang.Throwable cause)
|
|
(send this IndexOutOfBoundsException-constructor-java.lang.Throwable cause))
|
|
(define/override (my-name) "ArrayIndexOutOfBoundsException")))
|
|
(define (wrap-convert-assert-ArrayIndexOutOfBoundsException obj p n s c)
|
|
(make-object convert-assert-ArrayIndexOutOfBoundsException obj p n s c))
|
|
(define convert-assert-ArrayIndexOutOfBoundsException
|
|
(class convert-assert-IndexOutOfBoundsException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define guard-convert-ArrayIndexOutOfBoundsException
|
|
(class guard-convert-IndexOutOfBoundsException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define dynamic-ArrayIndexOutOfBoundsException/c
|
|
(c:flat-named-contract "ArrayIndexOutOfBoundsException" (lambda (c) (is-a? c convert-assert-ArrayIndexOutOfBoundsException))))
|
|
(define static-ArrayIndexOutOfBoundsException/c
|
|
(c:flat-named-contract "ArrayIndexOutOfBoundsException" (lambda (c) (is-a? c guard-convert-ArrayIndexOutOfBoundsException))))
|
|
|
|
(provide ArrayStoreException guard-convert-ArrayStoreException convert-assert-ArrayStoreException wrap-convert-assert-ArrayStoreException
|
|
dynamic-ArrayStoreException/c static-ArrayStoreException/c)
|
|
(define ArrayStoreException
|
|
(class* RuntimeException ()
|
|
(super-instantiate ())
|
|
(define/public (ArrayStoreException-constructor) (send this RuntimeException-constructor))
|
|
(define/public (ArrayStoreException-constructor-java.lang.String s)
|
|
(send this RuntimeException-constructor-java.lang.String s))
|
|
(define/public (ArrayStoreException-constructor-java.lang.string-java.lang.Throwable s cause)
|
|
(send this RuntimeException-constructor-java.lang.String-java.lang.Throwable s cause))
|
|
(define/public (ArrayStoreException-constructor-java.lang.Throwable cause)
|
|
(send this RuntimeException-constructor-java.lang.Throwable cause))
|
|
(define/override (my-name) "ArrayStoreException")))
|
|
(define (wrap-convert-assert-ArrayStoreException obj p n s c)
|
|
(make-object convert-assert-ArrayStoreException obj p n s c))
|
|
(define convert-assert-ArrayStoreException
|
|
(class convert-assert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define guard-convert-ArrayStoreException
|
|
(class guard-convert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define dynamic-ArrayStoreException/c
|
|
(c:flat-named-contract "ArrayStoreException" (lambda (c) (is-a? c convert-assert-ArrayStoreException))))
|
|
(define static-ArrayStoreException/c
|
|
(c:flat-named-contract "ArrayStoreException" (lambda (c) (is-a? c guard-convert-ArrayStoreException))))
|
|
|
|
(provide NegativeArraySizeException guard-convert-NegativeArraySizeException convert-assert-NegativeArraySizeException wrap-convert-assert-NegativeArraySizeException
|
|
dynamic-NegativeArraySizeException/c static-NegativeArraySizeException/c)
|
|
(define NegativeArraySizeException
|
|
(class* RuntimeException ()
|
|
(super-instantiate ())
|
|
(define/public (NegativeArraySizeException-constructor) (send this RuntimeException-constructor))
|
|
(define/public (NegativeArraySizeException-constructor-java.lang.String s)
|
|
(send this RuntimeException-constructor-java.lang.String s))
|
|
(define/public (NegativeArraySizeException-constructor-java.lang.string-java.lang.Throwable s cause)
|
|
(send this RuntimeException-constructor-java.lang.String-java.lang.Throwable s cause))
|
|
(define/public (NegativeArraySizeException-constructor-java.lang.Throwable cause)
|
|
(send this RuntimeException-constructor-java.lang.Throwable cause))
|
|
(define/override (my-name) "NegativeArraySizeException")))
|
|
(define (wrap-convert-assert-NegativeArraySizeException obj p n s c)
|
|
(make-object convert-assert-NegativeArraySizeException obj p n s c))
|
|
(define convert-assert-NegativeArraySizeException
|
|
(class convert-assert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define guard-convert-NegativeArraySizeException
|
|
(class guard-convert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define dynamic-NegativeArraySizeException/c
|
|
(c:flat-named-contract "NegativeArraySizeException" (lambda (c) (is-a? c convert-assert-NegativeArraySizeException))))
|
|
(define static-NegativeArraySizeException/c
|
|
(c:flat-named-contract "NegativeArraySizeException" (lambda (c) (is-a? c guard-convert-NegativeArraySizeException))))
|
|
|
|
(provide ClassCastException guard-convert-ClassCastException convert-assert-ClassCastException wrap-convert-assert-ClassCastException
|
|
dynamic-ClassCastException/c static-ClassCastException/c)
|
|
(define ClassCastException
|
|
(class* RuntimeException ()
|
|
(super-instantiate ())
|
|
(define/public (ClassCastException-constructor) (send this RuntimeException-constructor))
|
|
(define/public (ClassCastException-constructor-java.lang.String s)
|
|
(send this RuntimeException-constructor-java.lang.String s))
|
|
(define/public (ClassCastException-constructor-java.lang.string-java.lang.Throwable s cause)
|
|
(send this RuntimeException-constructor-java.lang.String-java.lang.Throwable s cause))
|
|
(define/public (ClassCastException-constructor-java.lang.Throwable cause)
|
|
(send this RuntimeException-constructor-java.lang.Throwable cause))
|
|
(define/override (my-name) "ClassCastException")))
|
|
(define (wrap-convert-assert-ClassCastException obj p n s c)
|
|
(make-object convert-assert-ClassCastException obj p n s c))
|
|
(define convert-assert-ClassCastException
|
|
(class convert-assert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define guard-convert-ClassCastException
|
|
(class guard-convert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define dynamic-ClassCastException/c
|
|
(c:flat-named-contract "ClassCastException" (lambda (c) (is-a? c convert-assert-ClassCastException))))
|
|
(define static-ClassCastException/c
|
|
(c:flat-named-contract "ClassCastException" (lambda (c) (is-a? c guard-convert-ClassCastException))))
|
|
|
|
(provide ArithmeticException guard-convert-ArithmeticException convert-assert-ArithmeticException wrap-convert-assert-ArithmeticException
|
|
dynamic-ArithmeticException/c static-ArithmeticException/c)
|
|
(define ArithmeticException
|
|
(class* RuntimeException ()
|
|
(super-instantiate ())
|
|
(define/public (ArithmeticException-constructor) (send this RuntimeException-constructor))
|
|
(define/public (ArithmeticException-constructor-java.lang.String s)
|
|
(send this RuntimeException-constructor-java.lang.String s))
|
|
(define/public (ArithmeticException-constructor-java.lang.string-java.lang.Throwable s cause)
|
|
(send this RuntimeException-constructor-java.lang.String-java.lang.Throwable s cause))
|
|
(define/public (ArithmeticException-constructor-java.lang.Throwable cause)
|
|
(send this RuntimeException-constructor-java.lang.Throwable cause))
|
|
(define/override (my-name) "ArithmeticException")))
|
|
(define (wrap-convert-assert-ArithmeticException obj p n s c)
|
|
(make-object convert-assert-ArithmeticException obj p n s c))
|
|
(define convert-assert-ArithmeticException
|
|
(class convert-assert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define guard-convert-ArithmeticException
|
|
(class guard-convert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define dynamic-ArithmeticException/c
|
|
(c:flat-named-contract "ArithmeticException" (lambda (c) (is-a? c convert-assert-ArithmeticException))))
|
|
(define static-ArithmeticException/c
|
|
(c:flat-named-contract "ArithmeticException" (lambda (c) (is-a? c guard-convert-ArithmeticException))))
|
|
|
|
(provide NullPointerException guard-convert-NullPointerException convert-assert-NullPointerException wrap-convert-assert-NullPointerException
|
|
dynamic-NullPointerException/c static-NullPointerException/c)
|
|
(define NullPointerException
|
|
(class* RuntimeException ()
|
|
(super-instantiate ())
|
|
(define/public (NullPointerException-constructor) (send this RuntimeException-constructor))
|
|
(define/public (NullPointerException-constructor-java.lang.String s)
|
|
(send this RuntimeException-constructor-java.lang.String s))
|
|
(define/public (NullPointerException-constructor-java.lang.string-java.lang.Throwable s cause)
|
|
(send this RuntimeException-constructor-java.lang.String-java.lang.Throwable s cause))
|
|
(define/public (NullPointerException-constructor-java.lang.Throwable cause)
|
|
(send this RuntimeException-constructor-java.lang.Throwable cause))
|
|
(define/override (my-name) "NullPointerException")))
|
|
(define (wrap-convert-assert-NullPointerException obj p n s c)
|
|
(make-object convert-assert-NullPointerException obj p n s c))
|
|
(define convert-assert-NullPointerException
|
|
(class convert-assert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define guard-convert-NullPointerException
|
|
(class guard-convert-RuntimeException
|
|
(init w p n s c)
|
|
(super-instantiate (w p n s c))))
|
|
(define dynamic-NullPointerException/c
|
|
(c:flat-named-contract "NullPointerException" (lambda (c) (is-a? c convert-assert-NullPointerException))))
|
|
(define static-NullPointerException/c
|
|
(c:flat-named-contract "NullPointerException" (lambda (c) (is-a? c guard-convert-NullPointerException))))
|
|
|
|
|
|
)
|