From 978329cc00fdc30da363e3fe3e80e08709d7e992 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Tue, 16 Aug 2011 14:22:43 -0700 Subject: [PATCH] Outf-console is now outf-error, writing to stderr. --- doc/ffi/ffi.texinfo | 7 +++---- doc/ffi/prhello.scm | 2 +- src/gtk/fix-demo.scm | 4 ++-- src/gtk/fix-layout.scm | 4 ++-- src/gtk/gio.scm | 2 +- src/gtk/gobject.scm | 2 +- src/gtk/gtk-ev.scm | 4 ++-- src/gtk/gtk-object.scm | 2 +- src/gtk/hello.scm | 2 +- src/gtk/swat.scm | 4 ++-- src/gtk/thread.scm | 2 +- src/microcode/pruxffi.c | 9 +++++---- src/runtime/ffi.scm | 14 +++++++------- src/runtime/runtime.pkg | 2 +- src/runtime/thread-queue.scm | 18 +++++++++--------- src/runtime/thread.scm | 2 +- 16 files changed, 40 insertions(+), 40 deletions(-) diff --git a/doc/ffi/ffi.texinfo b/doc/ffi/ffi.texinfo index e023561a3..b0dbc157a 100644 --- a/doc/ffi/ffi.texinfo +++ b/doc/ffi/ffi.texinfo @@ -589,14 +589,13 @@ 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. - @node Compiling and Linking, Hello World, Callbacks, Top @chapter Compiling and Linking diff --git a/doc/ffi/prhello.scm b/doc/ffi/prhello.scm index 25caeff5f..9ceb62d11 100644 --- 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/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index 25a9d4bf4..1960c56bd 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -253,7 +253,7 @@ USA. (define-syntax %trace (syntax-rules () - ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS))))))) (define-syntax %trace2 (syntax-rules () - ((_ . ARGS) (if %trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if %trace2? ((lambda () (outf-error . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index f2cd57d07..932906f1d 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -1901,10 +1901,10 @@ USA. (define-syntax %trace (syntax-rules () - ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS))))))) (define %trace2? #f) (define-syntax %trace2 (syntax-rules () - ((_ . ARGS) (if %trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if %trace2? ((lambda () (outf-error . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index f8b347f62..c389c491d 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -1141,4 +1141,4 @@ USA. (define-syntax %trace (syntax-rules () - ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm index 30f32d8fa..b1d4d9316 100644 --- a/src/gtk/gobject.scm +++ b/src/gtk/gobject.scm @@ -634,6 +634,6 @@ USA. (define-syntax %trace (syntax-rules () - ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS))))))) (initialize-package!) \ No newline at end of file diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm index 1fbe35899..28aa48f56 100644 --- a/src/gtk/gtk-ev.scm +++ b/src/gtk/gtk-ev.scm @@ -440,10 +440,10 @@ USA. (define-syntax %trace (syntax-rules () - ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS))))))) (define %trace2? #f) (define-syntax %trace2 (syntax-rules () - ((_ . ARGS) (if %trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if %trace2? ((lambda () (outf-error . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gtk-object.scm b/src/gtk/gtk-object.scm index e1b62849d..ae6214627 100644 --- a/src/gtk/gtk-object.scm +++ b/src/gtk/gtk-object.scm @@ -905,4 +905,4 @@ USA. (define-syntax %trace (syntax-rules () - ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/hello.scm b/src/gtk/hello.scm index 2c34bdd3b..951ef2c0b 100644 --- a/src/gtk/hello.scm +++ b/src/gtk/hello.scm @@ -14,7 +14,7 @@ This is Havoc Pennington's Hello World example from GGAD, wrapped in Scheme. |# (set-gtk-window-delete-event-callback! window (lambda (window) - (outf-console ";Bite me "(- 2 counter)" times.\n") + (outf-error ";Bite me "(- 2 counter)" times.\n") (set! counter (1+ counter)) ;; Three or more is the charm. (if (> counter 2) 0 1))) diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm index d1c0a5c2b..5ab9bedcd 100644 --- a/src/gtk/swat.scm +++ b/src/gtk/swat.scm @@ -1224,12 +1224,12 @@ USA. (define-syntax %trace (syntax-rules () - ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS))))))) (define %trace2? #f) (define-syntax %trace2 (syntax-rules () - ((_ . ARGS) (if %trace2? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace2? ((lambda () (outf-error . ARGS))))))) (initialize-package!) \ No newline at end of file diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm index 67bbbec67..6a65fb867 100644 --- a/src/gtk/thread.scm +++ b/src/gtk/thread.scm @@ -93,4 +93,4 @@ USA. (define-syntax %trace (syntax-rules () ((_ . MSG) - (if %trace? ((lambda () (outf-console . MSG))))))) \ No newline at end of file + (if %trace? ((lambda () (outf-error . MSG))))))) \ No newline at end of file diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c index 805d6eb40..bdaab84cc 100644 --- a/src/microcode/pruxffi.c +++ b/src/microcode/pruxffi.c @@ -1024,9 +1024,10 @@ 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. */ + /* To avoid the normal i/o system when debugging a callback. Uses + the Unix "stderr" channel. */ PRIMITIVE_HEADER (1); { @@ -1034,8 +1035,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 a0714a371..11ed5e895 100644 --- a/src/runtime/ffi.scm +++ b/src/runtime/ffi.scm @@ -334,14 +334,14 @@ USA. (define (call-alien* alien-function args) (let ((old-top calloutback-stack)) (%if-tracing - (outf-console ";"(tindent)"=> "alien-function" "args"\n") + (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") (set! calloutback-stack old-top) - (outf-console ";"(tindent)"<= "value"\n")) + (outf-error ";"(tindent)"<= "value"\n")) value))) @@ -479,7 +479,7 @@ USA. (normalize-aliens! args) (let ((old-top calloutback-stack)) (%if-tracing - (outf-console ";"(tindent)"=>> "procedure" "args"\n") + (outf-error ";"(tindent)"=>> "procedure" "args"\n") (set! calloutback-stack (cons (cons procedure args) old-top))) (let ((value (apply-callback-proc procedure args))) (%if-tracing @@ -487,7 +487,7 @@ USA. (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) @@ -512,8 +512,8 @@ USA. ;;; For callback debugging: -(define (outf-console . objects) - ((ucode-primitive outf-console 1) +(define (outf-error . objects) + ((ucode-primitive outf-error 1) (apply string-append (map (lambda (o) (if (string? o) o (write-to-string o))) objects)))) @@ -565,7 +565,7 @@ USA. (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 45160b7a5..18837dd58 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3301,7 +3301,7 @@ USA. free register-c-callback de-register-c-callback - outf-console) + outf-error) (initialization (initialize-package!))) (define-package (runtime program-copier) diff --git a/src/runtime/thread-queue.scm b/src/runtime/thread-queue.scm index 6eba438b8..56cb81010 100644 --- a/src/runtime/thread-queue.scm +++ b/src/runtime/thread-queue.scm @@ -256,26 +256,26 @@ USA. ;; Sets up a "producer" thread that puts the letters of the alphabet ;; into a thread-queue, one each 2-3 seconds. A "consumer" thread ;; waits on the queue, printing what it reads. - (outf-console ";Thread Queue Test\n") + (outf-error ";Thread Queue Test\n") (let ((queue (make-thread-queue))) (create-thread #f (lambda () - (outf-console "; Consumer: "(current-thread)"\n") + (outf-error "; Consumer: "(current-thread)"\n") (let loop () - (outf-console "; Consumer reads.\n") + (outf-error "; Consumer reads.\n") (let ((item (thread-queue/dequeue! queue))) - (outf-console "; Consumer read "item"\n") + (outf-error "; Consumer read "item"\n") (loop))))) (create-thread #f (lambda () - (outf-console "; Producer: "(current-thread)"\n") + (outf-error "; Producer: "(current-thread)"\n") (for-each (lambda (item) - (outf-console "; Producer: sleeping...\n") + (outf-error "; Producer: sleeping...\n") (sleep-current-thread 2000) - (outf-console "; Producer: queuing "item"...\n") + (outf-error "; Producer: queuing "item"...\n") (thread-queue/queue! queue item) - (outf-console "; Producer: queued "item"\n")) + (outf-error "; Producer: queued "item"\n")) '(#\a #\b #\c #\d #\e)) - (outf-console "; Producer done.\n"))))) \ No newline at end of file + (outf-error "; Producer done.\n"))))) \ No newline at end of file diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 8c6bce041..75bf4cd78 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -329,7 +329,7 @@ USA. (define-syntax %trace (syntax-rules () ((_ . MSG) - (if %trace? ((lambda () (outf-console . MSG))))))) + (if %trace? ((lambda () (outf-error . MSG))))))) (define (yield-current-thread) (without-interrupts -- 2.25.1