Added tracing capabilities to mzscheme's class system.

- class-internal.ss exports two versions (traced/untraced) of macros/functions
- classidmap.ss provides expansion to both forms (traced/untraced)
- class-traced.ss exports traced versions
- class.ss (unchanged) exports untraced versions
- class-events.ss contains hooks called by traced version
Functionality will be used by tool to be released via PLaneT.

svn: r4778

collects/mzlib/class-traced.ss

@@ -0,0 +1,59 @@
+(module class-traced mzscheme
+  
+  ;; All of the implementation is actually in private/class-internal.ss,
+  ;;  which provides extra (private) functionality to contract.ss.
+  (require "private/class-internal.ss")
+  
+  (provide (rename class-traced class)
+           (rename class*-traced class*)
+           (rename class/derived-traced class/derived)
+	   (rename define-serializable-class-traced define-serializable-class)
+           (rename define-serializable-class*-traced define-serializable-class*)
+           class?
+	   (rename mixin-traced mixin)
+           interface interface?
+	   object% object? externalizable<%>
+           object=?
+	   (rename new-traced new)
+           (rename make-object-traced make-object)
+           (rename instantiate-traced instantiate)
+	   (rename send-traced send)
+           (rename send/apply-traced send/apply)
+           (rename send*-traced send*)
+           (rename class-field-accessor-traced class-field-accessor)
+           (rename class-field-mutator-traced class-field-mutator)
+           (rename with-method-traced with-method)
+           (rename get-field-traced get-field)
+           (rename field-bound?-traced field-bound?)
+           (rename field-names-traced field-names)
+	   private* public*  pubment*
+	   override* overment*
+	   augride* augment*
+	   public-final* override-final* augment-final*
+	   define/private define/public define/pubment
+	   define/override define/overment
+	   define/augride define/augment
+	   define/public-final define/override-final define/augment-final
+	   define-local-member-name define-member-name member-name-key generate-member-key
+	   (rename generic-traced generic)
+           (rename make-generic-traced make-generic)
+           (rename send-generic-traced send-generic)
+	   (rename is-a?-traced is-a?)
+           subclass? implementation? interface-extension?
+	   (rename object-interface-traced object-interface)
+           (rename object-info-traced object-info)
+           (rename object->vector-traced object->vector)
+	   (rename object-method-arity-includes?-traced object-method-arity-includes?)
+	   method-in-interface? interface->method-names class->interface class-info
+	   (struct exn:fail:object ())
+	   make-primitive-class
+
+	   ;; "keywords":
+	   private public override augment
+	   pubment overment augride
+           public-final override-final augment-final
+	   field init init-field
+	   rename-super rename-inner inherit inherit-field
+	   this super inner
+	   super-make-object super-instantiate super-new
+	   inspect))

collects/mzlib/private/class-events.ss

@@ -0,0 +1,111 @@
+
+(module class-events mzscheme
+
+  (require-for-syntax (lib "stxparam.ss"))
+  (require (lib "stxparam.ss"))
+
+  (provide current-class-event-handler
+           define-traced
+           trace-begin
+           trace
+           initialize-call-event
+           finalize-call-event
+           new-event
+           inspect-event
+           set-event
+           get-event
+           )
+
+  (define current-class-event-handler
+    (make-parameter void))
+
+  ;; ----------------------------------------------------------------------
+  ;; Definitions for traced vs untraced functions
+  ;; ----------------------------------------------------------------------
+
+  (define-syntax-parameter trace? #f)
+
+  (define-syntax trace
+    (make-set!-transformer
+     (lambda (stx)
+       (raise-syntax-error
+        #f
+        "trace used outside a trace-begin"
+        stx))))
+
+  (define-syntax (trace-begin stx)
+    (syntax-case stx (trace)
+      [(form (trace expr) ...)
+       (raise-syntax-error
+        #f
+        "traced block has no non-trace code"
+        stx)]
+      [(form expr0 (trace expr) ...)
+       (if (syntax-parameter-value (syntax trace?))
+           (syntax/loc stx (begin0 expr0 expr ...))
+           (syntax expr0))]
+      [(form (trace expr) rest ...)
+       (if (syntax-parameter-value (syntax trace?))
+           (syntax/loc stx (begin expr (form rest ...)))
+           (syntax/loc stx (form rest ...)))]
+      [(form expr rest ...)
+       (syntax/loc stx (begin expr (form rest ...)))]))
+
+  (define-syntax (define-traced stx)
+    (syntax-case stx ()
+      [(form (name . args) . body)
+       (syntax/loc stx (form name (lambda args . body)))]
+      [(form name body ...)
+       (with-syntax ([name-traced
+                      (datum->syntax-object
+                       (syntax name)
+                       (string->symbol
+                        (string-append
+                         (symbol->string (syntax-e (syntax name)))
+                         "-traced"))
+                       (syntax name))])
+         (syntax/loc stx
+           (begin
+             (define name
+               (syntax-parameterize ([trace? #f])
+                 body ...))
+             (define name-traced
+               (syntax-parameterize ([trace? #t])
+                 body ...)))))]))
+
+  (define current-class-event-stack
+    (make-parameter null))
+
+  (define (initialize-event event . args)
+    (current-class-event-stack
+     (cons
+      (apply (current-class-event-handler) event args)
+      (current-class-event-stack))))
+
+  (define (finalize-event event . args)
+    (let* ([stack (current-class-event-stack)]
+           [head (car stack)]
+           [tail (cdr stack)])
+      (when (procedure? head) (apply head args))
+      (current-class-event-stack tail)))
+
+  (define (new-event class obj fields)
+    ((current-class-event-handler) 'new class obj fields))
+
+  (define (initialize-call-event obj method args)
+    (initialize-event 'call obj method args))
+
+  (define (finalize-call-event . returned)
+    (apply finalize-event 'call returned)
+    (apply values returned))
+
+  (define (inspect-event obj)
+    ((current-class-event-handler) 'inspect obj))
+
+  (define (set-event obj field value)
+    ((current-class-event-handler) 'set obj field value))
+
+  (define (get-event obj field)
+    ((current-class-event-handler) 'get obj field))
+
+  )

collects/mzlib/private/class-internal.ss

@@ -3,6 +3,7 @@
   (require (lib "list.ss")
            (lib "etc.ss")
 	   (lib "stxparam.ss")
+           "class-events.ss"
 	   "serialize-structs.ss")
   (require-for-syntax (lib "kerncase.ss" "syntax")
 		      (lib "stx.ss" "syntax")
@@ -117,7 +118,8 @@
   ;;  class macros
   ;;--------------------------------------------------------------------
 
-  (define-syntaxes (class* _class class/derived)
+  (define-syntaxes (class* _class class/derived
+                     class*-traced class-traced class/derived-traced)
     (let ()
       ;; Start with Helper functions
 
@@ -393,7 +395,7 @@
       ;; --------------------------------------------------------------------------------
       ;; Start here:
 
-      (define (main stx super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
+      (define (main stx trace-flag super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs)
 	(let-values ([(this-id) #'this-id]
 		     [(the-obj) (datum->syntax-object (quote-syntax here) (gensym 'self))]
 		     [(the-finder) (datum->syntax-object (quote-syntax here) (gensym 'find-self))])
@@ -1012,7 +1014,8 @@
 				 ;; make-XXX-map is supplied by private/classidmap.ss
 				 (with-syntax ([the-obj the-obj]
 					       [the-finder the-finder]
-					       [this-id this-id])
+					       [this-id this-id]
+                                               [trace-flag (if trace-flag (syntax #t) (syntax #f))])
 				   (syntax 
 				    ([(inherit-field-name ...
 							  local-field ...
@@ -1023,7 +1026,8 @@
 							  public-final-name ...
 							  pubment-name ...)
 				      (values
-				       (make-field-map (quote-syntax the-finder)
+				       (make-field-map trace-flag
+                                                       (quote-syntax the-finder)
 						       (quote the-obj)
 						       (quote-syntax inherit-field-name)
 						       (quote-syntax inherit-field-name-localized)
@@ -1031,7 +1035,8 @@
 						       (quote-syntax inherit-field-mutator)
 						       '())
 				       ...
-				       (make-field-map (quote-syntax the-finder)
+				       (make-field-map trace-flag
+                                                       (quote-syntax the-finder)
 						       (quote the-obj)
 						       (quote-syntax local-field)
 						       (quote-syntax local-field-localized)
@@ -1316,43 +1321,59 @@
 				     ;; Not primitive:
 				     #f))))))))))))))))
 
-      ;; The class* and class entry points:
+      (define (core-class* trace-flag)
-      (values
-       ;; class*
         (lambda (stx)
           (syntax-case stx ()
             [(_  super-expression (interface-expr ...)
                  defn-or-expr
                  ...)
-	    (main stx 
+             (main stx trace-flag
                    #'super-expression 
                    #f #f
                    (syntax->list #'(interface-expr ...))
-		  (syntax->list #'(defn-or-expr ...)))]))
+                   (syntax->list #'(defn-or-expr ...)))])))
-       ;; class
+
+      (define (core-class trace-flag)
         (lambda (stx)
           (syntax-case stx ()
             [(_ super-expression
                 defn-or-expr
                 ...)
-	    (main stx 
+             (main stx trace-flag
                    #'super-expression 
                    #f #f
                    null
-		  (syntax->list #'(defn-or-expr ...)))]))
+                   (syntax->list #'(defn-or-expr ...)))])))
-       ;; class/derived
+
+      (define (core-class/derived trace-flag)
         (lambda (stx)
           (syntax-case stx ()
             [(_  orig-stx
                  [name-id super-expression (interface-expr ...) deserialize-id-expr]
                  defn-or-expr
                  ...)
-	    (main #'orig-stx 
+             (main #'orig-stx trace-flag
                    #'super-expression 
                    #'deserialize-id-expr 
                    (and (syntax-e #'name-id) #'name-id)
                    (syntax->list #'(interface-expr ...))
-		  (syntax->list #'(defn-or-expr ...)))])))))
+                   (syntax->list #'(defn-or-expr ...)))])))
+
+      ;; The class* and class entry points:
+      (values
+       ;; class*
+       (core-class* #f)
+       ;; class
+       (core-class #f)
+       ;; class/derived
+       (core-class/derived #f)
+       ;; class*-traced
+       (core-class* #t)
+       ;; class-traced
+       (core-class #t)
+       ;; class/derived-traced
+       (core-class/derived #t)
+       )))
 
   (define-syntax (-define-serializable-class stx)
     (syntax-case stx ()
@@ -2326,11 +2347,15 @@
   ;;  instantiation
   ;;--------------------------------------------------------------------
   
-  (define-syntax (new stx)
+  (define-syntaxes (new new-traced)
+
+    (let* ([core-new
+            (lambda (instantiate-stx stx)
               (syntax-case stx ()
                 [(_ cls (id arg) ...)
                  (andmap identifier? (syntax->list (syntax (id ...))))
-       (syntax/loc stx (instantiate cls () (id arg) ...))]
+                 (quasisyntax/loc stx
+                   ((unsyntax instantiate-stx) cls () (id arg) ...))]
                 [(_ cls (id arg) ...)
                  (for-each (lambda (id)
                              (unless (identifier? id)
@@ -2342,19 +2367,36 @@
                     (syntax-case pr ()
                       [(x y) (void)]
                       [else (raise-syntax-error 'new "expected name and value binding" stx pr)]))
-        (syntax->list (syntax (pr ...))))]))
+                  (syntax->list (syntax (pr ...))))]))])
+
+      (values
+       (lambda (stx) (core-new (syntax/loc stx instantiate) stx))
+       (lambda (stx) (core-new (syntax/loc stx instantiate-traced) stx)))))
   
   (define make-object 
     (lambda (class . args)
       (do-make-object class args null)))
 
-  (define-syntax instantiate
+  (define make-object-traced
-    (lambda (stx)
+    (lambda (class . args)
+      (do-make-object-traced class args null)))
+  
+  (define-syntaxes (instantiate instantiate-traced)
+
+    (let* ([core-instantiate
+            (lambda (do-make-object-stx stx)
               (syntax-case stx ()
                 [(form class (arg ...) . x)
                  (with-syntax ([orig-stx stx])
-	   (syntax/loc stx 
+                   (quasisyntax/loc stx 
-             (-instantiate do-make-object orig-stx (class) (list arg ...) . x)))])))
+                     (-instantiate (unsyntax do-make-object-stx)
+                                   orig-stx (class) (list arg ...) . x)))]))])
+
+      (values
+       (lambda (stx)
+         (core-instantiate (syntax/loc stx do-make-object) stx))
+       (lambda (stx)
+         (core-instantiate (syntax/loc stx do-make-object-traced) stx)))))
 
   ;; Helper; used by instantiate and super-instantiate
   (define-syntax -instantiate
@@ -2389,13 +2431,26 @@
 			 kwarg)]))
 		   (syntax->list (syntax (kwarg ...))))])))
 
-  (define (do-make-object class by-pos-args named-args)
+  (define (alist->sexp alist)
+    (map (lambda (pair) (list (car pair) (cdr pair))) alist))
+
+  (define-traced (do-make-object class by-pos-args named-args)
     (unless (class? class)
       (raise-type-error 'instantiate "class" class))
     (let ([o ((class-make-object class))])
+      (trace-begin
        ;; Initialize it:
+       (trace (new-event class o (alist->sexp (get-field-alist o))))
+       (trace (initialize-call-event
+               o (string->symbol "(constructor)")
+               (cons (alist->sexp named-args) by-pos-args)))
        (continue-make-object o class by-pos-args named-args #t)
-      o))
+       (trace (finalize-call-event o))
+       o)))
+
+  (define (get-field-alist obj)
+    (map (lambda (id) (cons id (get-field/proc id obj)))
+         (field-names obj)))
 
   (define (continue-make-object o c by-pos-args named-args explict-named-args?)
     (let ([by-pos-only? (not (class-init-args c))])
@@ -2554,58 +2609,80 @@
   ;;  methods and fields
   ;;--------------------------------------------------------------------
   
-  (define-syntaxes (send send/apply)
+  (define-syntaxes (send send/apply send-traced send/apply-traced)
-    (let ([mk
+    (let ()
-	   (lambda (flatten?)
-	     (lambda (stx)
-	       (syntax-case stx ()
-		 [(_ obj name . args)
-		  (begin
-		    (unless (identifier? (syntax name))
-		      (raise-syntax-error
-		       #f
-		       "method name is not an identifier"
-		       stx
-		       (syntax name)))
-		    (with-syntax ([name (localize (syntax name))])
-		      (if flatten?
-			  (if (stx-list? (syntax args))
-			      (syntax (let-values ([(mth unwrapped-this)
-						    (find-method/who 'send obj `name)])
-					(apply mth unwrapped-this . args)))
-			      (raise-syntax-error
-			       #f
-			       "bad syntax (illegal use of `.')"
-			       stx))
-			  (if (stx-list? (syntax args))
-			      (syntax/loc stx
-				(let-values ([(mth unwrapped-this)
-					      (find-method/who 'send obj `name)])
-				    (mth unwrapped-this . args)))
-			      (with-syntax ([args (flatten-args (syntax args))])
-				(syntax/loc stx
-				  (let-values ([(mth unwrapped-this)
-						(find-method/who 'send obj `name)])
-				    (apply mth unwrapped-this . args))))))))])))])
-      (values (mk #f) (mk #t))))
 
-  (define-syntax send*
+      (define (do-method traced? stx form obj name args rest-arg?)
+        (with-syntax ([(sym method receiver)
+                       (generate-temporaries (syntax (1 2 3)))])
+          (quasisyntax/loc stx
+            (let*-values ([(sym) (quasiquote (unsyntax (localize name)))]
+                          [(method receiver)
+                           (find-method/who '(unsyntax form)
+                                            (unsyntax obj)
+                                            sym)])
+              (unsyntax
+               (make-method-call
+                traced?
+                stx
+                (syntax/loc stx receiver)
+                (syntax/loc stx unwrap-object)
+                (syntax/loc stx method)
+                (syntax/loc stx sym)
+                args
+                rest-arg?))))))
+
+      (define (core-send traced? apply?)
         (lambda (stx)
           (syntax-case stx ()
-	[(_ obj s ...)
+            [(form obj name . args)
-	 (with-syntax ([sends (map (lambda (s)
+             (identifier? (syntax name))
-				     (syntax-case s ()
+             (if (stx-list? (syntax args))
+                 ;; (send obj name arg ...) or (send/apply obj name arg ...)
+                 (do-method traced? stx #'form #'obj #'name #'args apply?)
+                 (if apply?
+                     ;; (send/apply obj name arg ... . rest)
+                     (raise-syntax-error
+                      #f "bad syntax (illegal use of `.')" stx)
+                     ;; (send obj name arg ... . rest)
+                     (do-method traced? stx #'form #'obj #'name
+                                (flatten-args #'args) #t)))]
+            [(form obj name . args)
+             (raise-syntax-error
+              #f "method name is not an identifier" stx #'name)])))
+
+      (values
+       ;; send
+       (core-send #f #f)
+       ;; send/apply
+       (core-send #f #t)
+       ;; send-traced
+       (core-send #t #f)
+       ;; send/apply-traced
+       (core-send #t #t))))
+  
+  (define-syntaxes (send* send*-traced)
+    (let* ([core-send*
+            (lambda (traced?)
+              (lambda (stx)
+                (syntax-case stx ()
+                  [(form obj clause ...)
+                   (quasisyntax/loc stx
+                     (let* ([o obj])
+                       (unsyntax-splicing
+                        (map
+                         (lambda (clause-stx)
+                           (syntax-case clause-stx ()
                              [(meth . args)
-					(syntax/loc s (send o meth . args))]
+                              (quasisyntax/loc stx
-				       [_else (raise-syntax-error
+                                ((unsyntax (if traced?
-					       #f
+                                               (syntax/loc stx send-traced)
-					       "bad method call"
+                                               (syntax/loc stx send)))
-					       stx
+                                 o meth . args))]
-					       s)]))
+                             [_ (raise-syntax-error
-				   (syntax->list (syntax (s ...))))])
+                                 #f "bad method call" stx clause-stx)]))
-	   (syntax/loc stx
+                         (syntax->list (syntax (clause ...)))))))])))])
-	     (let ([o obj])
+      (values (core-send* #f) (core-send* #t))))
-	       . sends)))])))
     
   ;; find-method/who : symbol[top-level-form/proc-name]
   ;;                   any[object] 
@@ -2663,7 +2740,7 @@
 		   make-struct-field-mutator class-field-set!
 		   class name))
 
-  (define-struct generic (applicable))
+  (define-struct generic (name applicable))
 
   ;; Internally, make-generic comes from the struct def.
   ;; Externally, make-generic is the following procedure.
@@ -2676,6 +2753,7 @@
 	     (unless (symbol? name)
 	       (raise-type-error 'make-generic "symbol" name))
 	     (make-generic
+              name
 	      (if (interface? class)
 		  (let ([intf class])
 		    (unless (method-in-interface? name intf)
@@ -2713,20 +2791,31 @@
                         dynamic-generic)))))])
       make-generic))
 
-  (define-syntax send-generic
+  (define-syntaxes (send-generic send-generic-traced)
+    (let ()
+      (define (core-send-generic traced?)
         (lambda (stx)
           (syntax-case stx ()
-	[(_ obj generic . args)
+            [(_ object generic . args)
-	 (if (stx-list? (syntax args))
+             (let* ([args-stx (syntax args)]
-	     (with-syntax ([call (syntax/loc stx
+                    [proper? (stx-list? args-stx)]
-				   (((generic-applicable generic) this) this . args))])
+                    [flat-stx (if proper? args-stx (flatten-args args-stx))])
-	       (syntax/loc stx (let ([this obj])
+               (with-syntax ([(gen obj)
-				 call)))
+                              (generate-temporaries (syntax (generic object)))])
-	     (with-syntax ([args (flatten-args (syntax args))])
+                 (quasisyntax/loc stx
-	       (with-syntax ([call (syntax/loc stx
+                   (let* ([obj object]
-				     (apply ((generic-applicable generic) this) this . args))])
+                          [gen generic])
-		 (syntax (let ([this obj])
+                     (unsyntax
-			   call)))))])))
+                      (make-method-call
+                       traced?
+                       stx
+                       (syntax obj)
+                       (syntax/loc stx unwrap-object)
+                       (syntax/loc stx ((generic-applicable gen) obj))
+                       (syntax/loc stx (generic-name gen))
+                       flat-stx
+                       (not proper?)))))))])))
+      (values (core-send-generic #f) (core-send-generic #t))))
 
   (define-syntaxes (class-field-accessor class-field-mutator generic/form)
     (let ([mk
@@ -2755,21 +2844,50 @@
        (mk (quote-syntax make-class-field-mutator) "class")
        (mk (quote-syntax make-generic/proc) "class or interface"))))
 
-  (define-syntax (get-field stx)
+  (define-syntax (class-field-accessor-traced stx)
+    (syntax-case stx ()
+      [(form class name)
+       (syntax/loc stx
+         (let* ([accessor (class-field-accessor class name)])
+           (lambda (obj)
+             (begin0 (accessor obj)
+                     (get-event obj 'name)))))]))
+
+  (define-syntax (class-field-mutator-traced stx)
+    (syntax-case stx ()
+      [(form class name)
+       (syntax/loc stx
+         (let* ([mutator (class-field-mutator class name)])
+           (lambda (obj value)
+             (begin0 (mutator obj value)
+                     (set-event obj 'name value)))))]))
+
+  (define-syntaxes (get-field get-field-traced)
+    (let ()
+      (define (core-get-field traced?)
+        (lambda (stx)
           (syntax-case stx ()
             [(_ name obj)
              (identifier? (syntax name))
-       (with-syntax ([localized (localize (syntax name))])
+             (with-syntax ([get (if traced?
-         (syntax (get-field/proc `localized obj)))]
+                                    (syntax get-field/proc-traced)
+                                    (syntax get-field/proc))]
+                           [localized (localize (syntax name))])
+               (syntax (get `localized obj)))]
             [(_ name obj)
-       (raise-syntax-error 'get-field "expected a field name as first argument" stx (syntax name))]))
+             (raise-syntax-error
+              'get-field "expected a field name as first argument"
+              stx (syntax name))])))
+      (values (core-get-field #f) (core-get-field #t))))
   
-  (define (get-field/proc id obj)
+  (define-traced (get-field/proc id obj)
     (unless (object? obj)
       (raise-mismatch-error 
        'get-field
        "expected an object, got "
        obj))
+    (trace-begin
+     (trace (get-event obj id))
      (let loop ([obj obj])
        (let* ([cls (object-ref obj)]
               [field-ht (class-field-ht cls)]
@@ -2786,46 +2904,61 @@
            (raise-mismatch-error 
             'get-field
             (format "expected an object that has a field named ~s, got " id)
-            obj)]))))
+            obj)])))))
   
-  (define-syntax (field-bound? stx)
+  (define-syntaxes (field-bound? field-bound?-traced)
+    (let ()
+      (define (core-field-bound? traced?)
+        (lambda (stx)
           (syntax-case stx ()
             [(_ name obj)
              (identifier? (syntax name))
-       (with-syntax ([localized (localize (syntax name))])
+             (with-syntax ([localized (localize (syntax name))]
-         (syntax (field-bound?/proc `localized obj)))]
+                           [bound? (if traced?
+                                       (syntax field-bound?/proc-traced)
+                                       (syntax field-bound?/proc))])
+               (syntax (bound? `localized obj)))]
             [(_ name obj)
-       (raise-syntax-error 'field-bound? "expected a field name as first argument" stx (syntax name))]))
+             (raise-syntax-error
+              'field-bound? "expected a field name as first argument"
+              stx (syntax name))])))
+      (values (core-field-bound? #f) (core-field-bound? #t))))
   
-  (define (field-bound?/proc id obj)
+  (define-traced (field-bound?/proc id obj)
     (unless (object? obj)
       (raise-mismatch-error 
        'field-bound?
        "expected an object, got "
        obj))
+    (trace-begin
+     (trace (inspect-event obj))
      (let loop ([obj obj])
        (let* ([cls (object-ref obj)]
               [field-ht (class-field-ht cls)])
          (or (and (hash-table-get field-ht id #f)
                   #t) ;; ensure that only #t and #f leak out, not bindings in ht
              (and (wrapper-object? obj)
-                 (loop (wrapper-object-wrapped obj)))))))
+                  (loop (wrapper-object-wrapped obj))))))))
   
-  (define (field-names obj)
+  (define-traced (field-names obj)
     (unless (object? obj)
       (raise-mismatch-error 
        'field-names
        "expected an object, got "
        obj))
+    (trace-begin
+     (trace (inspect-event obj))
      (let loop ([obj obj])
        (let* ([cls (object-ref obj)]
               [field-ht (class-field-ht cls)]
               [flds (filter interned? (hash-table-map field-ht (lambda (x y) x)))])
          (if (wrapper-object? obj)
              (append flds (loop (wrapper-object-wrapped obj)))
-            flds))))
+             flds)))))
     
-  (define-syntax with-method
+  (define-syntaxes (with-method with-method-traced)
+    (let ()
+      (define (core-with-method traced?)
         (lambda (stx)
           (syntax-case stx ()
             [(_ ([id (obj-expr name)] ...) body0 body1 ...)
@@ -2845,16 +2978,19 @@
                          ids names)
                (with-syntax ([(method ...) (generate-temporaries ids)]
                              [(method-obj ...) (generate-temporaries ids)]
-			 [(name ...) (map localize names)])
+                             [(name ...) (map localize names)]
+                             [trace-flag (if traced? (syntax/loc stx #t) (syntax/loc stx #f))])
                  (syntax/loc stx (let-values ([(method method-obj)
                                                (let ([obj obj-expr])
                                                  (find-method/who 'with-method obj `name))]
                                               ...)
                                    (letrec-syntaxes+values ([(id) (make-with-method-map
+                                                                   trace-flag
                                                                    (quote-syntax set!)
                                                                    (quote-syntax id)
                                                                    (quote-syntax method)
-							       (quote-syntax method-obj))]
+                                                                   (quote-syntax method-obj)
+                                                                   (syntax unwrap-object))]
                                                             ...)
                                                            ()
                                                            body0 body1 ...)))))]
@@ -2891,17 +3027,27 @@
               stx
               (syntax x))])))
 
+      (values
+       ;; with-method
+       (core-with-method #f)
+       ;; with-method-traced
+       (core-with-method #t))))
+        
+  
   ;;--------------------------------------------------------------------
   ;;  class, interface, and object properties
   ;;--------------------------------------------------------------------
   
-  (define (is-a? v c)
+  (define-traced (is-a? v c)
+    (trace-begin
+     (trace (when (object? v)
+              (inspect-event v)))
      (cond
       [(class? c) ((class-object? c) (unwrap-object v))]
       [(interface? c)
        (and (object? v)
             (implementation? (object-ref (unwrap-object v)) c))]
-     [else (raise-type-error 'is-a? "class or interface" 1 v c)]))
+      [else (raise-type-error 'is-a? "class or interface" 1 v c)])))
   
   (define (subclass? v c)
     (unless (class? c)
@@ -2911,12 +3057,14 @@
 	   (and (<= p (class-pos v))
 		(eq? c (vector-ref (class-supers v) p))))))
 
-  (define (object-interface o)
+  (define-traced (object-interface o)
     (unless (object? o)
       (raise-type-error 'object-interface "object" o))
-    (class-self-interface (object-ref (unwrap-object o))))
+    (trace-begin
+     (trace (inspect-event o))
+     (class-self-interface (object-ref (unwrap-object o)))))
 
-  (define (object-method-arity-includes? o name cnt)
+  (define-traced (object-method-arity-includes? o name cnt)
     (unless (object? o)
       (raise-type-error 'object-method-arity-includes? "object" o))
     (unless (symbol? name)
@@ -2925,6 +3073,8 @@
 		 (exact? cnt)
 		 (not (negative? cnt)))
       (raise-type-error 'object-method-arity-includes? "non-negative exact integer" cnt))
+    (trace-begin
+     (trace (inspect-event o))
      (let loop ([o o])
        (let* ([c (object-ref o)]
               [pos (hash-table-get (class-method-ht c) name #f)])
@@ -2932,7 +3082,7 @@
           [pos (procedure-arity-includes? (vector-ref (class-methods c) pos) 
                                           (add1 cnt))]
           [(wrapper-object? o) (loop (wrapper-object-wrapped o))]
-	 [else #f]))))
+          [else #f])))))
   
   (define (implementation? v i)
     (unless (interface? i)
@@ -2968,9 +3118,11 @@
     (apply list-immutable (filter interned? (interface-public-ids i))))
 
   
-  (define (object-info o)
+  (define-traced (object-info o)
     (unless (object? o)
       (raise-type-error 'object-info "object" o))
+    (trace-begin
+     (trace (inspect-event o))
      (let loop ([c (object-ref (unwrap-object o))]
                 [skipped? #f])
        (if (struct? ((class-insp-mk c)))
@@ -2978,7 +3130,7 @@
            (values c skipped?)
            (if (zero? (class-pos c))
                (values #f #t)
-	      (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t)))))
+               (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))))
 
   (define (class-info c)
     (unless (class? c)
@@ -3000,10 +3152,12 @@
 		    (loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t)))))
 	(raise-mismatch-error 'class-info "current inspector cannot inspect class: " c)))
 
-  (define object->vector
+  (define-traced object->vector
     (opt-lambda (in-o [opaque-v '...])
       (unless (object? in-o)
 	(raise-type-error 'object->vector "object" in-o))
+      (trace-begin
+       (trace (inspect-event in-o))
        (let ([o (unwrap-object in-o)])
          (list->vector
           (cons
@@ -3013,7 +3167,8 @@
               (let loop ([c c][skipped? skipped?])
                 (cond
                  [(not c) (if skipped? (list opaque-v) null)]
-                 [else (let-values ([(name num-fields field-ids field-ref field-set next next-skipped?)
+                 [else (let-values ([(name num-fields field-ids field-ref
+                                           field-set next next-skipped?)
                                      (class-info c)])
                          (let ([rest (loop next next-skipped?)]
                                [here (let loop ([n num-fields])
@@ -3023,7 +3178,7 @@
                                                  (loop (sub1 n)))))])
                            (append (if skipped? (list opaque-v) null)
                                    here
-                                   rest)))])))))))))
+                                   rest)))]))))))))))
   
   (define (object=? o1 o2)
     (unless (object? o1)
@@ -3410,6 +3565,36 @@
   (define externalizable<%>
     (_interface () externalize internalize))
 
+  ;; Providing traced versions:
+  (provide class-traced
+           class*-traced
+           class/derived-traced
+	   (rename define-serializable-class define-serializable-class-traced)
+           (rename define-serializable-class* define-serializable-class*-traced)
+           (rename mixin mixin-traced)
+           new-traced
+           make-object-traced
+           instantiate-traced
+	   send-traced
+           send/apply-traced
+           send*-traced
+           class-field-accessor-traced
+           class-field-mutator-traced
+           with-method-traced
+           get-field-traced
+           field-bound?-traced
+           field-names-traced
+	   (rename generic/form generic-traced)
+           (rename make-generic/proc make-generic-traced)
+           send-generic-traced
+	   is-a?-traced
+           object-interface-traced
+           object-info-traced
+           object->vector-traced
+	   object-method-arity-includes?-traced
+	   )
+
+  ;; Providing normal functionality:
   (provide (protect make-wrapper-class
 		    wrapper-object-wrapped
 		    extract-vtable

collects/mzlib/private/classidmap.ss

@@ -1,6 +1,7 @@
 
 (module classidmap mzscheme
   (require (lib "stx.ss" "syntax"))
+  (require-for-template mzscheme "class-events.ss")
 
   (define-values (struct:s!t make-s!t s!t? s!t-ref s!t-set!)
     (make-struct-type 'set!-transformer #f 2 0 #f null (current-inspector) 0))
@@ -24,13 +25,7 @@
 
   ;; Check Syntax binding info:
   (define (binding from to stx)
-    stx
+    stx)
-    ;; This 'bound-in-source is no longer needed
-    #;
-    (syntax-property
-     stx
-     'bound-in-source
-     (cons from (syntax-local-introduce to))))
 
 
   (define (make-this-map orig-id the-finder the-obj)
@@ -49,34 +44,42 @@
 	     stx)]
 	   [id (find the-finder the-obj stx)])))))
 
-  (define (make-field-map the-finder the-obj the-binder the-binder-localized field-accessor field-mutator field-pos/null)
+  (define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized
+                          field-accessor field-mutator field-pos/null)
     (let ([set!-stx (datum->syntax-object the-finder 'set!)])
       (mk-set!-trans
        the-binder-localized
        (lambda (stx)
+         (with-syntax ([obj-expr (find the-finder the-obj stx)])
            (syntax-case stx ()
              [(set! id expr)
               (module-identifier=? (syntax set!) set!-stx)
-	    (binding
+              (with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [value expr]))]
-	     the-binder (syntax id)
+                            [trace (syntax/loc stx (set-event obj (quote id) value))]
-	     (datum->syntax-object 
+                            [set (quasisyntax/loc stx
-	      the-finder
+                                   ((unsyntax field-mutator)
-	      (list* field-mutator (find the-finder the-obj stx) (append field-pos/null (list (syntax expr))))
+                                    obj (unsyntax-splicing field-pos/null) value))])
-	      stx))]
+                (if trace-flag
+                    (syntax/loc stx (let* bindings trace set))
+                    (syntax/loc stx (let* bindings set))))]
              [(id . args)
-	    (binding
+              (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
-	     the-binder (syntax id)
+                            [trace (syntax/loc stx (get-event obj (quote id)))]
-	     (datum->syntax-object 
+                            [call (quasisyntax/loc stx
-	      the-finder
+                                    (((unsyntax field-accessor)
-	      (cons (list* field-accessor (find the-finder the-obj stx) field-pos/null) (syntax args))
+                                      obj-expr (unsyntax-splicing field-pos/null)) . args))])
-	      stx))]
+                (if trace-flag
-	   [_else
+                    (syntax/loc stx (let* bindings trace call))
-	    (binding
+                    (syntax/loc stx (let* bindings call))))]
-	     the-binder stx
+             [id
-	     (datum->syntax-object 
+              (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))]
-	      the-finder
+                            [trace (syntax/loc stx (get-event obj (quote id)))]
-	      (list* field-accessor (find the-finder the-obj stx) field-pos/null)
+                            [get (quasisyntax/loc stx
-	      stx))])))))
+                                   ((unsyntax field-accessor)
+                                    obj-expr (unsyntax-splicing field-pos/null)))])
+                (if trace-flag
+                    (syntax/loc stx (let* bindings trace get))
+                    (syntax/loc stx (let* bindings get))))]))))))
 
   (define (make-method-map the-finder the-obj the-binder the-binder-localized method-accessor)
     (let ([set!-stx (datum->syntax-object the-finder 'set!)])
@@ -248,22 +251,31 @@
        "cannot use superclass initialization form in a method"
        stx)))
 
-  (define (make-with-method-map set!-stx id-stx method-stx method-obj-stx)
+  (define (make-with-method-map trace-flag set!-stx id-stx
+                                method-stx method-obj-stx unwrap-stx)
     (make-set!-transformer
      (lambda (stx)
        (syntax-case stx ()
 	 [(set! id expr)
-	  (module-identifier=? (syntax set!) set!-stx)
+          (and (identifier? (syntax id))
+               (module-identifier=? (syntax set!) set!-stx))
 	  (raise-syntax-error 'with-method "cannot mutate method" stx)]
 	 [(id . args)
-	  (datum->syntax-object 
+          (identifier? (syntax id))
-	   set!-stx
+          (let* ([args-stx (syntax args)]
-	   (make-method-apply
+                 [proper? (stx-list? args-stx)]
-	    method-stx
+                 [flat-args-stx (if proper? args-stx (flatten-args args-stx))])
+            (make-method-call
+             trace-flag
+             stx
              method-obj-stx
-	    (syntax args))
+             unwrap-stx
-	   stx)]
+             method-stx
-	 [_else
+             (syntax (quote id))
+             flat-args-stx
+             (not proper?)))]
+	 [id
+          (identifier? (syntax id))
 	  (raise-syntax-error 
 	   'with-method 
 	   "misuse of method (not in application)" 
@@ -307,12 +319,39 @@
     (and (pair? ctx)
 	 (class-context? (car ctx))))
 
+  (define (make-method-call traced? source-stx object-stx unwrap-stx
+                            method-proc-stx method-name-stx args-stx rest-arg?)
+
+    (define-syntax (qstx stx)
+      (syntax-case stx ()
+        [(form body) (syntax/loc stx (quasisyntax/loc source-stx body))]))
+
+    (with-syntax ([object object-stx]
+                  [method method-proc-stx]
+                  [app (if rest-arg? (qstx apply) (qstx #%app))]
+                  [args args-stx])
+      (if traced?
+          (with-syntax ([(mth obj) (generate-temporaries
+                                    (list object-stx method-proc-stx))]
+                        [unwrap unwrap-stx]
+                        [name method-name-stx]
+                        [(arg ...) (qstx args)]
+                        [(var ...) (generate-temporaries (qstx args))])
+            (qstx (let ([mth method]
+                        [obj object]
+                        [var arg] ...)
+                    (initialize-call-event
+                     (unwrap obj) name (app list var ...))
+                    (call-with-values (lambda () (app mth obj var ...))
+                      finalize-call-event))))
+          (qstx (app method object . args)))))
+
   (provide (protect make-this-map make-field-map make-method-map 
 		    make-direct-method-map 
 		    make-rename-super-map make-rename-inner-map
 		    make-init-error-map make-init-redirect super-error-map 
 		    make-with-method-map
-		    flatten-args
+		    flatten-args make-method-call
 		    make-private-name localize
 		    generate-super-call generate-inner-call
 		    generate-class-expand-context class-top-level-context?)))