source: project/release/5/condition-utils/trunk/exn-condition.scm @ 38965

Last change on this file since 38965 was 38965, checked in by Kon Lovett, 8 weeks ago

add -strict-types, remove redudant -local, update test runner, type is interface

File size: 2.4 KB
Line 
1;;;; exn-condition.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(declare
5  (bound-to-procedure ##sys#really-print-call-chain) )
6
7(module exn-condition
8
9(;export
10  ;
11  exn-condition?
12  exn-location
13  exn-message
14  exn-arguments
15  exn-call-chain
16  ;
17  make-exn-condition
18  make-exn-condition+
19  ;
20  write-exn-condition)
21
22(import scheme
23  (chicken base)
24  (chicken condition)
25  (chicken type)
26  (only (srfi 1) append!)
27  condition-utils-support
28  condition-utils)
29
30;;
31
32(: make-exn-condition (#!optional (or boolean symbol) (or boolean string) (or boolean list) (or boolean list) --> condition))
33(: make-exn-condition+ ((or boolean symbol) (or boolean string) #!rest -> condition))
34(: write-exn-condition (condition #!optional output-port string string -> void))
35
36;;
37
38; Signaled on errors.
39(define exn-condition? (condition-predicate* 'exn))
40
41(define exn-location (make-condition-property-accessor exn location))
42(define exn-message (make-condition-property-accessor exn message))
43(define exn-arguments (make-condition-property-accessor exn arguments))
44(define exn-call-chain (make-condition-property-accessor exn call-chain))
45
46;;
47
48(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (chain #f))
49  (let (
50    (if@ (lambda (tag val) (if val `(,tag ,val) '()))) )
51    (apply make-property-condition 'exn
52      (append!
53        (if@ 'location    loc)
54        (if@ 'message     (or msg "unknown"))
55        (if@ 'arguments   args)
56        (if@ 'call-chain  chain))) ) )
57
58;;
59
60(define (make-exn-condition+ loc msg args . cnds)
61  (let* (
62    (chn (and (pair? cnds) (call-chain? (car cnds)) (car cnds)))
63    (cnds (if chn (cdr cnds) cnds)) )
64    (apply make-composite-condition
65      (make-exn-condition loc msg args chn)
66      (expand-property-conditions cnds)) ) )
67
68;;
69
70;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
71(define (write-exn-condition cnd
72            #!optional
73            (port (current-output-port))
74            (header "Error")
75            (chain-header "\n\tCall history:\n"))
76  ;exn portion
77  (print-error-message cnd port header)
78  ;rest of the composite condition (if any)
79  (write-condition-list (cdr (condition->list cnd)) port header)
80  ;call-chain?
81  (and-let* (
82    (chain ((condition-property-accessor 'exn 'call-chain #f) cnd)) )
83    (write-call-chain chain port chain-header) )
84  ;no abstraction leakage
85  (void) )
86
87) ;module exn-condition
Note: See TracBrowser for help on using the repository browser.