[Guile-commits] GNU Guile branch, branch_release-1-8, updated. release_1-8-7-13-ga0f8a73

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a0f8a73f283ca8e5532090a137c95546836ddd4d

The branch, branch_release-1-8 has been updated
       via  a0f8a73f283ca8e5532090a137c95546836ddd4d (commit)
       via  bb9c5bbd2eb34d026521a4b99ee746ec3f335865 (commit)
       via  f9e8030266121b0b48e1665fe6fb699a0ca2c1ad (commit)
       via  ef171ff0392d265b926bf0e1cf153b28b7c0689c (commit)
      from  84a54b292d30e94c6980caf61bc0450ff4ba3ac8 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit a0f8a73f283ca8e5532090a137c95546836ddd4d
Author: Ludovic Courtès <address@hidden>
Date:   Mon Oct 26 21:39:13 2009 +0100

    Update `NEWS'.

commit bb9c5bbd2eb34d026521a4b99ee746ec3f335865
Author: Ludovic Courtès <address@hidden>
Date:   Sun Oct 25 22:49:28 2009 +0100

    Add GOOPS `class-of' test for nameless structs.
    
    * test-suite/tests/goops.test ("classes for built-in types")["struct
      vtable"]: New test case.

commit f9e8030266121b0b48e1665fe6fb699a0ca2c1ad
Author: Ludovic Courtès <address@hidden>
Date:   Sun Oct 25 22:57:29 2009 +0100

    SRFI-35: Provide nice vtable names, to make GOOPS happier.
    
    * module/srfi/srfi-35.scm (%make-condition-type): New procedure.
      (make-condition-type, make-compound-condition-type): Use it.
    
    * test-suite/tests/srfi-35.test ("condition
      types")["struct-vtable-name"]: New test.

commit ef171ff0392d265b926bf0e1cf153b28b7c0689c
Author: Ludovic Courtès <address@hidden>
Date:   Mon Oct 26 19:03:26 2009 +0100

    Fix unbound variable references in `srfi-19.scm'.
    
    * module/srfi/srfi-19.scm: Use `(ice-9 rdelim)'.
      (date->broken-down-time, priv:year-day, priv:char->int): Fix typo.
      (time-*->time-*, time-*->time-*!): Fix reference to unbound variable
      `caller'.

-----------------------------------------------------------------------

Summary of changes:
 NEWS                          |    2 ++
 srfi/srfi-19.scm              |   37 +++++++++++++++++++++++--------------
 srfi/srfi-35.scm              |   30 +++++++++++++++++++-----------
 test-suite/tests/goops.test   |    7 ++++++-
 test-suite/tests/srfi-35.test |    8 ++++++--
 5 files changed, 56 insertions(+), 28 deletions(-)

diff --git a/NEWS b/NEWS
index 9d84e06..7082960 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,8 @@ Changes in 1.8.8 (since 1.8.7)
 ** Avoid clash with system setjmp/longjmp on IA64
 ** Don't dynamically link an extension that is already registered
 ** Fix `wrong type arg' exceptions with IPv6 addresses
+** Fix typos in `(srfi srfi-19)'
+** Have `(srfi srfi-35)' provide named struct vtables
 
 
 Changes in 1.8.7 (since 1.8.6)
diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm
index ffce990..482ec4e 100644
--- a/srfi/srfi-19.scm
+++ b/srfi/srfi-19.scm
@@ -1,6 +1,6 @@
 ;;; srfi-19.scm --- Time/Date Library
 
-;;     Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008 Free Software 
Foundation, Inc.
+;;     Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009 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
@@ -41,7 +41,8 @@
 (define-module (srfi srfi-19)
   :use-module (srfi srfi-6)
   :use-module (srfi srfi-8)
-  :use-module (srfi srfi-9))
+  :use-module (srfi srfi-9)
+  :autoload   (ice-9 rdelim) (read-line))
 
 (begin-deprecated
  ;; Prevent `export' from re-exporting core bindings.  This behaviour
@@ -339,7 +340,7 @@
     (set-tm:hour result (date-hour date))
     ;; FIXME: SRFI day ranges from 0-31.  (not compatible with set-tm:mday).
     (set-tm:mday result (date-day date))
-    (set-tm:month result (- (date-month date) 1))
+    (set-tm:mon result (- (date-month date) 1))
     ;; FIXME: need to signal error on range violation.
     (set-tm:year result (+ 1900 (date-year date)))
     (set-tm:isdst result -1)
@@ -528,33 +529,38 @@
 ;; -- these depend on time-monotonic having the same definition as time-tai!
 (define (time-monotonic->time-utc time-in)
   (if (not (eq? (time-type time-in) time-monotonic))
-      (priv:time-error caller 'incompatible-time-types time-in))
+      (priv:time-error 'time-monotonic->time-utc
+                       'incompatible-time-types time-in))
   (let ((ntime (copy-time time-in)))
     (set-time-type! ntime time-tai)
     (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)))
 
 (define (time-monotonic->time-utc! time-in)
   (if (not (eq? (time-type time-in) time-monotonic))
-      (priv:time-error caller 'incompatible-time-types time-in))
+      (priv:time-error 'time-monotonic->time-utc!
+                       'incompatible-time-types time-in))
   (set-time-type! time-in time-tai)
-  (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))
+  (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc))
 
 (define (time-monotonic->time-tai time-in)
   (if (not (eq? (time-type time-in) time-monotonic))
-      (priv:time-error caller 'incompatible-time-types time-in))
+      (priv:time-error 'time-monotonic->time-tai
+                       'incompatible-time-types time-in))
   (let ((ntime (copy-time time-in)))
     (set-time-type! ntime time-tai)
     ntime))
 
 (define (time-monotonic->time-tai! time-in)
   (if (not (eq? (time-type time-in) time-monotonic))
-      (priv:time-error caller 'incompatible-time-types time-in))
+      (priv:time-error 'time-monotonic->time-tai!
+                       'incompatible-time-types time-in))
   (set-time-type! time-in time-tai)
   time-in)
 
 (define (time-utc->time-monotonic time-in)
   (if (not (eq? (time-type time-in) time-utc))
-      (priv:time-error caller 'incompatible-time-types time-in))
+      (priv:time-error 'time-utc->time-monotonic
+                       'incompatible-time-types time-in))
   (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f 
#f)
                                          'time-utc->time-monotonic)))
     (set-time-type! ntime time-monotonic)
@@ -562,7 +568,8 @@
 
 (define (time-utc->time-monotonic! time-in)
   (if (not (eq? (time-type time-in) time-utc))
-      (priv:time-error caller 'incompatible-time-types time-in))
+      (priv:time-error 'time-utc->time-monotonic!
+                       'incompatible-time-types time-in))
   (let ((ntime (priv:time-utc->time-tai! time-in time-in
                                          'time-utc->time-monotonic!)))
     (set-time-type! ntime time-monotonic)
@@ -570,14 +577,16 @@
 
 (define (time-tai->time-monotonic time-in)
   (if (not (eq? (time-type time-in) time-tai))
-      (priv:time-error caller 'incompatible-time-types time-in))
+      (priv:time-error 'time-tai->time-monotonic
+                       'incompatible-time-types time-in))
   (let ((ntime (copy-time time-in)))
     (set-time-type! ntime time-monotonic)
     ntime))
 
 (define (time-tai->time-monotonic! time-in)
   (if (not (eq? (time-type time-in) time-tai))
-      (priv:time-error caller 'incompatible-time-types time-in))
+      (priv:time-error 'time-tai->time-monotonic!
+                       'incompatible-time-types time-in))
   (set-time-type! time-in time-monotonic)
   time-in)
 
@@ -780,7 +789,7 @@
 (define (priv:year-day day month year)
   (let ((days-pr (assoc month priv:month-assoc)))
     (if (not days-pr)
-        (priv:error 'date-year-day 'invalid-month-specification month))
+        (priv:time-error 'date-year-day 'invalid-month-specification month))
     (if (and (priv:leap-year? year) (> month 2))
         (+ day (cdr days-pr) 1)
         (+ day (cdr days-pr)))))
@@ -1263,7 +1272,7 @@
    ((#\8) 8)
    ((#\9) 9)
    (else (priv:time-error 'bad-date-template-string
-                          (list "Non-integer character" ch i)))))
+                          (list "Non-integer character" ch)))))
 
 ;; read an integer upto n characters long on port; upto -> #f is any length
 (define (priv:integer-reader upto port)
diff --git a/srfi/srfi-35.scm b/srfi/srfi-35.scm
index 2035466..ee20a10 100644
--- a/srfi/srfi-35.scm
+++ b/srfi/srfi-35.scm
@@ -57,6 +57,19 @@
                                    (number->string (object-address ct)
                                                    16))))))
 
+(define (%make-condition-type layout id parent all-fields)
+  (let ((struct (make-struct %condition-type-vtable 0
+                             (make-struct-layout layout) ;; layout
+                             print-condition             ;; printer
+                             id parent all-fields)))
+
+    ;; Hack to associate STRUCT with a name, providing a better name for
+    ;; GOOPS classes as returned by `class-of' et al.
+    (set-struct-vtable-name! struct (cond ((symbol? id) id)
+                                          ((string? id) (string->symbol id))
+                                          (else         (string->symbol ""))))
+    struct))
+
 (define (condition-type? obj)
   "Return true if OBJ is a condition type."
   (and (struct? obj)
@@ -104,10 +117,8 @@ supertypes."
                                               field-names parent-fields)))
                (let* ((all-fields (append parent-fields field-names))
                       (layout     (struct-layout-for-condition all-fields)))
-                 (make-struct %condition-type-vtable 0
-                              (make-struct-layout layout) ;; layout
-                              print-condition             ;; printer
-                              id parent all-fields))
+                 (%make-condition-type layout
+                                        id parent all-fields))
                (error "invalid condition type field names"
                       field-names)))
          (error "parent is not a condition type" parent))
@@ -126,13 +137,10 @@ supertypes."
          (let* ((all-fields (append-map condition-type-all-fields
                                         parents))
                 (layout     (struct-layout-for-condition all-fields)))
-           (make-struct %condition-type-vtable 0
-                        (make-struct-layout layout) ;; layout
-                        print-condition             ;; printer
-                        id
-                        parents                     ;; list of parents!
-                        all-fields
-                        all-fields)))))
+           (%make-condition-type layout
+                                 id
+                                 parents         ;; list of parents!
+                                 all-fields)))))
 
 
 ;;;
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index fa53fd2..fb2535a 100644
--- a/test-suite/tests/goops.test
+++ b/test-suite/tests/goops.test
@@ -140,7 +140,12 @@
     (eq? (class-of "foo") <string>))
 
   (pass-if "port"
-    (is-a? (%make-void-port "w") <port>)))
+    (is-a? (%make-void-port "w") <port>))
+
+  (pass-if "struct vtable"
+    ;; Previously, `class-of' would fail for nameless structs, i.e., structs
+    ;; for which `struct-vtable-name' is #f.
+    (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>)))
 
 
 (with-test-prefix "defining classes"
diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test
index 83efd61..9fed28b 100644
--- a/test-suite/tests/srfi-35.test
+++ b/test-suite/tests/srfi-35.test
@@ -1,7 +1,7 @@
 ;;;; srfi-35.test --- Test suite for SRFI-35               -*- Scheme -*-
 ;;;; Ludovic Courtès <address@hidden>
 ;;;;
-;;;;   Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
 ;;;;
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -34,7 +34,11 @@
     (condition-type? &condition))
 
   (pass-if "make-condition-type"
-    (condition-type? (make-condition-type 'foo &condition '(a b)))))
+    (condition-type? (make-condition-type 'foo &condition '(a b))))
+
+  (pass-if "struct-vtable-name"
+    (let ((ct  (make-condition-type 'chbouib &condition '(a b))))
+      (eq? 'chbouib (struct-vtable-name ct)))))
 
 
 


hooks/post-receive
-- 
GNU Guile