[PATCH] Use proper SRFI-35 constructs

[Ludovic Courtès]

Hi,

G-Wrap code uses non-conforming SRFI-35 constructs, notably:

  * `define-class' instead of `define-condition-type', often used to
    create a condition type that inherits from several condition type,
    which is not part of SRFI-35;

  * `is-a?' instead of `condition-has-type?';

  * assumes that `&condition' and other condition types are GOOPS
    classes;

  * use the `handle-condition' method.

The attached patch fixes this.  Since Guile 1.8.3 will be shipped with
a strict SRFI-35 implementation (not GOOPS-based), this patch should
allow G-Wrap to run fine with Guile 1.8.3.

BTW, Andreas, did you have a chance to look at my previous patches?

Thanks,
Ludovic.

# Bazaar revision bundle v0.9
#
# message:
#   Use proper SRFI-35 constructs.
#   
# committer: Ludovic Courtes <address@hidden>
# date: Sat 2007-09-01 13:22:34.372999907 +0200

=== modified file ChangeLog
--- ChangeLog
+++ ChangeLog
@@ -1,3 +1,27 @@
+2007-09-01  Ludovic Courtès  <address@hidden>
+
+       Use proper SRFI-35 constructs.
+
+       * g-wrap.scm (&gw-bad-typespec, &gw-bad-typespec-option,
+       &gw-name-conflict, &gw-stacked): Use `define-condition-type'
+       instead of `define-class'.
+       (gw-handle-condition): New, replacement for the set of
+       `handle-condition' methods.
+       (raise-bad-typespec, raise-bad-typespec-option, raise-stacked):
+       Specify all fields when invoking the `condition' macro, as
+       required per SRFI-35.
+       (make-typespec): Use `condition-has-type?' instead of `is-a?'.
+       (generate-wrapset): Use `gw-handle-condition' instead of
+       `handle-condition'.
+
+       * g-wrap/util.scm: Autoload `(g-wrap)'.
+       (&gw-bad-element): Use `define-condition-type'.
+       (guard/handle): Use `gw-handle-condition'.
+       (call-with-output-file/cleanup): Likewise.
+
+       * scheme48/g-wrap/scheme48.scm (generate-packages): Use
+       `gw-handle-condition'.
+
 2007-05-04  Andreas Rottmann  <address@hidden>
 
        Buildsystem update.

=== modified file g-wrap.scm
--- g-wrap.scm
+++ g-wrap.scm
@@ -42,6 +42,7 @@
   (&gw-bad-typespec
    raise-bad-typespec
    raise-stacked
+   gw-handle-condition
    
    <gw-item>
    description
@@ -101,49 +102,63 @@
    get-wrapset generate-wrapset compute-client-types
    ))
 
+
+;;;
 ;;; Conditions
-
-(define-class &gw-bad-typespec (&error &message)
-  (spec #:getter typespec-form #:init-value #f)
-  (type #:getter type #:init-value #f)
-  (options #:getter typespec-options #:init-value #f))
-
-(define-class &gw-bad-typespec-option (&error &message)
-  (option #:getter typespec-option))
-
-(define-class &gw-name-conflict (&error &message)
-  (name #:getter conflicting-name)
-  (namespace #:getter conflict-namespace))
-
-(define-class &gw-stacked (&message)
-  (next #:getter next-condition))
+;;;
+
+(define-condition-type &gw-bad-typespec &error
+  gw-bad-typespec-error?
+  (spec    bad-typespec-form)
+  (type    bad-typespec-type)
+  (options bad-typespec-options)
+  (message bad-typespec-message))
+
+(define-condition-type &gw-bad-typespec-option &error
+  gw-bad-typespec-option-error?
+  (option  bad-typespec-option)
+  (message bad-typespec-option-message))
+
+(define-condition-type &gw-name-conflict &error
+  gw-name-conflict-error?
+  (name        conflicting-name)
+  (namespace   conflicting-namespace)
+  (message     name-conflict-message))
+
+(define-condition-type &gw-stacked &error
+  gw-stacked-error?
+  (next    stacked-error-next-condition)
+  (message stacked-error-message))
 
 (define-method (format-error msg . args)
   (display "g-wrap: " (current-error-port))
   (apply format (current-error-port) msg args)
   (newline (current-error-port)))
 
-(define-method (handle-condition (c &gw-stacked))
-  (format-error "~A:" (condition-message c))
-  (handle-condition (next-condition c)))
-
-(define-method (handle-condition (c &gw-bad-typespec))
-  (cond
-   ((type c)
-    (format-error "bad typespec `~A ~A': ~A"
-                  (type c) (typespec-options c) (condition-message c)))
-   (else
-    (format-error "bad typespec `~A': ~A" (typespec-form c)
-                  (condition-message c)))))
-
-(define-method (handle-condition (c &gw-bad-element))
-  (format-error "bad element ~S in tree ~S" (element c) (tree c)))
-
-(define-method (handle-condition (c &gw-name-conflict))
-  (format-error "name conflict: ~A in namespace ~A: ~A"
-                (conflicting-name c) (conflict-namespace c)
-                (condition-message c)))
-
+(define (gw-handle-condition c)
+  (cond ((condition-has-type? c &gw-stacked)
+         (format-error "~A:" (gw-stacked-error-message c))
+         (gw-handle-condition (stacked-error-next-condition c)))
+        ((condition-has-type? c &gw-bad-typespec)
+         (cond
+          ((bad-typespec-type c)
+           (format-error "bad typespec `~A ~A': ~A"
+                         (type c) (typespec-options c) (bad-typespec-message 
c)))
+          (else
+           (format-error "bad typespec `~A': ~A" (bad-typespec-form c)
+                         (bad-typespec-message c)))))
+        ((gw-bad-element-error? c)
+         (format-error "bad element ~S in tree ~S"
+                       (bad-element c) (bad-element-tree c)))
+        ((gw-name-conflict-error? c)
+         (format-error "name conflict: ~A in namespace ~A: ~A"
+                       (conflicting-name c) (conflict-namespace c)
+                       (name-conflict-message c)))
+        (else
+         (format-error "unhandled error condition: ~A" c))))
+
+
+
 ;;;
 
 ;; An <gw-item> is "something" that shows up in the generated
@@ -202,31 +217,38 @@
                              (symbol->string
                               (name type))) "_" suffix)))
 
+
+;;;
+;;; Raising error conditions
+;;;
+
 ;; Here because needs <gw-type>
 (define-method (raise-bad-typespec type (options <list>) (msg <string>) . args)
   (raise (condition
           (&gw-bad-typespec
-           (type type) (options options)
+           (spec #f) (type type) (options options)
            (message (apply format #f msg args))))))
 
 (define-method (raise-bad-typespec spec (msg <string>) . args)
   (raise (condition
           (&gw-bad-typespec
-           (spec spec)
+           (spec spec) (type #f) (options #f)
            (message (apply format #f msg args))))))
 
 (define-method (raise-bad-typespec-option option (msg <string>) . args)
   (raise (condition
           (&gw-bad-typespec-option
-           (option option)
+           (spec #f) (type #f) (option option)
            (message (apply format #f msg args))))))
 
-(define-method (raise-stacked (next &condition) (msg <string>) . args)
+(define-method (raise-stacked next (msg <string>) . args)
+  ;; NEXT should be a condition.
   (raise (condition
           (&gw-stacked
            (next next)
            (message (apply format #f msg args))))))
-  
+
+
 ;;;
 ;;; Values
 ;;;
@@ -367,10 +389,10 @@
   (check-typespec-options type options)
   (guard
    (c
-    ((is-a? c &gw-bad-typespec-option)
+    ((condition-has-type? c &gw-bad-typespec-option)
      (raise-bad-typespec type options "bad typespec option ~S: ~A"
-                         (typespec-option c)
-                         (condition-message c))))
+                         (bad-typespec-option c)
+                         (bad-typespec-message c))))
    (let ((typespec (make <gw-typespec> #:type type)))
      (for-each (lambda (opt) (parse-typespec-option! typespec type opt))
                options)
@@ -799,7 +821,7 @@
   (let ((had-error? #f))
     (guard
      (c
-      (#t (handle-condition c)
+      (#t (gw-handle-condition c)
           (set! had-error? #t)))
      (generate-wrapset lang (get-wrapset lang name) basename))
     (if had-error?

=== modified file g-wrap/util.scm
--- g-wrap/util.scm
+++ g-wrap/util.scm
@@ -32,10 +32,14 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (oop goops)
-  
+
+  ;; XXX: This introduces a circular dependency, but `autoload' allows us to
+  ;; work around it.
+  #:autoload   (g-wrap)       (gw-handle-condition)
+
   #:export
-  (&gw-bad-element
-   element tree
+  (&gw-bad-element gw-bad-element-error?
+   bad-element bad-element-tree
 
    call-with-output-file/cleanup
    slot-push!
@@ -51,15 +55,16 @@
 
 ;;; Condition stuff
 
-(define-class &gw-bad-element (&error)
-  (element #:getter element)
-  (tree #:getter tree))
+(define-condition-type &gw-bad-element &error
+  gw-bad-element-error?
+  (element  bad-element)
+  (tree     bad-element-tree))
 
 (define-macro (guard/handle . body)
   (let ((cond-name (gensym)))
     `(guard
       (,cond-name
-       (else (handle-condition ,cond-name)))
+       (else (gw-handle-condition ,cond-name)))
       ,@body)))
 
 ;;; General utilities
@@ -77,7 +82,7 @@
          (c
           ((condition-has-type? c &error)
            (set! had-errors? #t)
-           (handle-condition c)))
+           (gw-handle-condition c)))
          
          (call-with-output-file file-name proc)))
          

=== modified file scheme48/g-wrap/scheme48.scm
--- scheme48/g-wrap/scheme48.scm
+++ scheme48/g-wrap/scheme48.scm
@@ -240,7 +240,7 @@
         (basedir (dirname filename)))
     (guard
      (c
-      (#t (handle-condition c)
+      (#t (gw-handle-condition c)
           (set! had-error? #t)))
      (let ((wrapsets (map (lambda (name) (get-wrapset 'scheme48 name)) 
ws-names)))
        (call-with-output-file/cleanup filename

=== modified directory  // last-changed:address@hidden
... 78u
# revision id: address@hidden
# sha1: a24de442febbd27e80362272657453807bcdbbff
# inventory sha1: 5c6c33a5e2bf2627ed7c2c582d96daa3ccda72a3
# parent ids:
#   address@hidden
# base id: address@hidden
# properties:
#   branch-nick: g-wrap