* Reorganize macro code.

* Change `trace-apply' to accept keyword arguments by being a keyworded
  function itself
* Renamed `trace-apply' to `trace-call' -- since it's not following the
  calling convention of `apply'.

svn: r16161

collects/mzlib/scribblings/trace.scrbl

@@ -57,10 +57,11 @@ result is converted into a string using @scheme[pretty-print].  The
 parameter's default value prints the given string followed by a newline to
 @scheme[(current-output-port)].}
 
-@defproc[(trace-apply [id symbol?] [proc procedure?] [kws (listof keyword)] [kw-vals list?] [arg any/c] ...) any/c]{
+@defproc[(trace-call [id symbol?] [proc procedure?]
+                     [#:<kw> kw-arg any/c] ...) any/c]{
 
 Calls @scheme[proc] with the arguments supplied in
-@scheme[args], @scheme[kws], and @scheme[kw-vals]. Also prints out the
+@scheme[args], and possibly using keyword arguments. Also prints out the
 trace information during the call, as described above in the docs for
 @scheme[trace], using @scheme[id] as the name of @scheme[proc].
 

collects/mzlib/trace.ss

@@ -179,7 +179,12 @@
 ;;  the nesting depth:
 (define -:trace-level-key (gensym))
 
-(define (trace-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f))
+(define trace-apply
+  (make-keyword-procedure
+   (lambda (id f kws vals . args)
+     (do-traced id args kws vals f))
+   (lambda (id f . args)
+     (do-traced id args '() '() f))))
 
 ;; Apply a traced procedure to arguments, printing arguments
 ;; and results. We set and inspect the -:trace-level-key continuation
@@ -236,58 +241,35 @@
                                     ;; Return the results:
                                     (apply values results))))))))))
 
-(define-syntax trace
+(define-for-syntax (check-ids stx ids)
-  (lambda (stx)
+  (for ([id (in-list (syntax->list ids))])
-    (syntax-case stx ()
-      [(_ id ...)
-       (let ([ids (syntax->list (syntax (id ...)))])
-         (for-each (lambda (id)
     (unless (identifier? id)
-                       (raise-syntax-error
+      (raise-syntax-error #f "not an identifier" stx id)))
-                        #f
+  #t)
-                        "not an identifier"
+
-                        stx
+(define-syntax (trace stx)
-                        id)))
+  (syntax-case stx ()
-                   ids)
+    [(_ id ...) (check-ids stx #'(id ...))
-         (with-syntax ([(traced-name ...)
+     (with-syntax ([(tid ...)
-                        (map (lambda (id)
+                    (for/list ([id (in-list (syntax->list #'(id ...)))])
-                               (datum->syntax
+                      (let ([tid (format "traced-~a" (syntax-e id))])
-                                id
+                        (datum->syntax id (string->symbol tid) #f)))])
-                                (string->symbol
-                                 (string-append "traced-"
-                                                (symbol->string (syntax-e id))))
-                                #f))
-                             ids)])
        #'(do-trace
           '(id ...)
           (list id ...)
           (list (lambda (v) (set! id v)) ...)
-              (list
+          (list (let* ([real-value id]
-               (let ([real-value id])
+                       [tid (make-keyword-procedure
-                 (let ([traced-name
-                        (make-keyword-procedure
                              (lambda (kws vals . args)
                                (do-traced 'id args kws vals real-value))
                              (lambda args
                                (do-traced 'id args null null real-value)))])
-                   traced-name))
+                  tid)
-               ...))))])))
+                ...)))]))
 
-(define-syntax untrace
+(define-syntax (untrace stx)
-  (lambda (stx)
   (syntax-case stx ()
-      [(_ id ...)
+    [(_ id ...) (check-ids stx #'(id ...))
-       (let ([ids (syntax->list (syntax (id ...)))])
+     #'(begin (when (traced-proc? id)
-         (for-each (lambda (id)
-                     (unless (identifier? id)
-                       (raise-syntax-error
-                        #f
-                        "not an identifier"
-                        stx
-                        id)))
-                   ids)
-         (syntax
-          (begin
-            (when (traced-proc? id)
                 (set! id (traced-proc-ref id 1)))
-            ...)))])))
+              ...)]))

collects/redex/private/reduction-semantics.ss

@@ -1480,7 +1480,7 @@
                                       (parameterize ([current-trace-print-args
                                                       (λ (name args kws kw-args level)
                                                         (ot name (car args) kws kw-args level))])
-                                        (trace-apply name metafunc '() '() exp))
+                                        (trace-call name metafunc exp))
                                       (metafunc exp)))])
         traced-metafunc)
       compiled-patterns