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

Last change on this file since 35972 was 35972, checked in by Kon Lovett, 2 years ago

exn own mod

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;;
33
34; Signaled on errors.
35(define exn-condition? (condition-predicate* 'exn))
36
37(define exn-location (make-condition-property-accessor exn location))
38(define exn-message (make-condition-property-accessor exn message))
39(define exn-arguments (make-condition-property-accessor exn arguments))
40(define exn-call-chain (make-condition-property-accessor exn call-chain))
41
42;;
43
44(: make-exn-condition (#!optional (or boolean symbol) (or boolean string) (or boolean list) (or boolean list) --> condition))
45;
46(define (make-exn-condition #!optional (loc #f) (msg "unknown") (args #f) (chain #f))
47  (let (
48    (if@ (lambda (tag val) (if val `(,tag ,val) '()))) )
49    (apply make-property-condition 'exn
50      (append!
51        (if@ 'location    loc)
52        (if@ 'message     (or msg "unknown"))
53        (if@ 'arguments   args)
54        (if@ 'call-chain  chain))) ) )
55
56;;
57
58(: make-exn-condition+ ((or boolean symbol) (or boolean string) #!rest -> condition))
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(: write-exn-condition (condition #!optional output-port string string -> void))
71;
72;from 'write-exception' of https://github.com/dleslie/geiser/blob/master/scheme/chicken/geiser/emacs.scm
73(define (write-exn-condition cnd
74            #!optional
75            (port (current-output-port))
76            (header "Error")
77            (chain-header "\n\tCall history:\n"))
78  ;exn portion
79  (print-error-message cnd port header)
80  ;rest of the composite condition (if any)
81  (write-condition-list (cdr (condition->list cnd)) port header)
82  ;call-chain?
83  (and-let* (
84    (chain ((condition-property-accessor 'exn 'call-chain #f) cnd)) )
85    (write-call-chain chain port chain-header) )
86  ;no abstraction leakage
87  (void) )
88
89) ;module exn-condition
Note: See TracBrowser for help on using the repository browser.