source: project/release/5/condition-utils/trunk/condition-utils-support.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.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(: expand-property-conditions ((list-of (or condition symbol pair)) -> (list-of condition)))
30(: write-call-chain (list output-port string -> void))
31(: write-condition-list ((list-of pair) output-port string -> string))
32
33;; Interpret condition expression
34
35;; <condition>  ->  <condition>
36;; <symbol>     ->  (make-property-condition <symbol>)
37;; <pair>       ->  (apply make-property-condition <pair>)
38;;
39;; (<symbol> [<symbol> <object>]...)
40
41(define (expand-property-conditions cnds)
42  (map
43    (lambda (x)
44      (cond
45        ((condition? x)
46          x )
47        ((symbol? x)
48          (make-property-condition x) )
49        ((list? x)
50          (apply make-property-condition x) )
51        (else
52          (error-argument-type
53            'expand-property-conditions
54            x 'condition-expression "cond-parm") ) ) )
55    cnds) )
56
57;;
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(define (write-condition-list cnds port header)
80  (let (
81    (leader (string-append (subheader-string header) ": ")) )
82    (for-each
83      (lambda (cnd-info)
84        (let (
85          (kind (car cnd-info))
86          (args (cdr cnd-info)) )
87          (format port "~A~A:~A~%"
88            leader kind
89            (call-with-output-string
90              (lambda (p) (for-each (cut format p " ~S" <>) args)))) ) )
91      cnds) ) )
92
93;;
94
95#; ;UNUSED
96(define (exn-prop->string prop)
97  (condition-property->string cnd 'exn prop) )
98
99#; ;UNUSED
100(define (write-error-message cnd port header)
101  (format port "~%~A(~A) ~A: ~A~%"
102    header
103    (exn-prop->string 'location)
104    (exn-prop->string 'message)
105    (exn-prop->string 'arguments)) )
106
107;;
108
109(define (subheader-string header)
110  (string-append (make-string (fx- (string-length header) 1) #\space) "+") )
111
112) ;module condition-utils
Note: See TracBrowser for help on using the repository browser.