403 lines
16 KiB
Scheme
403 lines
16 KiB
Scheme
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
|
;;; Copyright (C) 2006,2007,2008 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-violation?
|
|
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
|
|
interrupted-condition? make-interrupted-condition
|
|
|
|
&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
|
|
&interrupted-rtd &interrupted-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-violation?
|
|
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
|
|
|
|
interrupted-condition? make-interrupted-condition
|
|
))
|
|
|
|
(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 #f))
|
|
|
|
(define (condition? x)
|
|
(or (&condition? x)
|
|
(compound-condition? x)))
|
|
|
|
(define condition
|
|
(case-lambda
|
|
[() (make-compound-condition '())]
|
|
[(x)
|
|
(if (condition? x)
|
|
x
|
|
(die '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 (die '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 (die 'simple-conditions "not a condition" x)]))
|
|
|
|
(define (condition-predicate rtd)
|
|
(unless (rtd? rtd)
|
|
(die 'condition-predicate "not a record type descriptor" rtd))
|
|
(unless (rtd-subtype? rtd (record-type-descriptor &condition))
|
|
(die '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)
|
|
(die 'condition-accessor "not a record type descriptor" rtd))
|
|
(unless (procedure? proc)
|
|
(die 'condition-accessor "not a procedure" proc))
|
|
(unless (rtd-subtype? rtd (record-type-descriptor &condition))
|
|
(die '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
|
|
(die 'condition-accessor "not a condition of correct type" x rtd)]))]
|
|
[else
|
|
(die '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-violation?)
|
|
|
|
(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-filename
|
|
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?)
|
|
|
|
;;; ikarus-specific conditions
|
|
(define-condition-type &interrupted &serious
|
|
make-interrupted-condition interrupted-condition?)
|
|
|
|
(define print-condition
|
|
(let ()
|
|
(define (print-simple-condition x p)
|
|
(let* ([rtd (record-rtd x)]
|
|
[rf (let l ([rtd rtd] [accum '()])
|
|
(if rtd
|
|
(l (record-type-parent rtd)
|
|
(cons
|
|
(cons rtd (record-type-field-names rtd))
|
|
accum))
|
|
(remp (lambda (a) (zero? (vector-length (cdr a))))
|
|
accum)))]
|
|
[rf-len (apply + (map vector-length
|
|
(map cdr rf)))])
|
|
(let ([name (record-type-name rtd)])
|
|
(display name p))
|
|
(case rf-len
|
|
[(0) (newline p)]
|
|
[(1)
|
|
(display ": " p)
|
|
(write ((record-accessor (caar rf) 0) x) p)
|
|
(newline p)]
|
|
[else
|
|
(display ":\n" p)
|
|
(for-each
|
|
(lambda (a)
|
|
(let f ([i 0] [rtd (car a)] [v (cdr a)])
|
|
(unless (= i (vector-length v))
|
|
(display " " p)
|
|
(display (vector-ref v i) p)
|
|
(display ": " p)
|
|
(write ((record-accessor rtd i) x) p)
|
|
(newline p)
|
|
(f (+ i 1) rtd v))))
|
|
rf)])))
|
|
(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 (console-output-port))]
|
|
[(x port)
|
|
(if (output-port? port)
|
|
(print-condition x port)
|
|
(die 'print-condition "not an output port" port))])))
|
|
|
|
|
|
)
|
|
|