Merge remote-tracking branch 'origin/stable-2.0'

[bpt/guile.git] / module / ice-9 / boot-9.scm

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 8e73015..1de5edf 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1,7 +1,8 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
 ;;; -*- 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
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public


@@ -69,23 +70,6 @@
 
 (define with-throw-handler #f)
 (let ()
 
 (define with-throw-handler #f)
 (let ()

-  ;; Ideally we'd like to be able to give these default values for all threads,
-  ;; even threads not created by Guile; but alack, that does not currently seem
-  ;; possible. So wrap the getters in thunks.
-  (define %running-exception-handlers (make-fluid))
-  (define %exception-handler (make-fluid))
-
-  (define (running-exception-handlers)
-    (or (fluid-ref %running-exception-handlers)
-        (begin
-          (fluid-set! %running-exception-handlers '())
-          '())))
-  (define (exception-handler)
-    (or (fluid-ref %exception-handler)
-        (begin
-          (fluid-set! %exception-handler default-exception-handler)
-          default-exception-handler)))
-

   (define (default-exception-handler k . args)
     (cond
      ((eq? k 'quit)
   (define (default-exception-handler k . args)
     (cond
      ((eq? k 'quit)


@@ -98,18 +82,21 @@
       (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
       (primitive-exit 1))))
 
       (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" k args)
       (primitive-exit 1))))
 

+  (define %running-exception-handlers (make-fluid '()))
+  (define %exception-handler (make-fluid default-exception-handler))
+

   (define (default-throw-handler prompt-tag catch-k)
   (define (default-throw-handler prompt-tag catch-k)

-    (let ((prev (exception-handler)))
+    (let ((prev (fluid-ref %exception-handler)))

       (lambda (thrown-k . args)
         (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
             (apply abort-to-prompt prompt-tag thrown-k args)
             (apply prev thrown-k args)))))
 
   (define (custom-throw-handler prompt-tag catch-k pre)
       (lambda (thrown-k . args)
         (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
             (apply abort-to-prompt prompt-tag thrown-k args)
             (apply prev thrown-k args)))))
 
   (define (custom-throw-handler prompt-tag catch-k pre)

-    (let ((prev (exception-handler)))
+    (let ((prev (fluid-ref %exception-handler)))

       (lambda (thrown-k . args)
         (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
       (lambda (thrown-k . args)
         (if (or (eq? thrown-k catch-k) (eqv? catch-k #t))

-            (let ((running (running-exception-handlers)))
+            (let ((running (fluid-ref %running-exception-handlers)))

               (with-fluids ((%running-exception-handlers (cons pre running)))
                 (if (not (memq pre running))
                     (apply pre thrown-k args))
               (with-fluids ((%running-exception-handlers (cons pre running)))
                 (if (not (memq pre running))
                     (apply pre thrown-k args))


@@ -192,9 +179,9 @@ for key @var{key}, then invoke @var{thunk}."
 
 If there is no handler at all, Guile prints an error and then exits."
           (if (not (symbol? key))
 
 If there is no handler at all, Guile prints an error and then exits."
           (if (not (symbol? key))

-              ((exception-handler) 'wrong-type-arg "throw"
+              ((fluid-ref %exception-handler) 'wrong-type-arg "throw"

                "Wrong type argument in position ~a: ~a" (list 1 key) (list key))
                "Wrong type argument in position ~a: ~a" (list 1 key) (list key))

-              (apply (exception-handler) key args)))))
+              (apply (fluid-ref %exception-handler) key args)))))

 
 
 \f
 
 
 \f


@@ -227,9 +214,11 @@ If there is no handler at all, Guile prints an error and then exits."
 
 (define pk peek)
 
 
 (define pk peek)
 

+;; Temporary definition; replaced later.
+(define current-warning-port current-error-port)

 
 (define (warn . stuff)
 
 (define (warn . stuff)

-  (with-output-to-port (current-error-port)
+  (with-output-to-port (current-warning-port)

     (lambda ()
       (newline)
       (display ";;; WARNING ")
     (lambda ()
       (newline)
       (display ";;; WARNING ")


@@ -744,6 +733,9 @@ If there is no handler at all, Guile prints an error and then exits."
              (_ (default-printer)))
            args))
 
              (_ (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! 'goops-error scm-error-printer)
   (set-exception-printer! 'host-not-found scm-error-printer)
   (set-exception-printer! 'keyword-argument-error scm-error-printer)


@@ -763,7 +755,9 @@ If there is no handler at all, Guile prints an error and then exits."
   (set-exception-printer! 'wrong-number-of-args scm-error-printer)
   (set-exception-printer! 'wrong-type-arg 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
 
 
 \f


@@ -955,16 +949,13 @@ VALUE."
 
 ;; 0: type-name, 1: fields, 2: constructor
 (define record-type-vtable
 
 ;; 0: type-name, 1: fields, 2: constructor
 (define record-type-vtable

-  ;; FIXME: This should just call make-vtable, not make-vtable-vtable; but for
-  ;; that we need to expose the bare vtable-vtable to Scheme.
-  (make-vtable-vtable "prprpw" 0
-                      (lambda (s p)
-                        (cond ((eq? s record-type-vtable)
-                               (display "#<record-type-vtable>" p))
-                              (else
-                               (display "#<record-type " p)
-                               (display (record-type-name s) p)
-                               (display ">" p))))))
+  (let ((s (make-vtable (string-append standard-vtable-fields "prprpw")
+                        (lambda (s p)
+                          (display "#<record-type " p)
+                          (display (record-type-name s) p)
+                          (display ">" p)))))
+    (set-struct-vtable-name! s 'record-type)
+    s))

 
 (define (record-type? obj)
   (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))
 
 (define (record-type? obj)
   (and (struct? obj) (eq? record-type-vtable (struct-vtable obj))))


@@ -1390,7 +1381,7 @@ VALUE."
 
 (define (%load-announce file)
   (if %load-verbosely
 
 (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 ")
         (lambda ()
           (display ";;; ")
           (display "loading ")


@@ -1407,8 +1398,7 @@ VALUE."
 ;;; Reader code for various "#c" forms.
 ;;;
 
 ;;; Reader code for various "#c" forms.
 ;;;
 

-(define read-eval? (make-fluid))
-(fluid-set! read-eval? #f)
+(define read-eval? (make-fluid #f))

 (read-hash-extend #\.
                   (lambda (c port)
                     (if (fluid-ref read-eval?)
 (read-hash-extend #\.
                   (lambda (c port)
                     (if (fluid-ref read-eval?)


@@ -1576,7 +1566,7 @@ VALUE."
     ((define-record-type
        (lambda (x)
          (define (make-id scope . fragments)
     ((define-record-type
        (lambda (x)
          (define (make-id scope . fragments)

-           (datum->syntax #'scope
+           (datum->syntax scope

                           (apply symbol-append
                                  (map (lambda (x)
                                         (if (symbol? x) x (syntax->datum x)))
                           (apply symbol-append
                                  (map (lambda (x)
                                         (if (symbol? x) x (syntax->datum x)))


@@ -2843,17 +2833,109 @@ module '(ice-9 q) '(make-q q-length))}."
 
 \f
 
 
 \f
 

+;;; {Parameters}
+;;;
+
+(define <parameter>
+  ;; Three fields: the procedure itself, the fluid, and the converter.
+  (make-struct <applicable-struct-vtable> 0 'pwprpr))
+(set-struct-vtable-name! <parameter> '<parameter>)
+
+(define* (make-parameter init #:optional (conv (lambda (x) x)))
+  (let ((fluid (make-fluid (conv init))))
+    (make-struct <parameter> 0
+                 (case-lambda
+                   (() (fluid-ref fluid))
+                   ((x) (let ((prev (fluid-ref fluid)))
+                          (fluid-set! fluid (conv x))
+                          prev)))
+                 fluid conv)))
+
+(define (parameter? x)
+  (and (struct? x) (eq? (struct-vtable x) <parameter>)))
+
+(define (parameter-fluid p)
+  (if (parameter? p)
+      (struct-ref p 1)
+      (scm-error 'wrong-type-arg "parameter-fluid"
+                 "Not a parameter: ~S" (list p) #f)))
+
+(define (parameter-converter p)
+  (if (parameter? p)
+      (struct-ref p 2)
+      (scm-error 'wrong-type-arg "parameter-fluid"
+                 "Not a parameter: ~S" (list p) #f)))
+
+(define-syntax parameterize
+  (lambda (x)
+    (syntax-case x ()
+      ((_ ((param value) ...) body body* ...)
+       (with-syntax (((p ...) (generate-temporaries #'(param ...))))
+         #'(let ((p param) ...)
+             (if (not (parameter? p))
+                        (scm-error 'wrong-type-arg "parameterize"
+                                   "Not a parameter: ~S" (list p) #f))
+             ...
+             (with-fluids (((struct-ref p 1) ((struct-ref p 2) value))
+                           ...)
+               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.
+;;;
+
+(define current-warning-port
+  (make-parameter (current-error-port)
+                  (lambda (x)
+                    (if (output-port? x)
+                        x
+                        (error "expected an output port" x)))))
+
+
+\f
+

 ;;; {Running Repls}
 ;;;
 
 ;;; {Running Repls}
 ;;;
 

-(define *repl-stack* (make-fluid))
+(define *repl-stack* (make-fluid '()))

 
 ;; Programs can call `batch-mode?' to see if they are running as part of a
 ;; script or if they are running interactively. REPL implementations ensure that
 ;; `batch-mode?' returns #f during their extent.
 ;;
 (define (batch-mode?)
 
 ;; Programs can call `batch-mode?' to see if they are running as part of a
 ;; script or if they are running interactively. REPL implementations ensure that
 ;; `batch-mode?' returns #f during their extent.
 ;;
 (define (batch-mode?)

-  (null? (or (fluid-ref *repl-stack*) '())))
+  (null? (fluid-ref *repl-stack*)))

 
 ;; Programs can re-enter batch mode, for example after a fork, by calling
 ;; `ensure-batch-mode!'. It's not a great interface, though; it would be better
 
 ;; Programs can re-enter batch mode, for example after a fork, by calling
 ;; `ensure-batch-mode!'. It's not a great interface, though; it would be better


@@ -2892,7 +2974,26 @@ module '(ice-9 q) '(make-q q-length))}."
 (define repl-reader
   (lambda* (prompt #:optional (reader (fluid-ref current-reader)))
     (if (not (char-ready?))
 (define repl-reader
   (lambda* (prompt #:optional (reader (fluid-ref current-reader)))
     (if (not (char-ready?))

-        (display (if (string? prompt) prompt (prompt))))
+        (begin
+          (display (if (string? prompt) prompt (prompt)))
+          ;; An interesting situation.  The printer resets the column to
+          ;; 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 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.
+          ;;
+          ;; Note that for similar reasons, the output-line will not
+          ;; reflect the actual line on the screen.  But given the
+          ;; possibility of multiline input, the fix is not as
+          ;; straightforward, so we don't bother.
+          ;;
+          ;; Also note that the readline implementation papers over
+          ;; these concerns, because it's readline itself printing the
+          ;; prompt, and not Guile.
+          (set-port-column! (current-output-port) 0)))

     (force-output)
     (run-hook before-read-hook)
     ((or reader read) (current-input-port))))
     (force-output)
     (run-hook before-read-hook)
     ((or reader read) (current-input-port))))


@@ -3244,8 +3345,7 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;;
 
 (define* (make-mutable-parameter init #:optional (converter identity))
 ;;;
 
 (define* (make-mutable-parameter init #:optional (converter identity))

-  (let ((fluid (make-fluid)))
-    (fluid-set! fluid (converter init))
+  (let ((fluid (make-fluid (converter init))))

     (case-lambda
       (() (fluid-ref fluid))
       ((val) (fluid-set! fluid (converter val))))))
     (case-lambda
       (() (fluid-ref fluid))
       ((val) (fluid-set! fluid (converter val))))))


@@ -3288,7 +3388,7 @@ module '(ice-9 q) '(make-q q-length))}."
                  #f))
     
     (define (warn module name int1 val1 int2 val2 var val)
                  #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
               "WARNING: ~A: `~A' imported from both ~A and ~A\n"
               (module-name module)
               name


@@ -3310,7 +3410,7 @@ module '(ice-9 q) '(make-q q-length))}."
     (define (warn-override-core module name int1 val1 int2 val2 var val)
       (and (eq? int1 the-scm-module)
            (begin
     (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)
                      "WARNING: ~A: imported module ~A overrides core binding `~A'\n"
                      (module-name module)
                      (module-name int2)


@@ -3364,7 +3464,7 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; {`load'.}
 ;;;
 ;;; Load is tricky when combined with relative paths, compilation, and
 ;;; {`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.
 ;;; 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.


@@ -3432,13 +3532,13 @@ module '(ice-9 q) '(make-q q-length))}."
               go-path
               (begin
                 (if gostat
               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)
                             ";;; 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))
                   (let ((cfn
                          ((module-ref
                                (resolve-interface '(system base compile))


@@ -3446,15 +3546,15 @@ module '(ice-9 q) '(make-q q-length))}."
                               name
                               #:opts %auto-compilation-options
                               #:env (current-module))))
                               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)
                     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))
                 ";;; 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)))
                   (string-split
                    (call-with-output-string
                     (lambda (port) (print-exception port #f k args)))


@@ -3547,8 +3647,9 @@ module '(ice-9 q) '(make-q q-length))}."
     srfi-4   ;; homogenous numeric vectors
     srfi-6   ;; open-input-string etc, in the guile core
     srfi-13  ;; string library
     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-14  ;; character sets

+    srfi-23  ;; `error` procedure
+    srfi-39  ;; parameterize

     srfi-55  ;; require-extension
     srfi-61  ;; general cond clause
     ))
     srfi-55  ;; require-extension
     srfi-61  ;; general cond clause
     ))