diff --git a/collects/profj/build-info.ss b/collects/profj/build-info.ss index f81231f5be..bd75109406 100644 --- a/collects/profj/build-info.ss +++ b/collects/profj/build-info.ss @@ -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) diff --git a/collects/profj/check.ss b/collects/profj/check.ss index ee5b1a53c8..75e1e9e09b 100644 --- a/collects/profj/check.ss +++ b/collects/profj/check.ss @@ -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) diff --git a/collects/profj/parameters.ss b/collects/profj/parameters.ss index f21f8ca31e..4376f8e3ef 100644 --- a/collects/profj/parameters.ss +++ b/collects/profj/parameters.ss @@ -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)) diff --git a/collects/profj/parsers/full-parser.ss b/collects/profj/parsers/full-parser.ss index 391048465c..887ab021ed 100644 --- a/collects/profj/parsers/full-parser.ss +++ b/collects/profj/parsers/full-parser.ss @@ -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 diff --git a/collects/profj/parsers/lexer.ss b/collects/profj/parsers/lexer.ss index c89616fd30..e0d26c09e1 100644 --- a/collects/profj/parsers/lexer.ss +++ b/collects/profj/parsers/lexer.ss @@ -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)) diff --git a/collects/profj/to-scheme.ss b/collects/profj/to-scheme.ss index 5f8c9c1f17..18966aa72b 100644 --- a/collects/profj/to-scheme.ss +++ b/collects/profj/to-scheme.ss @@ -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) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 8aa9156e15..59096ff309 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -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