summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-11-03 21:36:39 +0100
committerAndy Wingo <wingo@pobox.com>2019-11-03 21:36:39 +0100
commit90d52a9e1dd6419e0fef13e7b09e284e9d895920 (patch)
treeff43795e17828ce734d118e308d6d1d296ba1721
parent9f1a6717349ce3a6c1617dd7d606bc02386f1183 (diff)
downloadguile-90d52a9e1dd6419e0fef13e7b09e284e9d895920.tar.gz
Add `record-type-has-parent?'.
* module/ice-9/boot-9.scm (record-type-has-parent?): New function. * module/srfi/srfi-35.scm (condition-type?): Use it.
-rw-r--r--module/ice-9/boot-9.scm6
-rw-r--r--module/srfi/srfi-35.scm8
2 files changed, 8 insertions, 6 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index dcff0ed7a..3b98aaf75 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1241,6 +1241,12 @@ VALUE."
(nparents (vector-length parents)))
(and (not (zero? nparents))
(vector-ref parents (1- nparents)))))
+(define (record-type-has-parent? rtd parent)
+ (or (eq? rtd parent)
+ (let ((parents (record-type-parents rtd))
+ (nparents (vector-length (record-type-parents parent))))
+ (and (< nparents (vector-length parents))
+ (eq? (vector-ref parents nparents) parent)))))
(define (record-type-mutable-fields rtd)
(unless (record-type? rtd)
diff --git a/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm
index e4246bb7d..73e9394ef 100644
--- a/module/srfi/srfi-35.scm
+++ b/module/srfi/srfi-35.scm
@@ -77,12 +77,8 @@ supertypes."
(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))))))
+ (and (record-type? obj)
+ (record-type-has-parent? obj &condition)))
(define simple-condition?
(record-predicate &condition))