mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +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:
|
||||
|
||||
(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))
|
||||
;; 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))))))
|
||||
|
||||
(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)))
|
||||
;; FIXME: Perhaps use a `define-record-type' which allows for parent types.
|
||||
(define &condition
|
||||
(make-record-type '&condition '() print-condition #:final? #f))
|
||||
|
||||
;; 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 (make-condition-type id parent field-names)
|
||||
"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."
|
||||
(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."
|
||||
(and (struct? obj)
|
||||
(eq? (struct-vtable obj)
|
||||
%condition-type-vtable)))
|
||||
;; 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 (condition-type-id ct)
|
||||
(and (condition-type? ct)
|
||||
(struct-ref ct (+ vtable-offset-user 0))))
|
||||
(define simple-condition?
|
||||
(record-predicate &condition))
|
||||
|
||||
(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)))
|
||||
|
||||
(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)))))
|
||||
;; 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))
|
||||
|
|
|
|||
|
|
@ -203,7 +203,7 @@
|
|||
|
||||
(define v3
|
||||
(condition (&c1 (x "V3/1") (a "a3"))
|
||||
(&c2 (b "b3"))))
|
||||
(&c2 (x #f) (b "b3"))))
|
||||
|
||||
(define v4
|
||||
(make-compound-condition v1 v2))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue