[Guile-commits] 03/07: Move exception-handling routines after records in boot-9

[Andy Wingo]

wingo pushed a commit to branch wip-exceptions
in repository guile.

commit fc7a0a854fc85cbd51cfd6028945b433af07f1c1
Author: Andy Wingo <address@hidden>
Date:   Thu Nov 7 15:09:59 2019 +0100

    Move exception-handling routines after records in boot-9
    
    * module/ice-9/boot-9.scm: Move down definitions of catch, throw, and so
      on until they are after records.
---
 module/ice-9/boot-9.scm | 679 ++++++++++++++++++++++++------------------------
 1 file changed, 341 insertions(+), 338 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index c32a307..1d8dd75 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -719,264 +719,6 @@ information is unavailable."
 (define (abort-to-prompt tag . args)
   (abort-to-prompt* tag args))
 
-;; Define catch and with-throw-handler, using some common helper routines and a
-;; shared fluid. Hide the helpers in a lexical contour.
-
-(define with-throw-handler #f)
-(let ((%eh (module-ref (current-module) '%exception-handler)))
-  (define (make-exception-handler catch-key prompt-tag pre-unwind)
-    (vector catch-key prompt-tag pre-unwind))
-  (define (exception-handler-catch-key handler) (vector-ref handler 0))
-  (define (exception-handler-prompt-tag handler) (vector-ref handler 1))
-  (define (exception-handler-pre-unwind handler) (vector-ref handler 2))
-
-  (define %running-pre-unwind (make-fluid #f))
-  (define (pre-unwind-handler-running? handler)
-    (let lp ((depth 0))
-      (let ((running (fluid-ref* %running-pre-unwind depth)))
-        (and running
-             (or (eq? running handler) (lp (1+ depth)))))))
-
-  (define (dispatch-exception depth key args)
-    (cond
-     ((fluid-ref* %eh depth)
-      => (lambda (handler)
-           (let ((catch-key (exception-handler-catch-key handler)))
-             (if (or (eqv? catch-key #t) (eq? catch-key key))
-                 (let ((prompt-tag (exception-handler-prompt-tag handler))
-                       (pre-unwind (exception-handler-pre-unwind handler)))
-                   (cond
-                    ((and pre-unwind
-                          (not (pre-unwind-handler-running? handler)))
-                     ;; Prevent errors from within the pre-unwind
-                     ;; handler's invocation from being handled by this
-                     ;; handler.
-                     (with-fluid* %running-pre-unwind handler
-                       (lambda ()
-                         ;; FIXME: Currently the "running" flag only
-                         ;; applies to the pre-unwind handler; the
-                         ;; post-unwind handler is still called if the
-                         ;; error is explicitly rethrown.  Instead it
-                         ;; would be better to cause a recursive throw to
-                         ;; skip all parts of this handler.  Unfortunately
-                         ;; that is incompatible with existing semantics.
-                         ;; We'll see if we can change that later on.
-                         (apply pre-unwind key args)
-                         (dispatch-exception depth key args))))
-                    (prompt-tag
-                     (apply abort-to-prompt prompt-tag key args))
-                    (else
-                     (dispatch-exception (1+ depth) key args))))
-                 (dispatch-exception (1+ depth) key args)))))
-     ((eq? key 'quit)
-      (primitive-exit (cond
-                       ((not (pair? args)) 0)
-                       ((integer? (car args)) (car args))
-                       ((not (car args)) 1)
-                       (else 0))))
-     (else
-      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
-              key args)
-      (primitive-exit 1))))
-
-  (define (throw key . args)
-    "Invoke the catch form matching @var{key}, passing @var{args} to the
-@var{handler}.
-
-@var{key} is a symbol. It will match catches of the same symbol or of 
@code{#t}.
-
-If there is no handler at all, Guile prints an error and then exits."
-    (unless (symbol? key)
-      (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
-             (list 1 key) (list key)))
-    (dispatch-exception 0 key args))
-
-  (define* (catch k thunk handler #:optional pre-unwind-handler)
-    "Invoke @var{thunk} in the dynamic context of @var{handler} for
-exceptions matching @var{key}.  If thunk throws to the symbol
-@var{key}, then @var{handler} is invoked this way:
-@lisp
- (handler key args ...)
-@end lisp
-
-@var{key} is a symbol or @code{#t}.
-
-@var{thunk} takes no arguments.  If @var{thunk} returns
-normally, that is the return value of @code{catch}.
-
-Handler is invoked outside the scope of its own @code{catch}.
-If @var{handler} again throws to the same key, a new handler
-from further up the call chain is invoked.
-
-If the key is @code{#t}, then a throw to @emph{any} symbol will
-match this call to @code{catch}.
-
-If a @var{pre-unwind-handler} is given and @var{thunk} throws
-an exception that matches @var{key}, Guile calls the
-@var{pre-unwind-handler} before unwinding the dynamic state and
-invoking the main @var{handler}.  @var{pre-unwind-handler} should
-be a procedure with the same signature as @var{handler}, that
-is @code{(lambda (key . args))}.  It is typically used to save
-the stack at the point where the exception occurred, but can also
-query other parts of the dynamic state at that point, such as
-fluid values.
-
-A @var{pre-unwind-handler} can exit either normally or non-locally.
-If it exits normally, Guile unwinds the stack and dynamic context
-and then calls the normal (third argument) handler.  If it exits
-non-locally, that exit determines the continuation."
-    (define (wrong-type-arg n val)
-      (scm-error 'wrong-type-arg "catch"
-                 "Wrong type argument in position ~a: ~a"
-                 (list n val) (list val)))
-    (unless (or (symbol? k) (eqv? k #t))
-      (wrong-type-arg 1 k))
-    (unless (procedure? handler)
-      (wrong-type-arg 3 handler))
-    (unless (or (not pre-unwind-handler) (procedure? pre-unwind-handler))
-      (wrong-type-arg 4 pre-unwind-handler))
-    (let ((tag (make-prompt-tag "catch")))
-      (call-with-prompt
-       tag
-       (lambda ()
-         (with-fluid* %eh (make-exception-handler k tag pre-unwind-handler)
-           thunk))
-       (lambda (cont k . args)
-         (apply handler k args)))))
-
-  (define (with-throw-handler k thunk pre-unwind-handler)
-    "Add @var{handler} to the dynamic context as a throw handler
-for key @var{k}, then invoke @var{thunk}."
-    (if (not (or (symbol? k) (eqv? k #t)))
-        (scm-error 'wrong-type-arg "with-throw-handler"
-                   "Wrong type argument in position ~a: ~a"
-                   (list 1 k) (list k)))
-    (with-fluid* %eh (make-exception-handler k #f pre-unwind-handler)
-      thunk))
-
-  (hashq-remove! (%get-pre-modules-obarray) '%exception-handler)
-  (define! 'catch catch)
-  (define! 'with-throw-handler with-throw-handler)
-  (define! 'throw throw))
-
-
-
-
-;;;
-;;; Extensible exception printing.
-;;;
-
-(define set-exception-printer! #f)
-;; There is already a definition of print-exception from backtrace.c
-;; that we will override.
-
-(let ((exception-printers '()))
-  (define (print-location frame port)
-    (let ((source (and=> frame frame-source)))
-      ;; source := (addr . (filename . (line . column)))
-      (if source
-          (let ((filename (or (cadr source) "<unnamed port>"))
-                (line (caddr source))
-                (col (cdddr source)))
-            (format port "~a:~a:~a: " filename (1+ line) col))
-          (format port "ERROR: "))))
-
-  (set! set-exception-printer!
-        (lambda (key proc)
-          (set! exception-printers (acons key proc exception-printers))))
-
-  (set! print-exception
-        (lambda (port frame key args)
-          (define (default-printer)
-            (format port "Throw to key `~a' with args `~s'." key args))
-
-          (when frame
-            (print-location frame port)
-            ;; When booting, false-if-exception isn't defined yet.
-            (let ((name (catch #t
-                          (lambda () (frame-procedure-name frame))
-                          (lambda _ #f))))
-              (when name
-                (format port "In procedure ~a:\n" name))))
-
-          (catch #t
-            (lambda ()
-              (let ((printer (assq-ref exception-printers key)))
-                (if printer
-                    (printer port key args default-printer)
-                    (default-printer))))
-            (lambda (k . args)
-              (format port "Error while printing exception.")))
-          (newline port)
-          (force-output port))))
-
-;;;
-;;; Printers for those keys thrown by Guile.
-;;;
-(let ()
-  (define (scm-error-printer port key args default-printer)
-    ;; Abuse case-lambda as a pattern matcher, given that we don't have
-    ;; ice-9 match at this point.
-    (apply (case-lambda
-             ((subr msg args . rest)
-              (if subr
-                  (format port "In procedure ~a: " subr))
-              (apply format port msg (or args '())))
-             (_ (default-printer)))
-           args))
-
-  (define (syntax-error-printer port key args default-printer)
-    (apply (case-lambda
-             ((who what where form subform . extra)
-              (format port "Syntax error:\n")
-              (if where
-                  (let ((file (or (assq-ref where 'filename) "unknown file"))
-                        (line (and=> (assq-ref where 'line) 1+))
-                        (col (assq-ref where 'column)))
-                    (format port "~a:~a:~a: " file line col))
-                  (format port "unknown location: "))
-              (if who
-                  (format port "~a: " who))
-              (format port "~a" what)
-              (if subform
-                  (format port " in subform ~s of ~s" subform form)
-                  (if form
-                      (format port " in form ~s" form))))
-             (_ (default-printer)))
-           args))
-
-  (define (keyword-error-printer port key args default-printer)
-    (let ((message (cadr args))
-          (faulty  (car (cadddr args)))) ; I won't do it again, I promise.
-      (format port "~a: ~s" message faulty)))
-
-  (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 keyword-error-printer)
-  (set-exception-printer! 'misc-error scm-error-printer)
-  (set-exception-printer! 'no-data scm-error-printer)
-  (set-exception-printer! 'no-recovery scm-error-printer)
-  (set-exception-printer! 'null-pointer-error scm-error-printer)
-  (set-exception-printer! 'out-of-memory scm-error-printer)
-  (set-exception-printer! 'out-of-range scm-error-printer)
-  (set-exception-printer! 'program-error scm-error-printer)
-  (set-exception-printer! 'read-error scm-error-printer)
-  (set-exception-printer! 'regular-expression-syntax scm-error-printer)
-  (set-exception-printer! 'signal scm-error-printer)
-  (set-exception-printer! 'stack-overflow scm-error-printer)
-  (set-exception-printer! 'system-error scm-error-printer)
-  (set-exception-printer! 'try-again scm-error-printer)
-  (set-exception-printer! 'unbound-variable 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! 'getaddrinfo-error getaddrinfo-error-printer))
-
 
 
 
@@ -1494,6 +1236,7 @@ VALUE."
 
 
 
+
 ;;; {Parameters}
 ;;;
 
@@ -1544,114 +1287,374 @@ invariants on the values that a parameter may have."
 (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-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* ...)))))))
+
+(define* (fluid->parameter fluid #:optional (conv (lambda (x) x)))
+  "Make a parameter that wraps a fluid.
+
+The value of the parameter will be the same as the value of the fluid.
+If the parameter is rebound in some dynamic extent, perhaps via
+`parameterize', the new value will be run through the optional CONV
+procedure, as with any parameter.  Note that unlike `make-parameter',
+CONV is not applied to the initial value."
+  (make-struct/no-tail
+   <parameter>
+   (case-lambda
+    (() (fluid-ref fluid))
+    ((x) (let ((prev (fluid-ref fluid)))
+           (fluid-set! fluid (conv x))
+           prev)))
+   fluid conv))
+
+
+
+;;; Once parameters have booted, define the default prompt tag as being
+;;; a parameter, and make allow-legacy-syntax-objects? a parameter.
+;;;
+
+(set! default-prompt-tag (make-parameter (default-prompt-tag)))
+
+
+
+;;; {Languages}
+;;;
+
+;; The language can be a symbolic name or a <language> object from
+;; (system base language).
+;;
+(define current-language (make-parameter 'scheme))
+
+
+
+
+;;; {High-Level Port Routines}
+;;;
+
+(define (call-with-output-string proc)
+  "Calls the one-argument procedure @var{proc} with a newly created output
+port.  When the function returns, the string composed of the characters
+written into the port is returned."
+  (let ((port (open-output-string)))
+    (proc port)
+    (get-output-string port)))
+
+
+
+;;; {Booleans}
+;;;
+
+(define (->bool x) (not (not x)))
+
+
+
+;;; {Symbols}
+;;;
+
+(define (symbol-append . args)
+  (string->symbol (apply string-append (map symbol->string args))))
+
+(define (list->symbol . args)
+  (string->symbol (apply list->string args)))
+
+(define (symbol . args)
+  (string->symbol (apply string args)))
+
+
+
+;;; {Lists}
+;;;
+
+(define (list-index l k)
+  (let loop ((n 0)
+             (l l))
+    (and (not (null? l))
+         (if (eq? (car l) k)
+             n
+             (loop (+ n 1) (cdr l))))))
+
+
+
+;; Define catch and with-throw-handler, using some common helper routines and a
+;; shared fluid. Hide the helpers in a lexical contour.
+
+(define with-throw-handler #f)
+(let ((%eh (module-ref (current-module) '%exception-handler)))
+  (define (make-exception-handler catch-key prompt-tag pre-unwind)
+    (vector catch-key prompt-tag pre-unwind))
+  (define (exception-handler-catch-key handler) (vector-ref handler 0))
+  (define (exception-handler-prompt-tag handler) (vector-ref handler 1))
+  (define (exception-handler-pre-unwind handler) (vector-ref handler 2))
+
+  (define %running-pre-unwind (make-fluid #f))
+  (define (pre-unwind-handler-running? handler)
+    (let lp ((depth 0))
+      (let ((running (fluid-ref* %running-pre-unwind depth)))
+        (and running
+             (or (eq? running handler) (lp (1+ depth)))))))
+
+  (define (dispatch-exception depth key args)
+    (cond
+     ((fluid-ref* %eh depth)
+      => (lambda (handler)
+           (let ((catch-key (exception-handler-catch-key handler)))
+             (if (or (eqv? catch-key #t) (eq? catch-key key))
+                 (let ((prompt-tag (exception-handler-prompt-tag handler))
+                       (pre-unwind (exception-handler-pre-unwind handler)))
+                   (cond
+                    ((and pre-unwind
+                          (not (pre-unwind-handler-running? handler)))
+                     ;; Prevent errors from within the pre-unwind
+                     ;; handler's invocation from being handled by this
+                     ;; handler.
+                     (with-fluid* %running-pre-unwind handler
+                       (lambda ()
+                         ;; FIXME: Currently the "running" flag only
+                         ;; applies to the pre-unwind handler; the
+                         ;; post-unwind handler is still called if the
+                         ;; error is explicitly rethrown.  Instead it
+                         ;; would be better to cause a recursive throw to
+                         ;; skip all parts of this handler.  Unfortunately
+                         ;; that is incompatible with existing semantics.
+                         ;; We'll see if we can change that later on.
+                         (apply pre-unwind key args)
+                         (dispatch-exception depth key args))))
+                    (prompt-tag
+                     (apply abort-to-prompt prompt-tag key args))
+                    (else
+                     (dispatch-exception (1+ depth) key args))))
+                 (dispatch-exception (1+ depth) key args)))))
+     ((eq? key 'quit)
+      (primitive-exit (cond
+                       ((not (pair? args)) 0)
+                       ((integer? (car args)) (car args))
+                       ((not (car args)) 1)
+                       (else 0))))
+     (else
+      (format (current-error-port) "guile: uncaught throw to ~a: ~a\n"
+              key args)
+      (primitive-exit 1))))
+
+  (define (throw key . args)
+    "Invoke the catch form matching @var{key}, passing @var{args} to the
+@var{handler}.
 
-(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)))
+@var{key} is a symbol. It will match catches of the same symbol or of 
@code{#t}.
 
-(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* ...)))))))
+If there is no handler at all, Guile prints an error and then exits."
+    (unless (symbol? key)
+      (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a"
+             (list 1 key) (list key)))
+    (dispatch-exception 0 key args))
 
-(define* (fluid->parameter fluid #:optional (conv (lambda (x) x)))
-  "Make a parameter that wraps a fluid.
+  (define* (catch k thunk handler #:optional pre-unwind-handler)
+    "Invoke @var{thunk} in the dynamic context of @var{handler} for
+exceptions matching @var{key}.  If thunk throws to the symbol
+@var{key}, then @var{handler} is invoked this way:
+@lisp
+ (handler key args ...)
+@end lisp
 
-The value of the parameter will be the same as the value of the fluid.
-If the parameter is rebound in some dynamic extent, perhaps via
-`parameterize', the new value will be run through the optional CONV
-procedure, as with any parameter.  Note that unlike `make-parameter',
-CONV is not applied to the initial value."
-  (make-struct/no-tail
-   <parameter>
-   (case-lambda
-    (() (fluid-ref fluid))
-    ((x) (let ((prev (fluid-ref fluid)))
-           (fluid-set! fluid (conv x))
-           prev)))
-   fluid conv))
+@var{key} is a symbol or @code{#t}.
 
-
+@var{thunk} takes no arguments.  If @var{thunk} returns
+normally, that is the return value of @code{catch}.
 
-;;; Once parameters have booted, define the default prompt tag as being
-;;; a parameter, and make allow-legacy-syntax-objects? a parameter.
-;;;
+Handler is invoked outside the scope of its own @code{catch}.
+If @var{handler} again throws to the same key, a new handler
+from further up the call chain is invoked.
 
-(set! default-prompt-tag (make-parameter (default-prompt-tag)))
+If the key is @code{#t}, then a throw to @emph{any} symbol will
+match this call to @code{catch}.
 
-
+If a @var{pre-unwind-handler} is given and @var{thunk} throws
+an exception that matches @var{key}, Guile calls the
+@var{pre-unwind-handler} before unwinding the dynamic state and
+invoking the main @var{handler}.  @var{pre-unwind-handler} should
+be a procedure with the same signature as @var{handler}, that
+is @code{(lambda (key . args))}.  It is typically used to save
+the stack at the point where the exception occurred, but can also
+query other parts of the dynamic state at that point, such as
+fluid values.
 
-;;; {Languages}
-;;;
+A @var{pre-unwind-handler} can exit either normally or non-locally.
+If it exits normally, Guile unwinds the stack and dynamic context
+and then calls the normal (third argument) handler.  If it exits
+non-locally, that exit determines the continuation."
+    (define (wrong-type-arg n val)
+      (scm-error 'wrong-type-arg "catch"
+                 "Wrong type argument in position ~a: ~a"
+                 (list n val) (list val)))
+    (unless (or (symbol? k) (eqv? k #t))
+      (wrong-type-arg 1 k))
+    (unless (procedure? handler)
+      (wrong-type-arg 3 handler))
+    (unless (or (not pre-unwind-handler) (procedure? pre-unwind-handler))
+      (wrong-type-arg 4 pre-unwind-handler))
+    (let ((tag (make-prompt-tag "catch")))
+      (call-with-prompt
+       tag
+       (lambda ()
+         (with-fluid* %eh (make-exception-handler k tag pre-unwind-handler)
+           thunk))
+       (lambda (cont k . args)
+         (apply handler k args)))))
 
-;; The language can be a symbolic name or a <language> object from
-;; (system base language).
-;;
-(define current-language (make-parameter 'scheme))
+  (define (with-throw-handler k thunk pre-unwind-handler)
+    "Add @var{handler} to the dynamic context as a throw handler
+for key @var{k}, then invoke @var{thunk}."
+    (if (not (or (symbol? k) (eqv? k #t)))
+        (scm-error 'wrong-type-arg "with-throw-handler"
+                   "Wrong type argument in position ~a: ~a"
+                   (list 1 k) (list k)))
+    (with-fluid* %eh (make-exception-handler k #f pre-unwind-handler)
+      thunk))
 
+  (hashq-remove! (%get-pre-modules-obarray) '%exception-handler)
+  (define! 'catch catch)
+  (define! 'with-throw-handler with-throw-handler)
+  (define! 'throw throw))
 
 
 
-;;; {High-Level Port Routines}
+;;;
+;;; Extensible exception printing.
 ;;;
 
-(define (call-with-output-string proc)
-  "Calls the one-argument procedure @var{proc} with a newly created output
-port.  When the function returns, the string composed of the characters
-written into the port is returned."
-  (let ((port (open-output-string)))
-    (proc port)
-    (get-output-string port)))
+(define set-exception-printer! #f)
+;; There is already a definition of print-exception from backtrace.c
+;; that we will override.
 
-
+(let ((exception-printers '()))
+  (define (print-location frame port)
+    (let ((source (and=> frame frame-source)))
+      ;; source := (addr . (filename . (line . column)))
+      (if source
+          (let ((filename (or (cadr source) "<unnamed port>"))
+                (line (caddr source))
+                (col (cdddr source)))
+            (format port "~a:~a:~a: " filename (1+ line) col))
+          (format port "ERROR: "))))
 
-;;; {Booleans}
-;;;
+  (set! set-exception-printer!
+        (lambda (key proc)
+          (set! exception-printers (acons key proc exception-printers))))
 
-(define (->bool x) (not (not x)))
+  (set! print-exception
+        (lambda (port frame key args)
+          (define (default-printer)
+            (format port "Throw to key `~a' with args `~s'." key args))
 
-
+          (when frame
+            (print-location frame port)
+            ;; When booting, false-if-exception isn't defined yet.
+            (let ((name (catch #t
+                          (lambda () (frame-procedure-name frame))
+                          (lambda _ #f))))
+              (when name
+                (format port "In procedure ~a:\n" name))))
+
+          (catch #t
+            (lambda ()
+              (let ((printer (assq-ref exception-printers key)))
+                (if printer
+                    (printer port key args default-printer)
+                    (default-printer))))
+            (lambda (k . args)
+              (format port "Error while printing exception.")))
+          (newline port)
+          (force-output port))))
 
-;;; {Symbols}
 ;;;
+;;; Printers for those keys thrown by Guile.
+;;;
+(let ()
+  (define (scm-error-printer port key args default-printer)
+    ;; Abuse case-lambda as a pattern matcher, given that we don't have
+    ;; ice-9 match at this point.
+    (apply (case-lambda
+             ((subr msg args . rest)
+              (if subr
+                  (format port "In procedure ~a: " subr))
+              (apply format port msg (or args '())))
+             (_ (default-printer)))
+           args))
 
-(define (symbol-append . args)
-  (string->symbol (apply string-append (map symbol->string args))))
+  (define (syntax-error-printer port key args default-printer)
+    (apply (case-lambda
+             ((who what where form subform . extra)
+              (format port "Syntax error:\n")
+              (if where
+                  (let ((file (or (assq-ref where 'filename) "unknown file"))
+                        (line (and=> (assq-ref where 'line) 1+))
+                        (col (assq-ref where 'column)))
+                    (format port "~a:~a:~a: " file line col))
+                  (format port "unknown location: "))
+              (if who
+                  (format port "~a: " who))
+              (format port "~a" what)
+              (if subform
+                  (format port " in subform ~s of ~s" subform form)
+                  (if form
+                      (format port " in form ~s" form))))
+             (_ (default-printer)))
+           args))
 
-(define (list->symbol . args)
-  (string->symbol (apply list->string args)))
+  (define (keyword-error-printer port key args default-printer)
+    (let ((message (cadr args))
+          (faulty  (car (cadddr args)))) ; I won't do it again, I promise.
+      (format port "~a: ~s" message faulty)))
 
-(define (symbol . args)
-  (string->symbol (apply string 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 keyword-error-printer)
+  (set-exception-printer! 'misc-error scm-error-printer)
+  (set-exception-printer! 'no-data scm-error-printer)
+  (set-exception-printer! 'no-recovery scm-error-printer)
+  (set-exception-printer! 'null-pointer-error scm-error-printer)
+  (set-exception-printer! 'out-of-memory scm-error-printer)
+  (set-exception-printer! 'out-of-range scm-error-printer)
+  (set-exception-printer! 'program-error scm-error-printer)
+  (set-exception-printer! 'read-error scm-error-printer)
+  (set-exception-printer! 'regular-expression-syntax scm-error-printer)
+  (set-exception-printer! 'signal scm-error-printer)
+  (set-exception-printer! 'stack-overflow scm-error-printer)
+  (set-exception-printer! 'system-error scm-error-printer)
+  (set-exception-printer! 'try-again scm-error-printer)
+  (set-exception-printer! 'unbound-variable scm-error-printer)
+  (set-exception-printer! 'wrong-number-of-args scm-error-printer)
+  (set-exception-printer! 'wrong-type-arg scm-error-printer)
 
-;;; {Lists}
-;;;
+  (set-exception-printer! 'syntax-error syntax-error-printer)
+
+  (set-exception-printer! 'getaddrinfo-error getaddrinfo-error-printer))
 
-(define (list-index l k)
-  (let loop ((n 0)
-             (l l))
-    (and (not (null? l))
-         (if (eq? (car l) k)
-             n
-             (loop (+ n 1) (cdr l))))))