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

Fix to catching exceptions

Browse Source 
svn: r786
This commit is contained in:
Kathy Gray 2005-09-07 18:33:23 +00:00
parent 4b7a8dece0
commit 38f85dce57
3 changed files with 21 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/profj/check.ss
View File

@ -1142,12 +1142,15 @@
(if (null? catches)
new-env
(let* ((catch (car catches))
(type (field-type-spec (catch-cond catch))))
(type (type-spec-to-type (field-type-spec (catch-cond catch)) #f 'full type-recs)))
(unless (and (ref-type? type)
(is-eq-subclass? type throw-type type-recs))
(catch-error type (field-src (catch-cond catch))))
(set-field-type! (catch-cond catch) type)
(add-required '("" "") (ref-type-class/iface type) (ref-type-path type) type-recs)
(loop (cdr catches) (add-exn-to-env type env))))))
(body-res (check-s body new-env)))
(add-required '("" "") "Throwable" '("java" "lang") type-recs)
(for-each (lambda (catch)
(let* ((field (catch-cond catch))
(name (id-string (field-name field)))
@ -1155,10 +1158,10 @@
(if (and in-env? (not (properties-field? (var-type-properties in-env?))))
(illegal-redefinition (field-name field) (field-src field))
(check-s (catch-body catch)
(add-var-to-env name (field-type-spec field) parm env)))))
(add-var-to-env name (field-type field) parm env)))))
catches)
(when finally (check-s finally env))
(make-type/env 'void (unnest-var (type/env-e body-res)))))
(make-type/env 'void (unnest-var env (type/env-e body-res)))))
;INCORRECT!!! This doesn't properly type check and I'm just raising an error for now
;Skipping proper checks of the statements + proper checking that constants aren't repeated

2
collects/profj/libs/java/lang/Throwable.jinfo
View File

@ -14,7 +14,7 @@
("getMessage" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))
("getStackTrace" (public) (1 ("StackTraceElement" "java" "lang")) () () ("Throwable" "java" "lang"))
("printStackTrace" (public) void () () ("Throwable" "java" "lang"))
("printStackTrace" (public) void (("PrintString" "java" "io")) () ("Throwable" "java" "lang"))
("printStackTrace" (public) void (("PrintStream" "java" "io")) () ("Throwable" "java" "lang"))
("printStackTrace" (public) void (("PrintWriter" "java" "io")) () ("Throwable" "java" "lang"))
("setStackTrace" (public) void ((1 ("StackTraceElement" "java" "lang"))) () ("Throwable" "java" "lang"))
;("toString" (public) ("String" "java" "lang") () () ("Throwable" "java" "lang"))

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

@ -542,7 +542,7 @@
((null? reqs) null)
((member (cadr (car reqs))
(list (make-req "Class" '("java" "lang"))
(make-req "PrintString" '("java" "io"))
(make-req "PrintStream" '("java" "io"))
(make-req "PrintWriter" '("java" "io"))))
(translate-require (cdr reqs) type-recs))
(else
@ -932,7 +932,10 @@
(cond
((and (equal? string-type type) from-dynamic?) `(make-java-string ,value))
((equal? string-type type) `(send ,value get-mzscheme-string))
((equal? type (make-ref-type "Class" '("java" "lang"))) value)
((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)))
@ -1714,7 +1717,7 @@
(if isRuntime?
(make-syntax #f `exn? (build-src var-src))
(make-syntax #f
`(javaException:exception-is-a? ,class-name)
`(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))))
@ -2624,7 +2627,14 @@
(build-identifier (var-access-class vaccess))))))
((not obj) (set-h (translate-id (build-var-name field) field-src)))
(else
(let ((setter (create-set-name field (var-access-class vaccess)))
(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)))