Changes to speed up expansion of compiled code
svn: r1144
This commit is contained in:
Kathy Gray
parent
59dcd38b84
commit
990f73e698
|
|
@ -1,4 +1,3 @@
|
|||
#cs
|
||||
(module Object-composite mzscheme
|
||||
|
||||
(require (lib "class.ss")
|
||||
|
|
@ -935,9 +934,11 @@
|
|||
(make-object convert-assert-Throwable obj p n s c))
|
||||
|
||||
(define convert-assert-Throwable
|
||||
(class object%
|
||||
(class convert-assert-Object
|
||||
|
||||
(init w p n s c)
|
||||
(super-instantiate (w p n s c))
|
||||
|
||||
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
|
||||
(set! wrapped w)
|
||||
(set! pos-blame p)
|
||||
|
|
@ -977,55 +978,16 @@
|
|||
(define/public (printStackTrace-PrintStream printStream) (send wrapped printStackTrace-PrintStream))
|
||||
(define/public (printStackTrace-PrintWriter pW) (send wrapped printStackTrace-PrintWriter))
|
||||
(define/public (fillInStackTrace) (send wrapped fillInStackTrace))
|
||||
(define/public (clone) (send wrapped clone))
|
||||
(define/public (equals-java.lang.Object obj)
|
||||
(let ((val (send wrapped equals-java.lang.Object
|
||||
(make-object guard-convert-Object obj pos-blame neg-blame src cc-marks))))
|
||||
(unless (boolean? val)
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here; Throwable's equals expects boolean return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))
|
||||
val))
|
||||
|
||||
(define/public (finalize) (send wrapped finalize))
|
||||
(define/public (getClass) (send wrapped getClass))
|
||||
|
||||
(define/public (hashCode)
|
||||
(let ((val (send wrapped hashCode)))
|
||||
(unless (integer? val)
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here; Throwable's hashCode expects int return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))
|
||||
val))
|
||||
|
||||
(define/public (notify) (send wrapped notify))
|
||||
(define/public (notifyAll) (send wrapped notifyAll))
|
||||
(define/public (toString)
|
||||
(let ((val (send wrapped toString)))
|
||||
(unless (string? val)
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's toString expects String return, given ~a"
|
||||
pos-blame neg-blame val)) cc-marks)))
|
||||
(make-java-string val)))
|
||||
(define/public (wait) (send wrapped wait))
|
||||
(define/public (wait-long l) (send wrapped wait-long l))
|
||||
(define/public (wait-long-int l i) (send wrapped wait-long l i))
|
||||
(define/public (my-name) (send wrapped my-name))
|
||||
(define/public (field-names) (send wrapped field-names))
|
||||
(define/public (field-values) (send wrapped field-values))
|
||||
(define/public (fields-for-display) (send wrapped fields-for-display))
|
||||
(super-instantiate ())))
|
||||
))
|
||||
|
||||
(define dynamic-Throwable/c
|
||||
(c:flat-named-contract "Throwable" (lambda (v) (is-a? v convert-assert-Throwable))))
|
||||
|
||||
(define guard-convert-Throwable
|
||||
(class object%
|
||||
(class guard-convert-Object
|
||||
|
||||
(init w p n s c)
|
||||
(super-instantiate (w p n s c))
|
||||
(define-values (wrapped pos-blame neg-blame src cc-marks) (values null null null null null))
|
||||
(set! wrapped w)
|
||||
(set! pos-blame p)
|
||||
|
|
@ -1071,66 +1033,6 @@
|
|||
(define/public (fillInStackTrace) (send wrapped fillInStackTrace))
|
||||
(define/public (fill-in-stack-trace) (send wrapped fillInStackTrace))
|
||||
|
||||
(define/public (clone) (send wrapped clone))
|
||||
(define/public (equals-java.lang.Object . obj)
|
||||
(unless (= (length obj) 1)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's equals expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length obj))) cc-marks)))
|
||||
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
|
||||
(define/public (equals . obj)
|
||||
(unless (= (length obj) 1)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's equals expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length obj))) cc-marks)))
|
||||
(send wrapped equals-java.lang.Object (wrap-convert-assert-Object (car obj) pos-blame neg-blame src cc-marks)))
|
||||
(define/public (finalize) (send wrapped finalize))
|
||||
(define/public (getClass) (send wrapped getClass))
|
||||
(define/public (get-class) (send wrapped getClass))
|
||||
(define/public (hashCode) (send wrapped hashCode))
|
||||
(define/public (hash-code) (send wrapped hashCode))
|
||||
(define/public (notify) (send wrapped notify))
|
||||
(define/public (notifyAll) (send wrapped notifyAll))
|
||||
(define/public (notify-all) (send wrapped notifyAll))
|
||||
(define/public (my-name) (send wrapped my-name))
|
||||
(define/public (toString)
|
||||
(send (send wrapped toString) get-mzscheme-string))
|
||||
(define/public (to-string) (send (send wrapped toString) get-mzscheme-string))
|
||||
(define/public (wait) (send wrapped wait))
|
||||
(define/public (wait-long . l)
|
||||
(unless (= (length l) 1)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait-long expects to be called with 1 argument, given ~n"
|
||||
pos-blame neg-blame (length l))) cc-marks)))
|
||||
(unless (integer? (car l))
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait that takes a long argument expected long, given ~a"
|
||||
pos-blame neg-blame (car l))) cc-marks)))
|
||||
(send wrapped wait-long (car l)))
|
||||
(define/public (wait-long-int . l)
|
||||
(unless (= (length l) 2)
|
||||
(raise (make-exn:fail:contract:arity
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait-long-int expects to be called with 2 arguments, given ~n"
|
||||
pos-blame neg-blame (length l))) cc-marks)))
|
||||
(unless (integer? (car l))
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait-long-int expected long, given ~a"
|
||||
pos-blame neg-blame (car l))) cc-marks)))
|
||||
(unless (integer? (cadr l))
|
||||
(raise (make-exn:fail
|
||||
(string->immutable-string
|
||||
(format "~a broke ~a contract here: Throwable's wait-long-int expected int, given ~a"
|
||||
pos-blame neg-blame (cadr l))) cc-marks)))
|
||||
(send wrapped wait-long (car l) (cadr l)))
|
||||
(define/public (field-names) (send wrapped field-names))
|
||||
(define/public (field-values) (send wrapped field-values))
|
||||
(define/public (fields-for-display) (send wrapped fields-for-display))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define static-Throwable/c
|
||||
|
|
|
|||
|
|
@ -627,6 +627,7 @@
|
|||
overridden-methods))
|
||||
(dynamic-method-defs (generate-dyn-method-defs names-for-dynamic))
|
||||
(wrapper-classes (append (generate-wrappers (class-name)
|
||||
(parent-name)
|
||||
(filter
|
||||
(lambda (m) (not (or (private? (method-record-modifiers m))
|
||||
(static? (method-record-modifiers m)))))
|
||||
|
|
@ -726,25 +727,28 @@
|
|||
(accesses-protected methods)
|
||||
(accesses-private methods)))
|
||||
|
||||
,@dynamic-method-defs
|
||||
;,@dynamic-method-defs
|
||||
|
||||
(define/override (my-name) ,(class-name))
|
||||
|
||||
(define/override (field-names)
|
||||
(append (super field-names)
|
||||
(list ,@(map (lambda (n) (id-string (field-name n)))
|
||||
(append (accesses-public fields)
|
||||
(accesses-package fields)
|
||||
(accesses-protected fields)
|
||||
(accesses-private fields))))))
|
||||
|
||||
(define/override (field-values)
|
||||
(append (super field-values)
|
||||
(list ,@(map (lambda (n) (build-identifier (build-var-name (id-string (field-name n)))))
|
||||
(append (accesses-public fields)
|
||||
(accesses-package fields)
|
||||
(accesses-protected fields)
|
||||
(accesses-private fields))))))
|
||||
,@(let ((non-static-fields
|
||||
(append (accesses-public fields)
|
||||
(accesses-package fields)
|
||||
(accesses-protected fields)
|
||||
(accesses-private fields))))
|
||||
(if (null? non-static-fields)
|
||||
null
|
||||
`((define/override (field-names)
|
||||
(append (super field-names)
|
||||
(list ,@(map
|
||||
(lambda (n) (id-string (field-name n)))
|
||||
non-static-fields
|
||||
))))
|
||||
(define/override (field-values)
|
||||
(append (super field-values)
|
||||
(list ,@(map
|
||||
(lambda (n) (build-identifier (build-var-name (id-string (field-name n)))))
|
||||
non-static-fields)))))))
|
||||
|
||||
(define field-accessors ,(build-field-table create-get-name 'get fields))
|
||||
(define field-setters ,(build-field-table create-set-name 'set fields))
|
||||
|
|
@ -758,6 +762,8 @@
|
|||
|
||||
))
|
||||
|
||||
,@wrapper-classes
|
||||
|
||||
,@(create-generic-methods (append (accesses-public methods)
|
||||
(accesses-package methods)
|
||||
(accesses-protected methods)
|
||||
|
|
@ -789,7 +795,7 @@
|
|||
(initialize-src i)
|
||||
type-recs))
|
||||
(members-static-init class-members))
|
||||
,@wrapper-classes
|
||||
|
||||
)
|
||||
#f)))
|
||||
|
||||
|
|
@ -817,16 +823,24 @@
|
|||
(lambda (v) (is-a? v ,(build-identifier (string-append "guard-convert-" class-name))))))))
|
||||
|
||||
;generate-wrappers: string (list method-record) (list field) -> (list sexp)
|
||||
(define (generate-wrappers class-name methods fields)
|
||||
(let* ((normal-methods (filter
|
||||
(lambda (m)
|
||||
(not (or (eq? (method-record-rtype m) 'ctor)
|
||||
(method-record-override m)))) methods))
|
||||
(define (generate-wrappers class-name super-name methods fields)
|
||||
(let* ((wrapped-methods
|
||||
(filter
|
||||
(lambda (m)
|
||||
#;(printf "~a (~a : ~a ~a)~n" (method-record-name m) (method-record-class m) class-name
|
||||
(method-record-override m))
|
||||
(and (not (eq? (method-record-rtype m) 'ctor))
|
||||
(equal? (car (method-record-class m)) class-name)
|
||||
(not (method-record-override m))))
|
||||
methods))
|
||||
(add-ca
|
||||
(lambda (name) (build-identifier (string-append "convert-assert-" name))))
|
||||
(add-gc
|
||||
(lambda (name) (build-identifier (string-append "guard-convert-" name))))
|
||||
(class-text
|
||||
(lambda (name from-dynamic? extra-methods)
|
||||
(lambda (name super-name from-dynamic? extra-methods)
|
||||
`(define ,name
|
||||
(class object%
|
||||
(super-new)
|
||||
(class ,super-name
|
||||
(init w p n s c)
|
||||
(define-values (wrapped-obj pos-blame neg-blame src cc-marks) (values null null null null null))
|
||||
(set! wrapped-obj w)
|
||||
|
|
@ -834,26 +848,25 @@
|
|||
(set! neg-blame n)
|
||||
(set! src s)
|
||||
(set! cc-marks c)
|
||||
(super-instantiate (w p n s c))
|
||||
|
||||
,(generate-wrapper-fields fields from-dynamic?)
|
||||
|
||||
,@(generate-wrapper-methods (filter (lambda (m) (not (eq? (method-record-rtype m) 'ctor)))
|
||||
normal-methods) #f from-dynamic?)
|
||||
,@(generate-wrapper-methods
|
||||
(filter (lambda (m) (not (eq? (method-record-rtype m) 'ctor)))
|
||||
wrapped-methods) #f from-dynamic?)
|
||||
,@extra-methods
|
||||
|
||||
(define/public (my-name) (send wrapped-obj my-name))
|
||||
(define/public (field-names) (send wrapped-obj field-names))
|
||||
(define/public (field-values) (send wrapped-obj field-values))
|
||||
(define/public (fields-for-display) (send wrapped-obj fields-for-display))
|
||||
|
||||
))))
|
||||
(dynamic-callables (refine-method-list methods)))
|
||||
(dynamic-callables (refine-method-list wrapped-methods)))
|
||||
(list
|
||||
`(define (,(build-identifier (string-append "wrap-convert-assert-" class-name)) obj p n s c)
|
||||
(c:contract ,(methods->contract normal-methods) obj p n s)
|
||||
(make-object ,(build-identifier (string-append "convert-assert-" class-name)) obj p n s c))
|
||||
(class-text (build-identifier (string-append "convert-assert-" class-name)) #t null)
|
||||
(class-text (build-identifier (string-append "guard-convert-" class-name)) #f
|
||||
(and ,@(map method->check/error
|
||||
(filter (lambda (m) (not (eq? 'ctor (method-record-rtype m)))) methods)))
|
||||
#;(c:contract ,(methods->contract (filter (lambda (m) (not (eq? 'ctor (method-record-rtype m))))
|
||||
methods)) obj p n s)
|
||||
(make-object ,(add-ca class-name) obj p n s c))
|
||||
(class-text (add-ca class-name) (add-ca super-name) #t null)
|
||||
(class-text (add-gc class-name) (add-gc super-name) #f
|
||||
(generate-wrapper-methods dynamic-callables #t #f)))))
|
||||
|
||||
;generate-wrapper-fields: (list field) boolean -> sexp
|
||||
|
|
@ -915,6 +928,18 @@
|
|||
(c:-> ,@(map (lambda (a) 'c:any/c) (method-record-atypes m)) c:any/c)))
|
||||
methods)))
|
||||
|
||||
;method->check/error: method-record -> sexp
|
||||
(define (method->check/error method)
|
||||
(let* ((name (method-record-name method))
|
||||
(m-name (mangle-method-name name (method-record-atypes method)))
|
||||
(num-args (length (method-record-atypes method))))
|
||||
`(or (object-method-arity-includes? obj
|
||||
(quote ,(build-identifier m-name))
|
||||
,num-args)
|
||||
(raise (make-exn:fail
|
||||
(format "~a broke the contract with ~a here, expected an object with a method ~a accepting ~a args"
|
||||
n p ,name ,num-args) s)))))
|
||||
|
||||
;convert-value: sexp type boolean -> sexp
|
||||
(define (convert-value value type from-dynamic?)
|
||||
(cond
|
||||
|
|
@ -978,8 +1003,6 @@
|
|||
(assert-value value 'string from-dynamic? kind name))
|
||||
(else value))))
|
||||
|
||||
|
||||
|
||||
;Removes from the list all methods that are not callable from a dynamic context
|
||||
;refine-method-list: (list method-record) -> (list method-record)
|
||||
(define (refine-method-list methods)
|
||||
|
|
@ -1236,6 +1259,7 @@
|
|||
,@(make-method-names (members-method members) null)))
|
||||
,@(create-static-fields static-field-names (members-field members))
|
||||
,@(append (generate-wrappers (class-name)
|
||||
"Object"
|
||||
(class-record-methods
|
||||
(send type-recs get-class-record (list (class-name))))
|
||||
null)
|
||||
|
|
@ -1432,14 +1456,31 @@
|
|||
null
|
||||
(let* ((field (car fields))
|
||||
(class (build-identifier (class-name)))
|
||||
(ca-class (build-identifier (string-append "convert-assert-" (class-name))))
|
||||
(quote-name (build-identifier (build-var-name (id-string (field-name field)))))
|
||||
(getter (car names))
|
||||
(setter (cadr names))
|
||||
(final (final? (map modifier-kind (field-modifiers field)))))
|
||||
(append (cons (make-syntax #f `(define ,getter
|
||||
(class-field-accessor ,class ,quote-name)) #f)
|
||||
(append (cons (make-syntax #f
|
||||
`(define ,getter
|
||||
(let ((normal-get (class-field-accessor ,class ,quote-name))
|
||||
(dyn-get (class-field-accessor ,ca-class ,quote-name)))
|
||||
(lambda (obj)
|
||||
(if (is-a? obj ,class)
|
||||
(normal-get obj)
|
||||
(dyn-get obj)))))
|
||||
#f)
|
||||
(if (not final)
|
||||
(list (make-syntax #f `(define ,(cadr names)
|
||||
(class-field-mutator ,class ,quote-name)) #f))
|
||||
(list
|
||||
(make-syntax #f
|
||||
`(define ,setter
|
||||
(let ((normal-set (class-field-mutator ,class ,quote-name))
|
||||
(dyn-set (class-field-mutator ,ca-class ,quote-name)))
|
||||
(lambda (obj val)
|
||||
(if (is-a? obj ,class)
|
||||
(normal-set obj val)
|
||||
(dyn-set obj val)))))
|
||||
#f))
|
||||
null))
|
||||
(create-field-accessors (if final (cdr names) (cddr names)) (cdr fields))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -351,17 +351,20 @@
|
|||
(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)])
|
||||
(let ([name (object-name port)]
|
||||
[executed? #f])
|
||||
(lambda ()
|
||||
(if (eof-object? (peek-char-or-special port))
|
||||
(if executed? #;(eof-object? (peek-char-or-special port))
|
||||
eof
|
||||
(syntax-as-top
|
||||
(datum->syntax-object
|
||||
#f
|
||||
#;`(compile-interactions-helper ,(lambda (ast) (compile-interactions-ast ast name level execute-types))
|
||||
,(parse-interactions port name level))
|
||||
`(parse-java-interactions ,(parse-interactions port name level) ,name)
|
||||
#f))))))
|
||||
(begin
|
||||
(set! executed? #t)
|
||||
(syntax-as-top
|
||||
(datum->syntax-object
|
||||
#f
|
||||
#;`(compile-interactions-helper ,(lambda (ast) (compile-interactions-ast ast name level execute-types))
|
||||
,(parse-interactions port name level))
|
||||
`(parse-java-interactions ,(parse-interactions port name level) ,name)
|
||||
#f)))))))
|
||||
|
||||
;process-extras: (list struct) type-record -> (list syntax)
|
||||
(define/private (process-extras extras type-recs)
|
||||
|
|
@ -543,7 +546,8 @@
|
|||
(else (add1 (total-length (cdr lst))))))
|
||||
|
||||
(define/public (render-value/format value settings port width)
|
||||
(render-value value settings port)(newline port))
|
||||
(render-value value settings port)
|
||||
(newline port))
|
||||
|
||||
(define/public (create-executable fn parent . args)
|
||||
(printf "create-exe called~n")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user