mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 05:50:26 +02:00
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.
This commit is contained in:
Andy Wingo
parent
f116bd1009
commit
99a95383cf
2 changed files with 132 additions and 228 deletions
|
|
@ -27,7 +27,7 @@
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(define-module (srfi srfi-35)
|
(define-module (srfi srfi-35)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (ice-9 match)
|
||||||
#:export (make-condition-type condition-type?
|
#:export (make-condition-type condition-type?
|
||||||
make-condition condition? condition-has-type? condition-ref
|
make-condition condition? condition-has-type? condition-ref
|
||||||
make-compound-condition extract-condition
|
make-compound-condition extract-condition
|
||||||
|
|
@ -44,250 +44,166 @@
|
||||||
;;; Condition types.
|
;;; Condition types.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define %condition-type-vtable
|
;; Like default-record-printer, but prefixed with "condition ":
|
||||||
;; The vtable of all condition types.
|
;; #<condition TYPE FIELD: VALUE ...>.
|
||||||
;; user fields: id, parent, all-field-names
|
(define (print-condition c p)
|
||||||
(let ((s (make-vtable (string-append standard-vtable-fields "pwpwpw")
|
(display "#<condition " p)
|
||||||
(lambda (ct port)
|
(display (record-type-name (record-type-descriptor c)) p)
|
||||||
(format port "#<condition-type ~a ~a>"
|
(let loop ((fields (record-type-fields (record-type-descriptor c)))
|
||||||
(condition-type-id ct)
|
(off 0))
|
||||||
(number->string (object-address ct)
|
(match fields
|
||||||
16))))))
|
(() (display ">" p))
|
||||||
(set-struct-vtable-name! s 'condition-type)
|
((field . fields)
|
||||||
s))
|
(display " " p)
|
||||||
|
(display field p)
|
||||||
|
(display ": " p)
|
||||||
|
(display (struct-ref c off) p)
|
||||||
|
(loop fields (+ 1 off))))))
|
||||||
|
|
||||||
(define (%make-condition-type layout id parent all-fields)
|
;; FIXME: Perhaps use a `define-record-type' which allows for parent types.
|
||||||
(let ((struct (make-struct/no-tail %condition-type-vtable
|
(define &condition
|
||||||
(make-struct-layout layout) ;; layout
|
(make-record-type '&condition '() print-condition #:final? #f))
|
||||||
print-condition ;; printer
|
|
||||||
id parent all-fields)))
|
|
||||||
|
|
||||||
;; Hack to associate STRUCT with a name, providing a better name for
|
(define (make-condition-type id parent field-names)
|
||||||
;; GOOPS classes as returned by `class-of' et al.
|
"Return a new condition type named @var{id}, inheriting from
|
||||||
(set-struct-vtable-name! struct (cond ((symbol? id) id)
|
@var{parent}, and with the fields whose names are listed in
|
||||||
((string? id) (string->symbol id))
|
@var{field-names}. @var{field-names} must be a list of symbols and must
|
||||||
(else (string->symbol ""))))
|
not contain names already used by @var{parent} or one of its
|
||||||
struct))
|
supertypes."
|
||||||
|
(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)
|
(define (condition-type? obj)
|
||||||
"Return true if OBJ is a condition type."
|
"Return true if OBJ is a condition type."
|
||||||
(and (struct? obj)
|
;; FIXME: Use record-type-is-a? or something like that.
|
||||||
(eq? (struct-vtable obj)
|
(or (eq? obj &condition)
|
||||||
%condition-type-vtable)))
|
(and (record-type? obj)
|
||||||
|
(let ((parents (record-type-parents obj)))
|
||||||
|
(and (< 0 (vector-length parents))
|
||||||
|
(eq? (vector-ref parents 0) &condition))))))
|
||||||
|
|
||||||
(define (condition-type-id ct)
|
(define simple-condition?
|
||||||
(and (condition-type? ct)
|
(record-predicate &condition))
|
||||||
(struct-ref ct (+ vtable-offset-user 0))))
|
|
||||||
|
|
||||||
(define (condition-type-parent ct)
|
;; Compound conditions are represented as a disjoint type, as users
|
||||||
(and (condition-type? ct)
|
;; never have access to compound condition types.
|
||||||
(struct-ref ct (+ vtable-offset-user 1))))
|
(define &compound-condition
|
||||||
|
(make-record-type 'compound-condition '(conditions)))
|
||||||
(define (condition-type-all-fields ct)
|
(define compound-condition?
|
||||||
(and (condition-type? ct)
|
(record-predicate &compound-condition))
|
||||||
(struct-ref ct (+ vtable-offset-user 2))))
|
(define %make-compound-condition
|
||||||
|
(record-constructor &compound-condition))
|
||||||
|
(define compound-condition-conditions
|
||||||
(define (struct-layout-for-condition field-names)
|
(record-accessor &compound-condition 'conditions))
|
||||||
;; 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)))
|
|
||||||
|
|
||||||
(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
|
|
||||||
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)))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Conditions.
|
;;; Conditions.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define (condition? c)
|
(define (condition? obj)
|
||||||
"Return true if C is a condition."
|
"Return true if @var{obj} is a condition."
|
||||||
(and (struct? c)
|
(or (simple-condition? obj)
|
||||||
(condition-type? (struct-vtable c))))
|
(compound-condition? obj)))
|
||||||
|
|
||||||
(define (condition-type c)
|
|
||||||
(and (struct? c)
|
|
||||||
(let ((vtable (struct-vtable c)))
|
|
||||||
(if (condition-type? vtable)
|
|
||||||
vtable
|
|
||||||
#f))))
|
|
||||||
|
|
||||||
(define (condition-has-type? c type)
|
(define (condition-has-type? c type)
|
||||||
"Return true if condition C has type TYPE."
|
"Return true if condition C has type TYPE."
|
||||||
(if (and (condition? c) (condition-type? type))
|
(unless (condition-type? type)
|
||||||
(let loop ((ct (condition-type c)))
|
(scm-error 'wrong-type-arg "condition-has-type?" "Not a condition type: ~S"
|
||||||
(or (eq? ct type)
|
(list type) #f))
|
||||||
(and ct
|
(match c
|
||||||
(let ((parent (condition-type-parent ct)))
|
(($ &compound-condition conditions)
|
||||||
(if (list? parent)
|
(or-map (lambda (c) (condition-has-type? c type)) conditions))
|
||||||
(any loop parent) ;; compound condition
|
((? simple-condition?)
|
||||||
(loop (condition-type-parent ct)))))))
|
((record-predicate type) c))
|
||||||
(throw 'wrong-type-arg "condition-has-type?"
|
(_
|
||||||
"Wrong type argument")))
|
(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)
|
(define (condition-ref c field-name)
|
||||||
"Return the value of the field named FIELD-NAME from condition C."
|
"Return the value of the field named FIELD-NAME from condition C."
|
||||||
(if (condition? c)
|
(match c
|
||||||
(if (symbol? field-name)
|
(($ &compound-condition conditions)
|
||||||
(let* ((type (condition-type c))
|
(let lp ((conditions conditions))
|
||||||
(fields (condition-type-all-fields type))
|
(match conditions
|
||||||
(index (list-index (lambda (name)
|
(() (error "invalid field name" field-name))
|
||||||
(eq? name field-name))
|
((c . conditions)
|
||||||
fields)))
|
(simple-condition-ref c field-name (lambda () (lp conditions)))))))
|
||||||
(if index
|
((? simple-condition?)
|
||||||
(struct-ref c index)
|
(simple-condition-ref c field-name
|
||||||
(error "invalid field name" field-name)))
|
(lambda ()
|
||||||
(error "field name is not a symbol" field-name))
|
(error "invalid field name" field-name))))
|
||||||
(throw 'wrong-type-arg "condition-ref"
|
(_
|
||||||
"Wrong type argument: ~S" c)))
|
(scm-error 'wrong-type-arg "condition-ref" "Not a condition: ~S"
|
||||||
|
(list c) #f))))
|
||||||
|
|
||||||
(define (make-condition-from-values type values)
|
(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)
|
(define (make-condition type . field+value)
|
||||||
"Return a new condition of type TYPE with fields initialized as specified
|
"Return a new condition of type TYPE with fields initialized as specified
|
||||||
by FIELD+VALUE, a sequence of field names (symbols) and values."
|
by FIELD+VALUE, a sequence of field names (symbols) and values."
|
||||||
(if (condition-type? type)
|
(unless (condition-type? type)
|
||||||
(let* ((all-fields (condition-type-all-fields type))
|
(scm-error 'wrong-type-arg "make-condition" "Not a condition type: ~S"
|
||||||
(inits (fold-right (lambda (field inits)
|
(list type) #f))
|
||||||
(let ((v (memq field field+value)))
|
(let ((c (make-struct/no-tail type)))
|
||||||
(if (pair? v)
|
(let lp ((inits field+value) (fields (record-type-fields type)))
|
||||||
(cons (cadr v) inits)
|
(match inits
|
||||||
(error "field not specified"
|
(()
|
||||||
field))))
|
(match fields
|
||||||
'()
|
(() c)
|
||||||
all-fields)))
|
((field . fields)
|
||||||
(make-condition-from-values type inits))
|
(error "field not specified" field))))
|
||||||
(throw 'wrong-type-arg "make-condition"
|
(((and (? symbol?) field) value . inits)
|
||||||
"Wrong type argument: ~S" type)))
|
(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)
|
(define (make-compound-condition . conditions)
|
||||||
"Return a new compound condition composed of CONDITIONS."
|
"Return a new compound condition composed of CONDITIONS."
|
||||||
(let* ((types (map condition-type conditions))
|
(%make-compound-condition
|
||||||
(ct (make-compound-condition-type 'compound types))
|
(let lp ((conditions conditions))
|
||||||
(inits (append-map (lambda (c)
|
(if (null? conditions)
|
||||||
(let ((ct (condition-type c)))
|
'()
|
||||||
(map (lambda (f)
|
(let ((c (car conditions))
|
||||||
(condition-ref c f))
|
(conditions (cdr conditions)))
|
||||||
(condition-type-all-fields ct))))
|
(cond
|
||||||
conditions)))
|
((compound-condition? c)
|
||||||
(make-condition-from-values ct inits)))
|
(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)
|
(define (extract-condition c type)
|
||||||
"Return a condition of condition type TYPE with the field values specified
|
"Return a condition of condition type TYPE with the field values specified
|
||||||
by C."
|
by C."
|
||||||
|
(unless (condition-type? type)
|
||||||
(define (first-field-index parents)
|
(scm-error 'wrong-type-arg "extract-condition" "Not a condition type: ~S"
|
||||||
;; Return the index of the first field of TYPE within C.
|
(list type) #f))
|
||||||
(let loop ((parents parents)
|
(match c
|
||||||
(index 0))
|
(($ &compound-condition conditions)
|
||||||
(let ((parent (car parents)))
|
(or-map (lambda (c) (extract-condition c type))
|
||||||
(cond ((null? parents)
|
conditions))
|
||||||
#f)
|
((? simple-condition?)
|
||||||
((eq? parent type)
|
(and ((record-predicate type) c)
|
||||||
index)
|
c))
|
||||||
((pair? parent)
|
(_
|
||||||
(or (loop parent index)
|
(scm-error 'wrong-type-arg "extract-condition" "Not a condition: ~S"
|
||||||
(loop (cdr parents)
|
(list c) #f))))
|
||||||
(+ 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")))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -304,11 +220,6 @@ by C."
|
||||||
(condition-ref c 'field-name))
|
(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
|
(define-syntax condition-instantiation
|
||||||
;; Build the `(make-condition type ...)' call.
|
;; Build the `(make-condition type ...)' call.
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
|
|
@ -322,21 +233,14 @@ by C."
|
||||||
((_ (type field ...))
|
((_ (type field ...))
|
||||||
(condition-instantiation type () field ...))
|
(condition-instantiation type () field ...))
|
||||||
((_ (type field ...) ...)
|
((_ (type field ...) ...)
|
||||||
(compound-condition (type ...) (field ... ...)))))
|
(make-compound-condition (condition-instantiation type () field ...)
|
||||||
|
...))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Standard condition types.
|
;;; 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
|
(define-condition-type &message &condition
|
||||||
message-condition?
|
message-condition?
|
||||||
(message condition-message))
|
(message condition-message))
|
||||||
|
|
|
||||||
|
|
@ -203,7 +203,7 @@
|
||||||
|
|
||||||
(define v3
|
(define v3
|
||||||
(condition (&c1 (x "V3/1") (a "a3"))
|
(condition (&c1 (x "V3/1") (a "a3"))
|
||||||
(&c2 (b "b3"))))
|
(&c2 (x #f) (b "b3"))))
|
||||||
|
|
||||||
(define v4
|
(define v4
|
||||||
(make-compound-condition v1 v2))
|
(make-compound-condition v1 v2))
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue