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

Fixed a bug where interfaces were not being properly mirrored for dynamic use,

Browse Source 
also adds ability to use graphics in the interactions window for Full Java

svn: r506
This commit is contained in:
Kathy Gray 2005-07-30 18:31:11 +00:00
parent 871efa46cb
commit 38ae4e952b
7 changed files with 185 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/profj/build-info.ss
View File

@ -330,7 +330,7 @@
(define (find-implicit-import name type-recs level call-src)
(lambda ()
(let ((original-loc (send type-recs get-location))
(dir (find-directory (cdr name) (lambda () (file-error 'dir name call-src level)))))
(dir (find-directory (cdr name) (lambda () (file-error 'dir (cdr name) call-src level)))))
(when (memq level '(beginner intermediate))
(file-error 'file name call-src level))
(import-class (car name) (cdr name) dir original-loc type-recs level call-src #f)

15
collects/profj/check.ss
View File

@ -1319,10 +1319,17 @@
(cond
((literal? exp)
(make-type/env
(if (memq (expr-types exp) `(String string))
(begin (add-required c-class "String" `("java" "lang") type-recs)
(set-expr-type exp string-type))
(expr-types exp)) env))
(cond
((memq (expr-types exp) `(String string))
(add-required c-class "String" `("java" "lang") type-recs)
(set-expr-type exp string-type))
((eq? (expr-types exp) 'image)
(get-record (send type-recs get-class-record '("Image" "draw2") #f
((get-importer type-recs) '("Image" "draw2")
type-recs level (expr-src exp))) type-recs)
(add-required c-class "Image" `("draw2") type-recs)
(set-expr-type exp (make-ref-type "Image" '("draw2"))))
(else (expr-types exp))) env))
((bin-op? exp)
(set-expr-type exp
(check-bin-op (bin-op-op exp) (bin-op-left exp) (bin-op-right exp)

3
collects/profj/parameters.ss
View File

@ -34,6 +34,9 @@
;Stores whether dynamic typing is allowed
(define dynamic? (make-parameter #f))
;Stores whether or not we're in MrEd and therefore images can appear in the text
(define mred? (make-parameter #f))
;Stores whether it is permitted to use Scheme functions and other values
(define scheme-ok? (make-parameter #f))

3
collects/profj/parsers/full-parser.ss
View File

@ -54,7 +54,8 @@
(- (position-offset (cadr $1)) (position-offset $1-start-pos))
(file-path))
(car $1))]
[(NULL_LIT) (make-literal 'null (build-src 1) #f)])
[(NULL_LIT) (make-literal 'null (build-src 1) #f)]
[(IMAGE_SPECIAL) (make-literal 'image (build-src 1) $1)])
;; 19.4
(Type

28
collects/profj/parsers/lexer.ss
View File

@ -5,12 +5,17 @@
;; chapter 3.
;; Lacks all Unicode support
(require (lib "lex.ss" "parser-tools")
(require (lib "class.ss")
(lib "lex.ss" "parser-tools")
(prefix re: (lib "lex-sre.ss" "parser-tools"))
(lib "parameters.ss" "profj"))
(provide (all-defined))
(define (image-snip%)
(if (mred?)
(dynamic-require '(lib "mred.ss" "mred") 'image-snip%)
(class object% (super-instantiate ()))))
(provide (all-defined-except image-snip%))
(define-struct test-case (test))
(define-struct example-box (contents))
(define-struct interact-case (box))
@ -46,7 +51,8 @@
(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT
IDENTIFIER STRING_ERROR NUMBER_ERROR HEX_LIT OCT_LIT HEXL_LIT OCTL_LIT))
(define-tokens special-toks (CLASS_BOX INTERACTIONS_BOX EXAMPLE TEST_SUITE OTHER_SPECIAL))
(define-tokens special-toks (CLASS_BOX INTERACTIONS_BOX EXAMPLE TEST_SUITE
IMAGE_SPECIAL OTHER_SPECIAL))
(define (trim-string s f l)
(substring s f (- (string-length s) l)))
@ -316,15 +322,13 @@
(syntax-case lexeme ()
((parse-example-box examples) (token-EXAMPLE (make-example-box (syntax examples))))
(_
(if (syntax-property lexeme 'test-case-box)
(token-TEST_SUITE (make-test-case lexeme))
(token-OTHER_SPECIAL (list lexeme start-pos end-pos))))))
(cond
((and (syntax? lexeme) (syntax-property lexeme 'test-case-box))
(token-TEST_SUITE (make-test-case lexeme)))
((is-a? lexeme (image-snip%))
(token-IMAGE_SPECIAL lexeme))
((token-OTHER_SPECIAL (list lexeme start-pos end-pos)))))))
#;(begin(printf "lexing a special")
(syntax-case lexeme ()
((test-case equal? exp1 exp2 exp3 exp4)
(token-TEST_SUITE (make-test-case (syntax exp1) (syntax exp2) (syntax exp3) (syntax exp4))))
(_ (token-OTHER_SPECIAL (list lexeme start-pos end-pos)))))
#;(cond
((class-case? lexeme) (token-CLASS_BOX lexeme))
((interact-case? lexeme) (token-INTERACTIONS_BOX lexeme))

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

@ -953,7 +953,7 @@
(case type
((int byte short long) (check 'integer?))
((float double) (check 'real?))
((char) (check 'character?))
((char) (check 'char?))
((string) (check 'string?))
((boolean) (check 'boolean?))
((dynamic) value))))
@ -1207,12 +1207,23 @@
(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)))
(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-method-names (members-method members) null)))
,@(create-static-fields static-field-names (members-field members)))
,@(create-static-fields static-field-names (members-field members))
,@(append (generate-wrappers (class-name)
(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)))))
;-----------------------------------------------------------------------------------------------------------------
@ -1922,105 +1933,117 @@
;raises an error if it has no implementation for an expression type
;translate-expression: Expression -> syntax
(define translate-expression
(lambda (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)
(define (translate-expression expr)
(cond
((literal? expr) (translate-literal (expr-types expr)
(literal-val 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)
((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)))
((cast? expr) (translate-cast (cast-type expr)
(translate-expression (cast-expr expr))
(expr-types 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)))
((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))))))
((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|)))
(let ((make-string `(let ((temp-obj (make-object String)))
(send temp-obj make-mzscheme-string ,value)
temp-obj)))
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
(if (eq? type string-type)
make-string
(error 'translate-literal (format "Translate literal given unknown type: ~s" type)))))
(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)

79
collects/profj/tool.ss
View File

@ -341,6 +341,7 @@
(define/public (front-end/complete-program port settings teachpack-cache)
(set! execute-types (create-type-record))
(mred? #t)
(let ([name (object-name port)])
(lambda ()
(syntax-as-top
@ -349,6 +350,7 @@
eof
(datum->syntax-object #f `(parse-java-full-program ,(parse port name level)) #f)))))))
(define/public (front-end/interaction port settings teachpack-cache)
(mred? #t)
(let ([name (object-name port)])
(lambda ()
(if (eof-object? (peek-char-or-special port))
@ -878,42 +880,47 @@
((is-a? value String) (list (format "~v" (send value get-mzscheme-string))))
((string? value) (list (format "~v" value)))
((or (is-a? value ObjectI) (supports-printable-interface? value))
(case style
((type) (list (send value my-name)))
((field)
(let* ((retrieve-fields (send value fields-for-display))
(st (format "~a(" (send value my-name)))
(new-tabs (+ num-tabs 3))
(fields null))
(let loop ((current (retrieve-fields)))
(let ((next (retrieve-fields)))
(when current
(set! fields
(append fields
(cons
(format "~a~a = "
(if newline? (if (eq? fields null)
(format "~n~a" (get-n-spaces new-tabs))
(get-n-spaces new-tabs)) "")
(car current))
(append
(if (memq (cadr current) already-printed)
(format-java-list (cadr current) full-print? 'type already-printed #f 0)
(format-java-list (cadr current) full-print? style
(cons value already-printed) newline?
(if newline?
(+ new-tabs (string-length (car current)) 3)
num-tabs)))
(list (format "~a~a"
(if next "," "")
(if newline? (format "~n") " ")))))))
(loop next))))
(cons st
(append
(if (> (length fields) 1)
(reverse (cdr (reverse fields))) null) (list ")")))))
(else (list (send value my-name)))))
(else (list value))))
(cond
((equal? "Image" (send value my-name))
;(printf "~a~n" ((send value fields-for-display)))
(list (cadr ((send value fields-for-display)))))
(else
(case style
((type) (list (send value my-name)))
((field)
(let* ((retrieve-fields (send value fields-for-display))
(st (format "~a(" (send value my-name)))
(new-tabs (+ num-tabs 3))
(fields null))
(let loop ((current (retrieve-fields)))
(let ((next (retrieve-fields)))
(when current
(set! fields
(append fields
(cons
(format "~a~a = "
(if newline? (if (eq? fields null)
(format "~n~a" (get-n-spaces new-tabs))
(get-n-spaces new-tabs)) "")
(car current))
(append
(if (memq (cadr current) already-printed)
(format-java-list (cadr current) full-print? 'type already-printed #f 0)
(format-java-list (cadr current) full-print? style
(cons value already-printed) newline?
(if newline?
(+ new-tabs (string-length (car current)) 3)
num-tabs)))
(list (format "~a~a"
(if next "," "")
(if newline? (format "~n") " ")))))))
(loop next))))
(cons st
(append
(if (> (length fields) 1)
(reverse (cdr (reverse fields))) null) (list ")")))))
(else (list (send value my-name)))))))
(else (list value))))
;array->string: java-value int int bool symbol (list value) -> string