;;; Ikarus Scheme -- A compiler for R6RS Scheme. ;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum ;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License version 3 as ;;; published by the Free Software Foundation. ;;; ;;; This program is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. (library (ikarus conditions) (export condition? simple-conditions condition-predicate condition condition-accessor print-condition ;;; too much junk make-message-condition message-condition? condition-message make-warning warning? make-serious-condition serious-condition? make-error error? make-violation violation? make-assertion-violation assertion-violation? make-irritants-condition irritants-condition? condition-irritants make-who-condition who-condition? condition-who make-non-continuable-violation non-continuable-violation? make-implementation-restriction-violation implementation-restriction-voilation? make-lexical-violation lexical-violation? make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform make-undefined-violation undefined-violation? make-i/o-error i/o-error? make-i/o-read-error i/o-read-error? make-i/o-write-error i/o-write-error? make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position make-i/o-filename-error i/o-filename-error? i/o-error-filename make-i/o-file-protection-error i/o-file-protection-error? make-i/o-file-is-read-only-error i/o-file-is-read-only-error? make-i/o-file-already-exists-error i/o-file-already-exists-error? make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error? make-i/o-port-error i/o-port-error? i/o-error-port make-i/o-decoding-error i/o-decoding-error? make-i/o-encoding-error i/o-encoding-error? i/o-encoding-error-char no-infinities-violation? make-no-infinities-violation no-nans-violation? make-no-nans-violation &condition-rtd &condition-rcd &message-rtd &message-rcd &warning-rtd &warning-rcd &serious-rtd &serious-rcd &error-rtd &error-rcd &violation-rtd &violation-rcd &assertion-rtd &assertion-rcd &irritants-rtd &irritants-rcd &who-rtd &who-rcd &non-continuable-rtd &non-continuable-rcd &implementation-restriction-rtd &implementation-restriction-rcd &lexical-rtd &lexical-rcd &syntax-rtd &syntax-rcd &undefined-rtd &undefined-rcd &i/o-rtd &i/o-rcd &i/o-read-rtd &i/o-read-rcd &i/o-write-rtd &i/o-write-rcd &i/o-invalid-position-rtd &i/o-invalid-position-rcd &i/o-filename-rtd &i/o-filename-rcd &i/o-file-protection-rtd &i/o-file-protection-rcd &i/o-file-is-read-only-rtd &i/o-file-is-read-only-rcd &i/o-file-already-exists-rtd &i/o-file-already-exists-rcd &i/o-file-does-not-exist-rtd &i/o-file-does-not-exist-rcd &i/o-port-rtd &i/o-port-rcd &i/o-decoding-rtd &i/o-decoding-rcd &i/o-encoding-rtd &i/o-encoding-rcd &no-infinities-rtd &no-infinities-rcd &no-nans-rtd &no-nans-rcd ) (import (rnrs records inspection) (rnrs records procedural) (only (rnrs) record-type-descriptor record-constructor-descriptor record-predicate) (only (ikarus records procedural) rtd? rtd-subtype?) (except (ikarus) define-condition-type condition? simple-conditions condition condition-predicate condition-accessor print-condition ;;; more junk &condition &message &warning &serious &error &violation &assertion &irritants &who &non-continuable &implementation-restriction &lexical &syntax &undefined &i/o &i/o-read &i/o-write &i/o-invalid-position &i/o-filename &i/o-file-protection &i/o-file-is-read-only &i/o-file-already-exists &i/o-file-does-not-exist &i/o-port &i/o-decoding &i/o-encoding &no-infinities &no-nans make-message-condition message-condition? condition-message make-warning warning? make-serious-condition serious-condition? make-error error? make-violation violation? make-assertion-violation assertion-violation? make-irritants-condition irritants-condition? condition-irritants make-who-condition who-condition? condition-who make-non-continuable-violation non-continuable-violation? make-implementation-restriction-violation implementation-restriction-voilation? make-lexical-violation lexical-violation? make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform make-undefined-violation undefined-violation? make-i/o-error i/o-error? make-i/o-read-error i/o-read-error? make-i/o-write-error i/o-write-error? make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position make-i/o-filename-error i/o-filename-error? i/o-error-filename make-i/o-file-protection-error i/o-file-protection-error? make-i/o-file-is-read-only-error i/o-file-is-read-only-error? make-i/o-file-already-exists-error i/o-file-already-exists-error? make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error? make-i/o-port-error i/o-port-error? i/o-error-port make-i/o-decoding-error i/o-decoding-error? make-i/o-encoding-error i/o-encoding-error? i/o-encoding-error-char no-infinities-violation? make-no-infinities-violation no-nans-violation? make-no-nans-violation )) (define-record-type &condition (nongenerative)) (define &condition-rtd (record-type-descriptor &condition)) (define &condition-rcd (record-constructor-descriptor &condition)) (define-record-type compound-condition (nongenerative) (fields (immutable components)) (sealed #t) (opaque #t)) (define (condition? x) (or (&condition? x) (compound-condition? x))) (define condition (case-lambda [() (make-compound-condition '())] [(x) (if (condition? x) x (error 'condition "not a condition type" x))] [x* (let ([ls (let f ([x* x*]) (cond [(null? x*) '()] [(&condition? (car x*)) (cons (car x*) (f (cdr x*)))] [(compound-condition? (car x*)) (append (simple-conditions (car x*)) (f (cdr x*)))] [else (error 'condition "not a condition" (car x*))]))]) (cond [(null? ls) (make-compound-condition '())] [(null? (cdr ls)) (car ls)] [else (make-compound-condition ls)]))])) (define (simple-conditions x) (cond [(compound-condition? x) (compound-condition-components x)] [(&condition? x) (list x)] [else (error 'simple-conditions "not a condition" x)])) (define (condition-predicate rtd) (unless (rtd? rtd) (error 'condition-predicate "not a record type descriptor" rtd)) (unless (rtd-subtype? rtd (record-type-descriptor &condition)) (error 'condition-predicate "not a descendant of &condition" rtd)) (let ([p? (record-predicate rtd)]) (lambda (x) (or (p? x) (and (compound-condition? x) (let f ([ls (compound-condition-components x)]) (and (pair? ls) (or (p? (car ls)) (f (cdr ls)))))))))) (define (condition-accessor rtd proc) (unless (rtd? rtd) (error 'condition-accessor "not a record type descriptor" rtd)) (unless (procedure? proc) (error 'condition-accessor "not a procedure" proc)) (unless (rtd-subtype? rtd (record-type-descriptor &condition)) (error 'condition-accessor "not a descendant of &condition" rtd)) (let ([p? (record-predicate rtd)]) (lambda (x) (cond [(p? x) (proc x)] [(compound-condition? x) (let f ([ls (compound-condition-components x)]) (cond [(pair? ls) (if (p? (car ls)) (proc (car ls)) (f (cdr ls)))] [else (error 'condition-accessor "not a condition of correct type" x rtd)]))] [else (error 'condition-accessor "not a condition of correct type" x rtd)])))) (define-syntax define-condition-type (lambda (x) (define (mkname name suffix) (datum->syntax name (string->symbol (string-append (symbol->string (syntax->datum name)) suffix)))) (syntax-case x () [(ctxt name super constructor predicate (field* accessor*) ...) (and (identifier? #'name) (identifier? #'super) (identifier? #'constructor) (identifier? #'predicate) (andmap identifier? #'(field* ...)) (andmap identifier? #'(accessor* ...))) (with-syntax ([(aux-accessor* ...) (generate-temporaries #'(accessor* ...))] [rtd (mkname #'name "-rtd")] [rcd (mkname #'name "-rcd")]) #'(begin (define-record-type (name constructor p?) (parent super) (fields (immutable field* aux-accessor*) ...) (nongenerative) (sealed #f) (opaque #f)) (define predicate (condition-predicate (record-type-descriptor name))) (define accessor* (condition-accessor (record-type-descriptor name) aux-accessor*)) ... (define rtd (record-type-descriptor name)) (define rcd (record-constructor-descriptor name))))]))) (define-condition-type &message &condition make-message-condition message-condition? (message condition-message)) (define-condition-type &warning &condition make-warning warning?) (define-condition-type &serious &condition make-serious-condition serious-condition?) (define-condition-type &error &serious make-error error?) (define-condition-type &violation &serious make-violation violation?) (define-condition-type &assertion &violation make-assertion-violation assertion-violation?) (define-condition-type &irritants &condition make-irritants-condition irritants-condition? (irritants condition-irritants)) (define-condition-type &who &condition make-who-condition who-condition? (who condition-who)) (define-condition-type &non-continuable &violation make-non-continuable-violation non-continuable-violation?) (define-condition-type &implementation-restriction &violation make-implementation-restriction-violation implementation-restriction-voilation?) (define-condition-type &lexical &violation make-lexical-violation lexical-violation?) (define-condition-type &syntax &violation make-syntax-violation syntax-violation? (form syntax-violation-form) (subform syntax-violation-subform)) (define-condition-type &undefined &violation make-undefined-violation undefined-violation?) (define-condition-type &i/o &error make-i/o-error i/o-error?) (define-condition-type &i/o-read &i/o make-i/o-read-error i/o-read-error?) (define-condition-type &i/o-write &i/o make-i/o-write-error i/o-write-error?) (define-condition-type &i/o-invalid-position &i/o make-i/o-invalid-position-error i/o-invalid-position-error? (position i/o-error-position)) (define-condition-type &i/o-filename &i/o make-i/o-filename-error i/o-filename-error? (filename i/o-error-filename)) (define-condition-type &i/o-file-protection &i/o make-i/o-file-protection-error i/o-file-protection-error?) (define-condition-type &i/o-file-is-read-only &i/o-file-protection make-i/o-file-is-read-only-error i/o-file-is-read-only-error?) (define-condition-type &i/o-file-already-exists &i/o-filename make-i/o-file-already-exists-error i/o-file-already-exists-error?) (define-condition-type &i/o-file-does-not-exist &i/o-filename make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error?) (define-condition-type &i/o-port &i/o make-i/o-port-error i/o-port-error? (port i/o-error-port)) (define-condition-type &i/o-decoding &i/o-port make-i/o-decoding-error i/o-decoding-error?) (define-condition-type &i/o-encoding &i/o-port make-i/o-encoding-error i/o-encoding-error? (char i/o-encoding-error-char)) (define-condition-type &no-infinities &implementation-restriction make-no-infinities-violation no-infinities-violation?) (define-condition-type &no-nans &implementation-restriction make-no-nans-violation no-nans-violation?) (define print-condition (let () (define (print-simple-condition x p) (let ([rtd (record-rtd x)]) (let ([name (record-type-name rtd)]) (display name p)) (let ([v (record-type-field-names rtd)]) (case (vector-length v) [(1) (display ": " p) (write ((record-accessor rtd 0) x) p)] [else (let f ([i 0]) (unless (= i (vector-length v)) (display " " p) (display (vector-ref v i) p) (display "=" p) (write ((record-accessor rtd i) x) p) (f (+ i 1))))])) (newline p))) (define (print-condition x p) (cond [(condition? x) (let ([ls (simple-conditions x)]) (if (null? ls) (display "Condition object with no further information\n" p) (begin (display " Condition components:\n" p) (let f ([ls ls] [i 1]) (unless (null? ls) (display " " p) (display i p) (display ". " p) (print-simple-condition (car ls) p) (f (cdr ls) (+ i 1)))))))] [else (display "Non-condition object: " p) (write x p) (newline p)])) (case-lambda [(x) (print-condition x (standard-error-port))] [(x port) (if (output-port? port) (print-condition x port) (error 'print-condition "not an output port" port))]))) ;(let ([p ; (lambda (x p) ; (display "#<condition>" p))]) ; (set-rtd-printer! (record-type-descriptor compound-condition) p)) )