diff options
author | Andy Wingo <wingo@pobox.com> | 2019-10-23 14:25:21 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-10-23 14:42:35 +0200 |
commit | 99a95383cf405ab0284f98adda41ab4989d9a038 (patch) | |
tree | 397dec77a551e1de3ec3fe2973d55edd04f68254 | |
parent | f116bd100915a605ce75d6b4d4b08688a81f1e5b (diff) | |
download | guile-99a95383cf405ab0284f98adda41ab4989d9a038.tar.gz |
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.
-rw-r--r-- | module/srfi/srfi-35.scm | 366 | ||||
-rw-r--r-- | test-suite/tests/srfi-35.test | 2 |
2 files changed, 136 insertions, 232 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)) diff --git a/test-suite/tests/srfi-35.test b/test-suite/tests/srfi-35.test index 5e4cb271e..df73c8442 100644 --- a/test-suite/tests/srfi-35.test +++ b/test-suite/tests/srfi-35.test @@ -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)) |