source: project/misc-extn/trunk/misc-extn-control-support.scm @ 5438

Last change on this file since 5438 was 5438, checked in by Kon Lovett, 12 years ago

Added misc-extn extension element.

File size: 1.3 KB
Line 
1;;;; misc-extn-control-support.scm
2;;;; Kon Lovett, Jul '07
3
4(use srfi-1)
5
6(eval-when (compile)
7  (declare
8    (fixnum)
9    (inline)
10    (no-procedure-checks)
11    (no-bound-checks)
12    (export
13      assure identify-error errorf) ) )
14
15;;; Error Invocation
16
17;; Error unless expression not false
18
19(define (assure exp . err-args)
20        (or exp (apply error err-args)))
21
22;; Print error message but don't throw an exception
23
24(define (identify-error msg . args)
25  (with-output-to-port (current-error-port)
26    (lambda ()
27      (display "Error: ")
28      (when (symbol? msg)
29        (let ([caller msg])
30          (set! msg
31            (let ([msg (and (pair? args) (car args))])
32              (when msg
33                (set! args (cdr args)))
34              msg))
35          (display "(") (display caller) (display ") ")))
36      (when msg
37        (display msg))
38      (unless (null? args)
39        (for-each (lambda (arg) (newline) (write arg)) args))
40      (newline))) )
41
42;; Printf version of error
43
44(define (errorf format-string . rest)
45  (let ([loc #f])
46    (when (symbol? format-string)
47      (set! loc format-string)
48      (if (null? rest)
49        (set! format-string #f)
50        (begin
51          (set! format-string (car rest))
52          (set! rest (cdr rest)) ) ) )
53    (if format-string
54      (error loc (apply format format-string rest))
55      (error loc) ) ) )
Note: See TracBrowser for help on using the repository browser.