source: project/release/4/error-utils/trunk/error-utils.scm @ 34409

Last change on this file since 34409 was 34409, checked in by kon, 11 months ago

bump ver, re-flow

File size: 3.5 KB
Line 
1;;;; error-utils.scm
2;;;; Kon Lovett, Aug '10
3;;;; Kon Lovett, may '17
4
5(module error-utils
6
7(;export
8  ;
9  error/no-raise *error/no-raise
10  ;
11  errorf errorf/no-raise
12  ;
13  error-format-procedure)
14
15(import scheme)
16
17(import chicken)
18
19(import (only extras format))
20(require-library extras)
21
22(import (only data-structures chop ->string string-intersperse) )
23(require-library data-structures)
24
25(import (only (srfi 1) append!) )
26(require-library (srfi 1))
27
28;;;
29
30;; Print error message but don't throw an exception
31;;
32(define (error/no-raise . args)
33  (receive (port args) (error-port-args args)
34    (*error/no-raise args port) ) )
35
36;; Print error-style message to port
37;; unlike 'error' will print arguments when loc but no msg
38;;
39(define (*error/no-raise args #!optional (port (current-error-port)))
40  (receive (loc msg args) (error-params args)
41    (let (
42        (errmsg
43          (string-append
44            "\n"
45            "Error" (if (or loc msg) ": " "")
46            (if (and loc msg) (string-append "(" (->string loc) ")" " ") "")
47            (or (and msg (->string msg)) (and loc (->string loc)) "")
48            (cond
49              ((null? args)
50                "" )
51              ((null? (cdr args))
52                (string-append ": " (->sexpr-string (car args))) )
53              (else
54                ;leading empty string so leading newline
55                (string-intersperse (append '("") (map ->sexpr-string args)) "\n") ) )
56            "\n" )))
57      (display errmsg port) ) ) )
58
59;;
60(define (errorf . args)
61  (*errorf #f error args) )
62
63;;
64(define (errorf/no-raise . args)
65  (receive (port args) (error-port-args args)
66    (*errorf port error/no-raise args) ) )
67
68;; Format procedure for error
69;;
70(define error-format-procedure
71  (make-parameter
72    format
73    (lambda (x)
74      (if (procedure? x)
75        x
76        (begin
77          (warning 'error-format-procedure "invalid procedure" x)
78          (error-format-procedure) ) ) ) ) )
79
80;;;
81
82;;
83(define (*errorf port proc args)
84  (let ((portarg (if port `(,port) '())))
85    (receive (loc fmt fmtargs) (error-params args)
86      (let (
87          (err-args
88            (if (not fmt)
89              (append args portarg)
90              (let ((msg (apply (error-format-procedure) #f fmt fmtargs)))
91                (if loc
92                  (append! `(,loc ,msg) portarg)
93                  (append! `(,msg) portarg) ) ) ) ) )
94        (apply proc err-args) ) ) ) )
95
96;;
97(define (->sexpr-string obj)
98  ((error-format-procedure) #f "~S" obj) )
99
100;; Parse error style argument list into (values loc msg args)
101;;
102(define (error-params args)
103  (let* (
104      (loc
105        (and
106          (not (null? args))
107          (symbol? (car args)) (car args)) )
108      (msg
109        (if (not loc)
110          (and
111            (not (null? args))
112            (string? (car args)) (car args))
113          (and
114            (not (null? (cdr args)))
115            (string? (cadr args)) (cadr args)) ) )
116      (args
117        (if (and loc msg)
118          (cddr args)
119          (if (or loc msg)
120            (cdr args)
121            args ) ) ) )
122    (values loc msg args) ) )
123
124;; Parse error/no-raise style argument list into (values port args)
125;;
126(define (error-port-args args)
127  (let* ((len (length args) )
128         (argls (and (<= 2 len) (chop args (fx- len 1))) )
129         (args (if argls (car argls) args) )
130         (port (and argls (caadr argls)) )
131         (args (if (port? port) args (append args (if port `(,port) '()))) )
132         (port (if (port? port) port (current-error-port)) ) )
133    (values port args) ) )
134
135) ;module error-utils
Note: See TracBrowser for help on using the repository browser.