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)

13
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)
(cond
((memq (expr-types exp) `(String string))
(add-required c-class "String" `("java" "lang") type-recs)
(set-expr-type exp string-type))
(expr-types exp)) env))
((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))

45
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,8 +1933,7 @@
;raises an error if it has no implementation for an expression type
;translate-expression: Expression -> syntax
(define translate-expression
(lambda (expr)
(define (translate-expression expr)
(cond
((literal? expr) (translate-literal (expr-types expr)
(literal-val expr)
@ -2002,25 +2012,38 @@
(assignment-key-src expr)
(expr-src expr)))
(else
(error 'translate-expression (format "Translate Expression given unrecognized expression ~s" expr))))))
(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)

9
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,6 +880,11 @@
((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))
(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)
@ -912,7 +919,7 @@
(append
(if (> (length fields) 1)
(reverse (cdr (reverse fields))) null) (list ")")))))
(else (list (send value my-name)))))
(else (list (send value my-name)))))))
(else (list value))))