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) (define (find-implicit-import name type-recs level call-src)
(lambda () (lambda ()
(let ((original-loc (send type-recs get-location)) (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)) (when (memq level '(beginner intermediate))
(file-error 'file name call-src level)) (file-error 'file name call-src level))
(import-class (car name) (cdr name) dir original-loc type-recs level call-src #f) (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 (cond
((literal? exp) ((literal? exp)
(make-type/env (make-type/env
(if (memq (expr-types exp) `(String string)) (cond
(begin (add-required c-class "String" `("java" "lang") type-recs) ((memq (expr-types exp) `(String string))
(set-expr-type exp string-type)) (add-required c-class "String" `("java" "lang") type-recs)
(expr-types exp)) env)) (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) ((bin-op? exp)
(set-expr-type exp (set-expr-type exp
(check-bin-op (bin-op-op exp) (bin-op-left exp) (bin-op-right 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 ;Stores whether dynamic typing is allowed
(define dynamic? (make-parameter #f)) (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 ;Stores whether it is permitted to use Scheme functions and other values
(define scheme-ok? (make-parameter #f)) (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)) (- (position-offset (cadr $1)) (position-offset $1-start-pos))
(file-path)) (file-path))
(car $1))] (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 ;; 19.4
(Type (Type

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

@ -5,12 +5,17 @@
;; chapter 3. ;; chapter 3.
;; Lacks all Unicode support ;; Lacks all Unicode support
(require (lib "class.ss")
(require (lib "lex.ss" "parser-tools") (lib "lex.ss" "parser-tools")
(prefix re: (lib "lex-sre.ss" "parser-tools")) (prefix re: (lib "lex-sre.ss" "parser-tools"))
(lib "parameters.ss" "profj")) (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 test-case (test))
(define-struct example-box (contents)) (define-struct example-box (contents))
(define-struct interact-case (box)) (define-struct interact-case (box))
@ -46,7 +51,8 @@
(STRING_LIT CHAR_LIT INTEGER_LIT LONG_LIT FLOAT_LIT DOUBLE_LIT (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)) 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) (define (trim-string s f l)
(substring s f (- (string-length s) l))) (substring s f (- (string-length s) l)))
@ -316,15 +322,13 @@
(syntax-case lexeme () (syntax-case lexeme ()
((parse-example-box examples) (token-EXAMPLE (make-example-box (syntax examples)))) ((parse-example-box examples) (token-EXAMPLE (make-example-box (syntax examples))))
(_ (_
(if (syntax-property lexeme 'test-case-box) (cond
(token-TEST_SUITE (make-test-case lexeme)) ((and (syntax? lexeme) (syntax-property lexeme 'test-case-box))
(token-OTHER_SPECIAL (list lexeme start-pos end-pos)))))) (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 #;(cond
((class-case? lexeme) (token-CLASS_BOX lexeme)) ((class-case? lexeme) (token-CLASS_BOX lexeme))
((interact-case? lexeme) (token-INTERACTIONS_BOX lexeme)) ((interact-case? lexeme) (token-INTERACTIONS_BOX lexeme))

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

@ -953,7 +953,7 @@
(case type (case type
((int byte short long) (check 'integer?)) ((int byte short long) (check 'integer?))
((float double) (check 'real?)) ((float double) (check 'real?))
((char) (check 'character?)) ((char) (check 'char?))
((string) (check 'string?)) ((string) (check 'string?))
((boolean) (check 'boolean?)) ((boolean) (check 'boolean?))
((dynamic) value)))) ((dynamic) value))))
@ -1207,12 +1207,23 @@
(send type-recs set-location! (loc)) (send type-recs set-location! (loc))
(let* ((static-field-names (map build-identifier (make-static-field-names (members-field members)))) (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 (list `(begin ,provides
(define ,syntax-name (,interface ,(translate-parents (header-extends header)) (define ,syntax-name (,interface ,(translate-parents (header-extends header))
,@(make-method-names (members-method members) null))) ,@(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))))) (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 ;raises an error if it has no implementation for an expression type
;translate-expression: Expression -> syntax ;translate-expression: Expression -> syntax
(define translate-expression (define (translate-expression expr)
(lambda (expr) (cond
(cond ((literal? expr) (translate-literal (expr-types expr)
((literal? expr) (translate-literal (expr-types expr) (literal-val 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)
(expr-src expr))) (expr-src expr)))
((special-name? expr) (translate-special-name (special-name-name expr) ((bin-op? expr) (translate-bin-op (bin-op-op expr)
(expr-src expr))) (translate-expression (bin-op-left expr))
((specified-this? expr) (translate-specified-this (specified-this-var expr) (expr-src expr))) (expr-types (bin-op-left expr))
((call? expr) (translate-call (call-expr expr) (translate-expression (bin-op-right expr))
(call-method-name expr) (expr-types (bin-op-right expr))
(map translate-expression (call-args expr)) (bin-op-key-src expr)
(map expr-types (call-args expr)) (expr-src expr)
(call-method-record expr) (expr-types expr)))
(expr-types expr) ((access? expr) (translate-access (access-name expr)
(expr-src expr))) (expr-types 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))) (expr-src expr)))
((cast? expr) (translate-cast (cast-type expr) ((special-name? expr) (translate-special-name (special-name-name expr)
(translate-expression (cast-expr expr)) (expr-src expr)))
(expr-types 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))) (expr-src expr)))
((instanceof? expr) (translate-instanceof (translate-expression (instanceof-expr expr)) ((cast? expr) (translate-cast (cast-type expr)
(instanceof-type expr) (translate-expression (cast-expr expr))
(expr-src expr))) (expr-types expr)
((assignment? expr) (translate-assignment (assignment-left expr) (expr-src expr)))
(assignment-op expr) ((instanceof? expr) (translate-instanceof (translate-expression (instanceof-expr expr))
(translate-expression (assignment-right expr)) (instanceof-type expr)
(assignment-right expr) (expr-src expr)))
(expr-types expr) ((assignment? expr) (translate-assignment (assignment-left expr)
(assignment-key-src expr) (assignment-op expr)
(expr-src expr))) (translate-expression (assignment-right expr))
(else (assignment-right expr)
(error 'translate-expression (format "Translate Expression given unrecognized expression ~s" 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. ;All of the following functions translate Java Expressions into syntax.
;Straightforward unless otherwise noted ;Straightforward unless otherwise noted
;translate-literal: symbol value src -> syntax ;translate-literal: symbol value src -> syntax
(define (translate-literal type value src) (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) (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 (create-syntax #f
(case type (case type
((char int long float double boolean) value) ((char int long float double boolean) value)
((String string) make-string) ((String string) make-string)
((image) (make-image))
((null) 'null) ((null) 'null)
(else (else
(if (eq? type string-type) (cond
make-string ((eq? type string-type) make-string)
(error 'translate-literal (format "Translate literal given unknown type: ~s" type))))) ((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)))) (build-src src))))
;;make-is-test sym -> (type -> bool) ;;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) (define/public (front-end/complete-program port settings teachpack-cache)
(set! execute-types (create-type-record)) (set! execute-types (create-type-record))
(mred? #t)
(let ([name (object-name port)]) (let ([name (object-name port)])
(lambda () (lambda ()
(syntax-as-top (syntax-as-top
@ -349,6 +350,7 @@
eof eof
(datum->syntax-object #f `(parse-java-full-program ,(parse port name level)) #f))))))) (datum->syntax-object #f `(parse-java-full-program ,(parse port name level)) #f)))))))
(define/public (front-end/interaction port settings teachpack-cache) (define/public (front-end/interaction port settings teachpack-cache)
(mred? #t)
(let ([name (object-name port)]) (let ([name (object-name port)])
(lambda () (lambda ()
(if (eof-object? (peek-char-or-special port)) (if (eof-object? (peek-char-or-special port))
@ -878,42 +880,47 @@
((is-a? value String) (list (format "~v" (send value get-mzscheme-string)))) ((is-a? value String) (list (format "~v" (send value get-mzscheme-string))))
((string? value) (list (format "~v" value))) ((string? value) (list (format "~v" value)))
((or (is-a? value ObjectI) (supports-printable-interface? value)) ((or (is-a? value ObjectI) (supports-printable-interface? value))
(case style (cond
((type) (list (send value my-name))) ((equal? "Image" (send value my-name))
((field) ;(printf "~a~n" ((send value fields-for-display)))
(let* ((retrieve-fields (send value fields-for-display)) (list (cadr ((send value fields-for-display)))))
(st (format "~a(" (send value my-name))) (else
(new-tabs (+ num-tabs 3)) (case style
(fields null)) ((type) (list (send value my-name)))
(let loop ((current (retrieve-fields))) ((field)
(let ((next (retrieve-fields))) (let* ((retrieve-fields (send value fields-for-display))
(when current (st (format "~a(" (send value my-name)))
(set! fields (new-tabs (+ num-tabs 3))
(append fields (fields null))
(cons (let loop ((current (retrieve-fields)))
(format "~a~a = " (let ((next (retrieve-fields)))
(if newline? (if (eq? fields null) (when current
(format "~n~a" (get-n-spaces new-tabs)) (set! fields
(get-n-spaces new-tabs)) "") (append fields
(car current)) (cons
(append (format "~a~a = "
(if (memq (cadr current) already-printed) (if newline? (if (eq? fields null)
(format-java-list (cadr current) full-print? 'type already-printed #f 0) (format "~n~a" (get-n-spaces new-tabs))
(format-java-list (cadr current) full-print? style (get-n-spaces new-tabs)) "")
(cons value already-printed) newline? (car current))
(if newline? (append
(+ new-tabs (string-length (car current)) 3) (if (memq (cadr current) already-printed)
num-tabs))) (format-java-list (cadr current) full-print? 'type already-printed #f 0)
(list (format "~a~a" (format-java-list (cadr current) full-print? style
(if next "," "") (cons value already-printed) newline?
(if newline? (format "~n") " "))))))) (if newline?
(loop next)))) (+ new-tabs (string-length (car current)) 3)
(cons st num-tabs)))
(append (list (format "~a~a"
(if (> (length fields) 1) (if next "," "")
(reverse (cdr (reverse fields))) null) (list ")"))))) (if newline? (format "~n") " ")))))))
(else (list (send value my-name))))) (loop next))))
(else (list value)))) (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 ;array->string: java-value int int bool symbol (list value) -> string