77 lines
1.8 KiB
Scheme
77 lines
1.8 KiB
Scheme
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
|
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
|
|
|
|
|
|
; This is file condition.scm.
|
|
|
|
;;;; Condition hierarchy
|
|
|
|
; General design copied from gnu emacs.
|
|
|
|
(define *condition-types* '())
|
|
|
|
(define (condition-supertypes type)
|
|
(assq type *condition-types*))
|
|
|
|
(define (define-condition-type type supertypes)
|
|
(set! *condition-types*
|
|
(cons (cons type (apply append
|
|
(map (lambda (sup)
|
|
(or (condition-supertypes sup)
|
|
(error "unrecognized condition type"
|
|
sup)))
|
|
supertypes)))
|
|
*condition-types*)))
|
|
|
|
(define (condition-predicate name)
|
|
(lambda (c)
|
|
(and (pair? c)
|
|
(let ((probe (condition-supertypes (car c))))
|
|
(if probe
|
|
(if (memq name probe) #t #f)
|
|
#f)))))
|
|
|
|
(define (condition? x)
|
|
(and (pair? x)
|
|
(list? x)
|
|
(condition-supertypes (car x))))
|
|
(define condition-type car)
|
|
(define condition-stuff cdr)
|
|
|
|
|
|
; Errors
|
|
|
|
(define-condition-type 'error '())
|
|
(define error? (condition-predicate 'error))
|
|
|
|
(define-condition-type 'call-error '(error))
|
|
(define call-error? (condition-predicate 'call-error))
|
|
|
|
(define-condition-type 'read-error '(error))
|
|
(define read-error? (condition-predicate 'read-error))
|
|
|
|
; Exceptions
|
|
|
|
(define-condition-type 'exception '(error))
|
|
(define exception? (condition-predicate 'exception))
|
|
(define exception-opcode cadr)
|
|
(define exception-arguments cddr)
|
|
|
|
(define (make-exception opcode args)
|
|
(make-condition 'exception (cons opcode args)))
|
|
|
|
|
|
; Warnings
|
|
|
|
(define-condition-type 'warning '())
|
|
(define warning? (condition-predicate 'warning))
|
|
|
|
(define-condition-type 'syntax-error '(warning))
|
|
(define syntax-error? (condition-predicate 'syntax-error))
|
|
|
|
|
|
; Interrupts
|
|
|
|
(define-condition-type 'interrupt '())
|
|
(define interrupt? (condition-predicate 'interrupt))
|