source: project/release/5/condition-utils/trunk/condition-utils-support.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.8 KB
Line 
1;;;; condition-utils-support.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(declare
5  (bound-to-procedure ##sys#really-print-call-chain) )
6
7(module condition-utils-support
8
9(;export
10  write-call-chain
11  write-condition-list
12  expand-property-conditions)
13
14(import scheme
15  (chicken base)
16  (chicken fixnum)
17  (chicken condition)
18  (chicken syntax)
19  (chicken type)
20  (only (chicken string) ->string)
21  (only (chicken format) format)
22  (only (chicken port) call-with-output-string)
23  (only (srfi 69) make-hash-table hash-table-ref/default hash-table-set!)
24  (only (srfi 1) concatenate)
25  (only type-errors error-argument-type))
26
27;;;
28
29;; Interpret condition expression
30
31;; <condition>  ->  <condition>
32;; <symbol>     ->  (make-property-condition <symbol>)
33;; <pair>       ->  (apply make-property-condition <pair>)
34;;
35;; (<symbol> [<symbol> <object>]...)
36
37(: expand-property-conditions ((list-of (or condition symbol pair)) -> (list-of condition)))
38;
39(define (expand-property-conditions cnds)
40  (map
41    (lambda (x)
42      (cond
43        ((condition? x)
44          x )
45        ((symbol? x)
46          (make-property-condition x) )
47        ((list? x)
48          (apply make-property-condition x) )
49        (else
50          (error-argument-type
51            'expand-property-conditions
52            x 'condition-expression "cond-parm") ) ) )
53    cnds) )
54
55;;
56
57(: write-call-chain (list output-port string -> void))
58;
59(define (write-call-chain chain port header)
60  (##sys#really-print-call-chain port chain header) )
61
62#; ;using builtin
63(define (write-call-chain chain port header)
64  ;
65  (define (write-call-entry call)
66    (let (
67      (type (vector-ref call 0))
68      (line (vector-ref call 1)) )
69      (write-type-item type line header) ) )
70  ;
71  (define (write-type-item type line header)
72    (format port "~A~A\t  ~S~%" header type line) )
73  ;
74  (for-each write-call-entry chain)
75  (newline port) )
76
77;;
78
79(: write-condition-list ((list-of pair) output-port string -> string))
80;
81(define (write-condition-list cnds port header)
82  (let (
83    (leader (string-append (subheader-string header) ": ")) )
84    (for-each
85      (lambda (cnd-info)
86        (let (
87          (kind (car cnd-info))
88          (args (cdr cnd-info)) )
89          (format port "~A~A:~A~%"
90            leader kind
91            (call-with-output-string
92              (lambda (p) (for-each (cut format p " ~S" <>) args)))) ) )
93      cnds) ) )
94
95;;
96
97#; ;UNUSED
98(define (exn-prop->string prop)
99  (condition-property->string cnd 'exn prop) )
100
101#; ;UNUSED
102(define (write-error-message cnd port header)
103  (format port "~%~A(~A) ~A: ~A~%"
104    header
105    (exn-prop->string 'location)
106    (exn-prop->string 'message)
107    (exn-prop->string 'arguments)) )
108
109;;
110
111(define (subheader-string header)
112  (string-append (make-string (fx- (string-length header) 1) #\space) "+") )
113
114) ;module condition-utils
Note: See TracBrowser for help on using the repository browser.