Rebase srfi-35 conditions on top of make-record-type

* module/srfi/srfi-35.scm: Import (ice-9 match), and remove now-unused
  srfi-1 import.
  (print-condition): Print more like records, as appears to be the
  intention.
  (&condition): Define using make-record-type.  Adapt all callers.
  Also, compound conditions are now a disjoint type, handled specially
  by condition-ref, condition?, and so on.
* test-suite/tests/srfi-35.test (v3): Fix an error in which a
  subcondition was initialized without initializers for all of its
  fields.

1 files changed, 135 insertions, 231 deletions

diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index 626026d74..ffb372632 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -27,7 +27,7 @@
 ;;; Code:
 
 (define-module (srfi srfi-35)
-  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 match)
   #:export (make-condition-type condition-type?
             make-condition condition? condition-has-type? condition-ref
             make-compound-condition extract-condition
@@ -44,250 +44,166 @@
 ;;; Condition types.
 ;;;
 
-(define %condition-type-vtable
-  ;; The vtable of all condition types.
-  ;;   user fields:   id, parent, all-field-names
-  (let ((s (make-vtable (string-append standard-vtable-fields "pwpwpw")
-                        (lambda (ct port)
-                          (format port "#<condition-type ~a ~a>"
-                                  (condition-type-id ct)
-                                  (number->string (object-address ct)
-                                                  16))))))
-    (set-struct-vtable-name! s 'condition-type)
-    s))
-
-(define (%make-condition-type layout id parent all-fields)
-  (let ((struct (make-struct/no-tail %condition-type-vtable
-                                     (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)
-       (eq? (struct-vtable obj)
-	    %condition-type-vtable)))
-
-(define (condition-type-id ct)
-  (and (condition-type? ct)
-       (struct-ref ct (+ vtable-offset-user 0))))
-
-(define (condition-type-parent ct)
-  (and (condition-type? ct)
-       (struct-ref ct (+ vtable-offset-user 1))))
-
-(define (condition-type-all-fields ct)
-  (and (condition-type? ct)
-       (struct-ref ct (+ vtable-offset-user 2))))
-
-
-(define (struct-layout-for-condition field-names)
-  ;; Return a string denoting the layout required to hold the fields listed
-  ;; in FIELD-NAMES.
-  (let loop ((field-names field-names)
-	     (layout      '("pw")))
-    (if (null? field-names)
-	(string-concatenate/shared layout)
-	(loop (cdr field-names)
-	      (cons "pw" layout)))))
-
-(define (print-condition c port)
-  ;; Print condition C to PORT in a way similar to how records print:
-  ;; #<condition TYPE [FIELD: VALUE ...] ADDRESS>.
-  (define (field-values)
-    (let* ((type    (struct-vtable c))
-           (strings (fold (lambda (field result)
-                            (cons (format #f "~A: ~S" field
-                                          (condition-ref c field))
-                                  result))
-                          '()
-                          (condition-type-all-fields type))))
-      (string-join (reverse strings) " ")))
-
-  (format port "#<condition ~a [~a] ~a>"
-          (condition-type-id (condition-type c))
-          (field-values)
-          (number->string (object-address c) 16)))
+;; Like default-record-printer, but prefixed with "condition ":
+;; #<condition TYPE FIELD: VALUE ...>.
+(define (print-condition c p)
+  (display "#<condition " p)
+  (display (record-type-name (record-type-descriptor c)) p)
+  (let loop ((fields (record-type-fields (record-type-descriptor c)))
+             (off 0))
+    (match fields
+      (() (display ">" p))
+      ((field . fields)
+       (display " " p)
+       (display field p)
+       (display ": " p)
+       (display (struct-ref c off) p)
+       (loop fields (+ 1 off))))))
+
+;; FIXME: Perhaps use a `define-record-type' which allows for parent types.
+(define &condition
+  (make-record-type '&condition '() print-condition #:final? #f))
 
 (define (make-condition-type id parent field-names)
-  "Return a new condition type named ID, inheriting from PARENT, and with the
-fields whose names are listed in FIELD-NAMES.  FIELD-NAMES must be a list of
-symbols and must not contain names already used by PARENT or one of its
+  "Return a new condition type named @var{id}, inheriting from
+@var{parent}, and with the fields whose names are listed in
+@var{field-names}.  @var{field-names} must be a list of symbols and must
+not contain names already used by @var{parent} or one of its
 supertypes."
-  (if (symbol? id)
-      (if (condition-type? parent)
-	  (let ((parent-fields (condition-type-all-fields parent)))
-	    (if (and (every symbol? field-names)
-		     (null? (lset-intersection eq?
-					       field-names parent-fields)))
-		(let* ((all-fields (append parent-fields field-names))
-		       (layout     (struct-layout-for-condition 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))
-      (error "condition type identifier is not a symbol" id)))
-
-(define (make-compound-condition-type id parents)
-  ;; Return a compound condition type made of the types listed in PARENTS.
-  ;; All fields from PARENTS are kept, even same-named ones, since they are
-  ;; needed by `extract-condition'.
-  (cond ((null? parents)
-         (error "`make-compound-condition-type' passed empty parent list"
-                id))
-        ((null? (cdr parents))
-         (car parents))
-        (else
-         (let* ((all-fields (append-map condition-type-all-fields
-                                        parents))
-                (layout     (struct-layout-for-condition all-fields)))
-           (%make-condition-type layout
-                                 id
-                                 parents         ;; list of parents!
-                                 all-fields)))))
+  (unless (condition-type? parent)
+    (error "parent is not a condition type" parent))
+  (make-record-type id field-names print-condition #:final? #f #:parent parent))
+
+(define (condition-type? obj)
+  "Return true if OBJ is a condition type."
+  ;; FIXME: Use record-type-is-a? or something like that.
+  (or (eq? obj &condition)
+      (and (record-type? obj)
+           (let ((parents (record-type-parents obj)))
+             (and (< 0 (vector-length parents))
+                  (eq? (vector-ref parents 0) &condition))))))
+
+(define simple-condition?
+  (record-predicate &condition))
+
+;; Compound conditions are represented as a disjoint type, as users
+;; never have access to compound condition types.
+(define &compound-condition
+  (make-record-type 'compound-condition '(conditions)))
+(define compound-condition?
+  (record-predicate &compound-condition))
+(define %make-compound-condition
+  (record-constructor &compound-condition))
+(define compound-condition-conditions
+  (record-accessor &compound-condition 'conditions))
 
 
 ;;;
 ;;; Conditions.
 ;;;
 
-(define (condition? c)
-  "Return true if C is a condition."
-  (and (struct? c)
-       (condition-type? (struct-vtable c))))
-
-(define (condition-type c)
-  (and (struct? c)
-       (let ((vtable (struct-vtable c)))
-	 (if (condition-type? vtable)
-	     vtable
-	     #f))))
+(define (condition? obj)
+  "Return true if @var{obj} is a condition."
+  (or (simple-condition? obj)
+      (compound-condition? obj)))
 
 (define (condition-has-type? c type)
   "Return true if condition C has type TYPE."
-  (if (and (condition? c) (condition-type? type))
-      (let loop ((ct (condition-type c)))
-        (or (eq? ct type)
-            (and ct
-                 (let ((parent (condition-type-parent ct)))
-                   (if (list? parent)
-                       (any loop parent) ;; compound condition
-                       (loop (condition-type-parent ct)))))))
-      (throw 'wrong-type-arg "condition-has-type?"
-             "Wrong type argument")))
+  (unless (condition-type? type)
+    (scm-error 'wrong-type-arg "condition-has-type?" "Not a condition type: ~S"
+               (list type) #f))
+  (match c
+    (($ &compound-condition conditions)
+     (or-map (lambda (c) (condition-has-type? c type)) conditions))
+    ((? simple-condition?)
+     ((record-predicate type) c))
+    (_
+     (scm-error 'wrong-type-arg "condition-has-type?" "Not a condition: ~S"
+                (list c) #f))))
+
+;; Precondition: C is a simple condition.
+(define (simple-condition-ref c field-name not-found)
+  (match (list-index (record-type-fields (struct-vtable c)) field-name)
+    (#f (not-found))
+    (pos (struct-ref c pos))))
 
 (define (condition-ref c field-name)
   "Return the value of the field named FIELD-NAME from condition C."
-  (if (condition? c)
-      (if (symbol? field-name)
-	  (let* ((type   (condition-type c))
-		 (fields (condition-type-all-fields type))
-		 (index  (list-index (lambda (name)
-				       (eq? name field-name))
-				     fields)))
-	    (if index
-		(struct-ref c index)
-		(error "invalid field name" field-name)))
-	  (error "field name is not a symbol" field-name))
-      (throw 'wrong-type-arg "condition-ref"
-             "Wrong type argument: ~S" c)))
+  (match c
+    (($ &compound-condition conditions)
+     (let lp ((conditions conditions))
+       (match conditions
+         (() (error "invalid field name" field-name))
+         ((c . conditions)
+          (simple-condition-ref c field-name (lambda () (lp conditions)))))))
+    ((? simple-condition?)
+     (simple-condition-ref c field-name
+                           (lambda ()
+                             (error "invalid field name" field-name))))
+    (_
+     (scm-error 'wrong-type-arg "condition-ref" "Not a condition: ~S"
+                (list c) #f))))
 
 (define (make-condition-from-values type values)
-  (apply make-struct/no-tail type values))
+  (apply make-struct/simple type values))
 
 (define (make-condition type . field+value)
   "Return a new condition of type TYPE with fields initialized as specified
 by FIELD+VALUE, a sequence of field names (symbols) and values."
-  (if (condition-type? type)
-      (let* ((all-fields (condition-type-all-fields type))
-	     (inits      (fold-right (lambda (field inits)
-				       (let ((v (memq field field+value)))
-					 (if (pair? v)
-					     (cons (cadr v) inits)
-					     (error "field not specified"
-						    field))))
-				     '()
-				     all-fields)))
-	(make-condition-from-values type inits))
-      (throw 'wrong-type-arg "make-condition"
-             "Wrong type argument: ~S" type)))
+  (unless (condition-type? type)
+    (scm-error 'wrong-type-arg "make-condition" "Not a condition type: ~S"
+               (list type) #f))
+  (let ((c (make-struct/no-tail type)))
+    (let lp ((inits field+value) (fields (record-type-fields type)))
+      (match inits
+        (()
+         (match fields
+           (() c)
+           ((field . fields)
+            (error "field not specified" field))))
+        (((and (? symbol?) field) value . inits)
+         (unless (memq field fields)
+           (error "unknown field, or duplicate initializer" field))
+         ((record-modifier type field) c value)
+         (lp inits (delq field fields)))
+        (inits
+         (scm-error 'wrong-type-arg "make-condition"
+                    "Bad initializer list tail: ~S"
+                    (list inits) #f))))))
 
 (define (make-compound-condition . conditions)
   "Return a new compound condition composed of CONDITIONS."
-  (let* ((types  (map condition-type conditions))
-	 (ct     (make-compound-condition-type 'compound types))
-	 (inits  (append-map (lambda (c)
-			       (let ((ct (condition-type c)))
-				 (map (lambda (f)
-					(condition-ref c f))
-				      (condition-type-all-fields ct))))
-			     conditions)))
-    (make-condition-from-values ct inits)))
+  (%make-compound-condition
+   (let lp ((conditions conditions))
+     (if (null? conditions)
+         '()
+         (let ((c (car conditions))
+               (conditions (cdr conditions)))
+           (cond
+            ((compound-condition? c)
+             (append (compound-condition-conditions c) (lp conditions)))
+            (else
+             (unless (condition? c)
+               (throw 'wrong-type-arg "make-compound-condition"
+                      "Not a condition: ~S" c))
+             (cons c (lp conditions)))))))))
 
 (define (extract-condition c type)
   "Return a condition of condition type TYPE with the field values specified
 by C."
-
-  (define (first-field-index parents)
-    ;; Return the index of the first field of TYPE within C.
-    (let loop ((parents parents)
-	       (index   0))
-      (let ((parent (car parents)))
-	(cond ((null? parents)
-	       #f)
-	      ((eq? parent type)
-	       index)
-	      ((pair? parent)
-	       (or (loop parent index)
-		   (loop (cdr parents)
-			 (+ index
-			    (apply + (map condition-type-all-fields
-					  parent))))))
-	      (else
-	       (let ((shift (length (condition-type-all-fields parent))))
-		 (loop (cdr parents)
-		       (+ index shift))))))))
-
-  (define (list-fields start-index field-names)
-    ;; Return a list of the form `(FIELD-NAME VALUE...)'.
-    (let loop ((index       start-index)
-	       (field-names field-names)
-	       (result      '()))
-      (if (null? field-names)
-	  (reverse! result)
-	  (loop (+ 1 index)
-		(cdr field-names)
-		(cons* (struct-ref c index)
-		       (car field-names)
-		       result)))))
-
-  (if (and (condition? c) (condition-type? type))
-      (let* ((ct     (condition-type c))
-             (parent (condition-type-parent ct)))
-        (cond ((eq? type ct)
-               c)
-              ((pair? parent)
-               ;; C is a compound condition.
-               (let ((field-index (first-field-index parent)))
-                 ;;(format #t "field-index: ~a ~a~%" field-index
-                 ;;        (list-fields field-index
-                 ;;                     (condition-type-all-fields type)))
-                 (apply make-condition type
-                        (list-fields field-index
-                                     (condition-type-all-fields type)))))
-              (else
-               ;; C does not have type TYPE.
-               #f)))
-      (throw 'wrong-type-arg "extract-condition"
-             "Wrong type argument")))
+  (unless (condition-type? type)
+    (scm-error 'wrong-type-arg "extract-condition" "Not a condition type: ~S"
+               (list type) #f))
+  (match c
+    (($ &compound-condition conditions)
+     (or-map (lambda (c) (extract-condition c type))
+             conditions))
+    ((? simple-condition?)
+     (and ((record-predicate type) c)
+          c))
+    (_
+     (scm-error 'wrong-type-arg "extract-condition" "Not a condition: ~S"
+                (list c) #f))))
 
 
 ;;;
@@ -304,11 +220,6 @@ by C."
       (condition-ref c 'field-name))
     ...))
 
-(define-syntax-rule (compound-condition (type ...) (field ...))
-  ;; Create a compound condition using `make-compound-condition-type'.
-  (condition ((make-compound-condition-type '%compound `(,type ...))
-              field ...)))
-
 (define-syntax condition-instantiation
   ;; Build the `(make-condition type ...)' call.
   (syntax-rules ()
@@ -322,21 +233,14 @@ by C."
     ((_ (type field ...))
      (condition-instantiation type () field ...))
     ((_ (type field ...) ...)
-     (compound-condition (type ...) (field ... ...)))))
+     (make-compound-condition (condition-instantiation type () field ...)
+                              ...))))
 
 
 ;;;
 ;;; Standard condition types.
 ;;;
 
-(define &condition
-  ;; The root condition type.
-  (make-struct/no-tail %condition-type-vtable
-                       (make-struct-layout "")
-                       (lambda (c port)
-                         (display "<&condition>"))
-                       '&condition #f '() '()))
-
 (define-condition-type &message &condition
   message-condition?
   (message condition-message))