Moved outf-console to -error (stderr); fiddled FFI debugging.

diff --git a/doc/ffi/ffi.texinfo b/doc/ffi/ffi.texinfo
index e023561a3d77682fc2ee891a2a779d32e69a6b61..0ab9f6fd1258913ad9bca75a8a77b4c307e8b55b 100644 (file)
--- a/doc/ffi/ffi.texinfo
+++ b/doc/ffi/ffi.texinfo
@@ -589,11 +589,11 @@ balk at a callback procedure that calls @code{yield-thread}, waits for
 I/O, sleeps, or otherwise causes a thread switch.  Presumably such a
 procedure has some other way of enforcing the LIFO ordering.
 
-The @code{outf-console} procedure is provided for debugging purposes.
+The @code{outf-error} procedure is provided for debugging purposes.
 It writes one or more argument strings (and @code{write}s any
-non-strings) to the console and flushes, atomically, via a machine
+non-strings) to the Unix ``stderr'' channel, atomically, via a machine
 primitive, bypassing the runtime's I/O buffering and thread switching.
-Thus multiple debugging trace messages arrive on the console intact
+Thus trace messages from multiple threads will appear on stderr intact
 and uninterrupted.
 
 

diff --git a/doc/ffi/prhello.scm b/doc/ffi/prhello.scm
index 25caeff5f3b4f565fa84a10f2ac7b25ef50a9003..9ceb62d11f71008984b5fd7461cfe52934743d54 100644 (file)
--- a/doc/ffi/prhello.scm
+++ b/doc/ffi/prhello.scm
@@ -32,7 +32,7 @@ callbacks. |#
              (C-callback "delete_event")       ;trampoline
              (C-callback                       ;callback ID
               (lambda (w e)
-                (outf-console ";Delete me "(- 2 counter)" times.\n")
+                (outf-error ";Delete me "(- 2 counter)" times.\n")
                 (set! counter (1+ counter))
                 ;; Three or more is the charm.
                 (if (> counter 2)

diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index a64179e181093636ef7e5e883abcaee6968fdbf2..2f45ea3da7c730a7c598ce76ba172dbc5f24f05e 100644 (file)
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -998,7 +998,7 @@ empty_list (void)
   return (EMPTY_LIST);
 }
 
-DEFINE_PRIMITIVE ("OUTF-CONSOLE", Prim_outf_console, 1, 1, 0)
+DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0)
 {
   /* To avoid the normal i/o system when debugging a callback. */
 
@@ -1008,8 +1008,8 @@ DEFINE_PRIMITIVE ("OUTF-CONSOLE", Prim_outf_console, 1, 1, 0)
     if (STRING_P (arg))
       {
        char * string = ((char *) STRING_LOC (arg, 0));
-       outf_console ("%s", string);
-       outf_flush_console ();
+       outf_error ("%s", string);
+       outf_flush_error ();
       }
     else
       {

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index 489ddca424bd2239c2d5ddaa49a817dbacb1c0cd..7ee4bd6a0cf61b3029337e771d8b10d69b6f516a 100644 (file)
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-Copyright (C) 2006, 2007, 2008, 2009, 2010 Matthew Birkholz
+Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
 
 This file is part of MIT/GNU Scheme.
 
@@ -322,15 +322,15 @@ USA.
 
 (define (call-alien* alien-function args)
   (let ((old-top calloutback-stack))
-    (if-tracing
-     (outf-console ";"(tindent)"=> "alien-function" "args"\n")
+    (%if-tracing
+     (outf-error ";"(tindent)"=> "alien-function" "args"\n")
      (set! calloutback-stack (cons (cons* alien-function args) old-top)))
     (let ((value (apply (ucode-primitive c-call -1) alien-function args)))
-      (if-tracing
-       (assert (eq? old-top (cdr calloutback-stack))
-              "call-alien: freak stack "calloutback-stack"\n")
+      (%if-tracing
+       (%assert (eq? old-top (cdr calloutback-stack))
+               "call-alien: freak stack "calloutback-stack"\n")
        (set! calloutback-stack old-top)
-       (outf-console ";"(tindent)"<= "value"\n"))
+       (outf-error ";"(tindent)"<= "value"\n"))
       value)))
 \f
 
@@ -469,16 +469,16 @@ USA.
        (error:bad-range-argument id 'apply-callback))
     (normalize-aliens! args)
     (let ((old-top calloutback-stack))
-      (if-tracing
-       (outf-console ";"(tindent)"=>> "procedure" "args"\n")
+      (%if-tracing
+       (outf-error ";"(tindent)"=>> "procedure" "args"\n")
        (set! calloutback-stack (cons (cons procedure args) old-top)))
       (let ((value (apply-callback-proc procedure args)))
-       (if-tracing
-        (assert (and (pair? calloutback-stack)
-                     (eq? old-top (cdr calloutback-stack)))
-                "callback-handler: freak stack "calloutback-stack"\n")
+       (%if-tracing
+        (%assert (and (pair? calloutback-stack)
+                      (eq? old-top (cdr calloutback-stack)))
+                 "callback-handler: freak stack "calloutback-stack"\n")
         (set! calloutback-stack old-top)
-        (outf-console ";"(tindent)"<<= "value"\n"))
+        (outf-error ";"(tindent)"<<= "value"\n"))
        value))))
 
 (define (apply-callback-proc procedure args)
@@ -501,27 +501,39 @@ USA.
                (error "Cannot return from a callback more than once.")
                (loop)))))))))
 
-;; For callback debugging...
-(define (outf-console . objects)
-  ((ucode-primitive outf-console 1)
+;;; For callback debugging:
+
+(define (outf-error . objects)
+  ((ucode-primitive outf-error 1)
    (apply string-append
          (map (lambda (o) (if (string? o) o (write-to-string o)))
               objects))))
 
+(define (registered-callback-count)
+  (let* ((vector registered-callbacks)
+        (end (vector-length vector)))
+    (let loop ((i 0)(count 0))
+      (if (fix:< i end)
+         (loop (fix:1+ i)
+               (if (vector-ref vector i)
+                   (fix:1+ count)
+                   count))
+         (cons count end)))))
+
 (define (initialize-callbacks!)
   (vector-set! (get-fixed-objects-vector) #x41 callback-handler))
 \f
 
 (define calloutback-stack '())
 
-(define trace? #f)
+(define %trace? #f)
 
 (define (reset-package!)
   (reset-alien-functions!)
   (reset-malloced-aliens!)
   (reset-callbacks!)
   (set! %radix (if (fix:fixnum? #x100000000) #x100000000 #x10000))
-  (set! trace? #f)
+  (set! %trace? #f)
   (set! calloutback-stack '()))
 
 (define (initialize-package!)
@@ -531,20 +543,20 @@ USA.
   (add-gc-daemon! free-malloced-aliens)
   unspecific)
 
-(define-syntax if-tracing
+(define-syntax %if-tracing
   (syntax-rules ()
     ((_ . BODY)
-     (if trace? ((lambda () . BODY))))))
+     (if %trace? ((lambda () . BODY))))))
 
-(define-syntax assert
+(define-syntax %assert
   (syntax-rules ()
     ((_ TEST . MSG)
      (if (not TEST) (error "Failed assert:" . MSG)))))
 
-(define-syntax trace
+(define-syntax %trace
   (syntax-rules ()
     ((_ . MSG)
-     (if trace? ((lambda () (outf-console . MSG)))))))
+     (if %trace? ((lambda () (outf-error . MSG)))))))
 
 (define (tindent)
   (make-string (* 2 (length calloutback-stack)) #\space))
\ No newline at end of file

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index bffa129a4b292ca18fb0ee7797cc02763507f2dc..99cefe50ba324079f48f98a918337563ce5375fa 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3282,7 +3282,7 @@ USA.
          free
          register-c-callback
          de-register-c-callback
-         outf-console)
+         outf-error)
   (initialization (initialize-package!)))
 
 (define-package (runtime program-copier)