Fixed a bug where interfaces were not being properly mirrored for dynamic use,
also adds ability to use graphics in the interactions window for Full Java svn: r506
This commit is contained in:
parent
871efa46cb
commit
38ae4e952b
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue
Block a user