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

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)

collects/profj/check.ss

@@ -1319,10 +1319,17 @@
       (cond
         ((literal? exp)
          (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))
+             (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)

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))
   

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

collects/profj/parsers/lexer.ss

@@ -5,12 +5,17 @@
   ;; chapter 3.
   ;; 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"))
            (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)
+         (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
         ((class-case? lexeme) (token-CLASS_BOX lexeme))
         ((interact-case? lexeme) (token-INTERACTIONS_BOX lexeme))

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,8 +1933,7 @@
   ;raises an error if it has no implementation for an expression type
   
   ;translate-expression: Expression -> syntax
-  (define translate-expression
+  (define (translate-expression expr)
-    (lambda (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)
+                        (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))))
   
   ;;make-is-test sym -> (type -> bool)

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,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))))