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

Assorted bug fixes, mostly with dynamic

Browse Source 
svn: r1421
This commit is contained in:
Kathy Gray 2005-11-28 05:54:42 +00:00
parent 7491c9f8b0
commit e44c0b9e65
6 changed files with 47 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/profj/check.ss
View File

@ -1692,8 +1692,9 @@
(unless (eq? level 'full)
(when (is-field-restricted? fname field-class)
(restricted-field-access-err (field-access-field acc) field-class src)))
(make-type/env (field-record-type record)
(if (type/env? obj-type/env) (type/env-e obj-type/env) env))))
(make-type/env
(if (eq? 'dynamic (field-record-type record)) (make-dynamic-val #f) (field-record-type record))
(if (type/env? obj-type/env) (type/env-e obj-type/env) env))))
((and (dynamic-val? record) (dynamic-val-type record))
(set-field-access-access! acc (make-var-access #f #t #t 'public 'unknown))
(make-type/env (field-contract-type (unknown-ref-access (dynamic-val-type record)))
@ -2026,11 +2027,11 @@
type-recs)))
(else (prim-call-error call-exp name src level)))))
(else
(if (eq? level 'beginner)
(if (and (eq? level 'beginner) (not interact?))
(beginner-method-access-error name (id-src name))
(let ((rec (if static? (send type-recs get-class-record c-class) this)))
(cond
((and (null? rec) (dynamic?) (lookup-var-in-env name-string env)) =>
((and (dynamic?) (lookup-var-in-env name-string env)) =>
(lambda (var-type)
(if (eq? 'dynamic (var-type-type var-type))
(list (make-method-contract (string-append name-string "~f") #f #f #f))
@ -2057,7 +2058,10 @@
(cond
((close-to-keyword? name-string)
(close-to-keyword-error 'method name src))
(interact? (interaction-call-error name src level))
(interact?
(if (or class? field?)
(no-method-error 'interact sub-kind exp-type name src)
(interaction-call-error name src level)))
(else
(no-method-error 'this sub-kind exp-type name src)))))))
@ -2789,11 +2793,11 @@
(let ((line1
(format "Class ~a is inappropriately being used as a method." n))
(line2
"Parenthesis typically follow the class name when creating an instance, perhaps 'new' was forgotten"))
"Parenthesis typically follow the class name when creating an instance, perhaps 'new' was forgotten."))
(format "~a~n~a" line1 line2)))
((field-name)
(format
"Field ~a is being inappropriately used as a method, parentheses are not used in interacting with a field"
"Field ~a is being inappropriately used as a method, parentheses are not used in interacting with a field."
n)))
n src)))
@ -2804,12 +2808,12 @@
(case kind
((method)
(string-append
(format "this method call uses an unfound method ~a, which is similar to a reserved word~n"
(format "This method call uses an unfound method ~a, which is similar to a reserved word~n"
n)
"Perhaps it is miscapitalized or misspelled"))
((field)
(string-append
(format "this unknown variable, ~a, is similar to a reserved word.~n" n)
(format "This unknown variable, ~a, is similar to a reserved word.~n" n)
"Perhaps it is miscaptialzed or misspelled")))
n src)))
@ -2827,7 +2831,7 @@
(define (beginner-method-access-error name src)
(let ((n (id->ext-name name)))
(raise-error n
(format "method ~a from the current class must be called on 'this'" n)
(format "Method ~a from the current class must be called on 'this'" n)
n src)))
@ -2835,7 +2839,7 @@
(define (restricted-method-call name class src)
(let ((n (id->ext-name name)))
(raise-error n
(format "method ~a from ~a may not be called" n (car class))
(format "Method ~a from ~a may not be called." n (car class))
n src)))
;ctor-called-error: type id src -> void
@ -2843,7 +2847,7 @@
(let ((t (if exp (type->ext-name exp) "the current class"))
(n (id->ext-name name)))
(raise-error n
(format "Constructor ~a from ~a cannot be used as a method" n t)
(format "Constructor ~a from ~a cannot be used as a method." n t)
n src)))
;non-static-called-error: id (list string) src bool -> void
@ -2851,24 +2855,24 @@
(let ((n (id->ext-name name)))
(raise-error n
(if (memq level '(advanced full))
(format "Non-static method ~a from ~a cannot be called directly from a static context"
(format "Non-static method ~a from ~a cannot be called directly from a static context."
n (car class))
(format "Method ~a from ~a cannot be called here" n (car class)))
(format "Method ~a from ~a cannot be called here." n (car class)))
n src)))
;interaction-call-error
(define (interaction-call-error name src level)
(let ((n (id->ext-name name)))
(raise-error n
(string-append (format "method ~a cannot be called in the interactions window.~n" n)
(format "Only ~a methods or methods on objects may be called here"
(string-append (format "Method ~a cannot be called in the interactions window.~n" n)
(format "Only ~a methods or methods on objects may be called here."
(if (memq level '(beginner intermediate)) "certain library" "static")))
n src)))
(define (illegal-ctor-call name src level)
(let ((n (string->symbol name)))
(raise-error n (format "calls to ~a may only occur in ~a"
(raise-error n (format "Calls to ~a may only occur in ~a"
n
(if (memq level `(full advanced)) "other constructors" "the super constructor"))
n src)))

3
collects/profj/error-messaging.ss
View File

@ -1,4 +1,3 @@
#cs
(module error-messaging mzscheme
(require "ast.ss")
@ -11,7 +10,7 @@
;make-error: 'a string 'a src -> void
(define (make-error-pass parm)
(lambda (kind message so src)
(raise-syntax-error kind message (make-so so src parm))))
(raise-syntax-error 'Error #;kind message (make-so so src parm))))
;make-so: symbol src (-> location) -> syntax-object
(define (make-so id src parm)

9
collects/profj/libs/java/runtime.scm
View File

@ -4,7 +4,6 @@
;This module provides functions needed at runtime for compiled Java code
#cs
(module runtime mzscheme
(require (lib "class.ss")
@ -15,7 +14,7 @@
(lib "ClassCastException.ss" "profj" "libs" "java" "lang")
(lib "NullPointerException.ss" "profj" "libs" "java" "lang"))
(provide convert-to-string shift not-equal bitwise mod divide-int
(provide convert-to-string shift not-equal bitwise mod divide-dynamic divide-int
divide-float and or cast-primitive cast-reference instanceof-array nullError)
;convert-to-string: (U string int real bool char Object) -> string
@ -58,6 +57,12 @@
(or left right)))
((or) (or left right)))))
;divide-dynamic: number number -> number
(define (divide-dynamic left right)
(if (or (inexact? left) (inexact? right))
(divide-float left right)
(divide-int left right)))
;divide-int: int int -> int
(define (divide-int left right)
(when (zero? right)

4
collects/profj/parsers/beginner-parser.ss
View File

@ -287,8 +287,8 @@
[(O_BRACE Statement C_BRACE) (make-block (list $2) (build-src 3))])
(BlockStatements
[(Statement) (if (list? $1) $1 (list $1))]
[(BlockStatements Statement) (if (list? $2) (append (reverse $2) $1) (cons $2 $1))])
[(Assignment SEMI_COLON) (if (list? $1) $1 (list $1))]
[(BlockStatements Assignment SEMI_COLON) (if (list? $2) (append (reverse $2) $1) (cons $2 $1))])
(BeginnerInteractions
[(Statement) $1]

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

@ -1826,7 +1826,7 @@
((symbol? type)
(case type
((int short long byte) 'integer?)
((double float) '(c:and/c number? inexact?))
((double float) '(c:and/c number? (c:union inexact? integer?)))
((boolean) 'boolean?)
((char) 'char?)
((string String)
@ -2037,6 +2037,10 @@
(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)
@ -2074,13 +2078,15 @@
((- *)
(create-syntax #f `(,op-syntax ,left ,right) source))
((/)
(make-syntax
#f
(cond
((or (is-int? type) (and (dynamic-val? type) (is-int? (dynamic-val-type type))))
`(,(create-syntax #f 'javaRuntime:divide-int key-src) ,left ,right))
(else
`(,(create-syntax #f 'javaRuntime:divide-float key-src) ,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
((<< >> >>>)
@ -2111,7 +2117,7 @@
(if (dynamic-val? type)
(make-syntax #f
(convert-assert-value
(make-syntax #f `(c:contract ,(type->contract (dynamic-val-type type)) ,result
(make-syntax #f `(c:contract ,(type->contract (dynamic-val-type type) #t) ,result
(quote ,(string->symbol (class-name))) '||) source)
type)
source)