;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
-;;;; Free Software Foundation, Inc.
+;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;;;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
+;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(define current-warning-port current-error-port)
(define (warn . stuff)
- (with-output-to-port (current-error-port)
+ (with-output-to-port (current-warning-port)
(lambda ()
(newline)
(display ";;; WARNING ")
(_ (default-printer)))
args))
+ (define (getaddrinfo-error-printer port key args default-printer)
+ (format port "In procedure getaddrinfo: ~a" (gai-strerror (car args))))
+
(set-exception-printer! 'goops-error scm-error-printer)
(set-exception-printer! 'host-not-found scm-error-printer)
(set-exception-printer! 'keyword-argument-error scm-error-printer)
(set-exception-printer! 'wrong-number-of-args scm-error-printer)
(set-exception-printer! 'wrong-type-arg scm-error-printer)
- (set-exception-printer! 'syntax-error syntax-error-printer))
+ (set-exception-printer! 'syntax-error syntax-error-printer)
+
+ (set-exception-printer! 'getaddrinfo-error getaddrinfo-error-printer))
\f
(define (%load-announce file)
(if %load-verbosely
- (with-output-to-port (current-error-port)
+ (with-output-to-port (current-warning-port)
(lambda ()
(display ";;; ")
(display "loading ")
body body* ...)))))))
\f
+;;;
+;;; Current ports as parameters.
+;;;
+
+(let ((fluid->parameter
+ (lambda (fluid conv)
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (let ((prev (fluid-ref fluid)))
+ (fluid-set! fluid (conv x))
+ prev)))
+ fluid conv))))
+ (define-syntax-rule (port-parameterize! binding fluid predicate msg)
+ (begin
+ (set! binding (fluid->parameter (module-ref (current-module) 'fluid)
+ (lambda (x)
+ (if (predicate x) x
+ (error msg x)))))
+ (module-remove! (current-module) 'fluid)))
+
+ (port-parameterize! current-input-port %current-input-port-fluid
+ input-port? "expected an input port")
+ (port-parameterize! current-output-port %current-output-port-fluid
+ output-port? "expected an output port")
+ (port-parameterize! current-error-port %current-error-port-fluid
+ output-port? "expected an output port"))
+
+
+\f
;;;
;;; Warnings.
;;;
;; 0 by printing a newline, but we then advance it by printing
;; the prompt. However the port-column of the output port
;; does not typically correspond with the actual column on the
- ;; screen, because the input is is echoed back! Since the
+ ;; screen, because the input is echoed back! Since the
;; input is line-buffered and thus ends with a newline, the
;; output will really start on column zero. So, here we zero
;; it out. See bug 9664.
#f))
(define (warn module name int1 val1 int2 val2 var val)
- (format (current-error-port)
+ (format (current-warning-port)
"WARNING: ~A: `~A' imported from both ~A and ~A\n"
(module-name module)
name
(define (warn-override-core module name int1 val1 int2 val2 var val)
(and (eq? int1 the-scm-module)
(begin
- (format (current-error-port)
+ (format (current-warning-port)
"WARNING: ~A: imported module ~A overrides core binding `~A'\n"
(module-name module)
(module-name int2)
;;; {`load'.}
;;;
;;; Load is tricky when combined with relative paths, compilation, and
-;;; the filesystem. If a path is relative, what is it relative to? The
+;;; the file system. If a path is relative, what is it relative to? The
;;; path of the source file at the time it was compiled? The path of
;;; the compiled file? What if both or either were installed? And how
;;; do you get that information? Tricky, I say.
go-path
(begin
(if gostat
- (format (current-error-port)
+ (format (current-warning-port)
";;; note: source file ~a\n;;; newer than compiled ~a\n"
name go-path))
(cond
(%load-should-auto-compile
(%warn-auto-compilation-enabled)
- (format (current-error-port) ";;; compiling ~a\n" name)
+ (format (current-warning-port) ";;; compiling ~a\n" name)
(let ((cfn
((module-ref
(resolve-interface '(system base compile))
name
#:opts %auto-compilation-options
#:env (current-module))))
- (format (current-error-port) ";;; compiled ~a\n" cfn)
+ (format (current-warning-port) ";;; compiled ~a\n" cfn)
cfn))
(else #f))))))
(lambda (k . args)
- (format (current-error-port)
+ (format (current-warning-port)
";;; WARNING: compilation of ~a failed:\n" name)
(for-each (lambda (s)
(if (not (string-null? s))
- (format (current-error-port) ";;; ~a\n" s)))
+ (format (current-warning-port) ";;; ~a\n" s)))
(string-split
(call-with-output-string
(lambda (port) (print-exception port #f k args)))
srfi-4 ;; homogenous numeric vectors
srfi-6 ;; open-input-string etc, in the guile core
srfi-13 ;; string library
- srfi-23 ;; `error` procedure
srfi-14 ;; character sets
+ srfi-23 ;; `error` procedure
+ srfi-39 ;; parameterize
srfi-55 ;; require-extension
srfi-61 ;; general cond clause
))