source: project/release/3/misc-extn/tags/3.1/misc-extn-control-support.scm @ 8075

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

Rel 3.1, adds -directory stuff.

File size: 1.4 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    (usual-integrations)
9    (fixnum)
10    (inline)
11    (no-procedure-checks)
12    (no-bound-checks)
13    (export
14      assure
15      identify-error
16      errorf) ) )
17
18;;; Error Invocation
19
20;; Error unless expression not false
21
22(define (assure exp . err-args)
23        (or exp
24            (apply error err-args)))
25
26;; Print error message but don't throw an exception
27
28(define (identify-error msg . args)
29  (with-output-to-port (current-error-port)
30    (lambda ()
31      (display "Error: ")
32      (when (symbol? msg)
33        (let ([caller msg])
34          (set! msg
35            (let ([msg (and (pair? args) (car args))])
36              (when msg
37                (set! args (cdr args)))
38              msg))
39          (display "(") (display caller) (display ") ")))
40      (when msg
41        (display msg))
42      (unless (null? args)
43        (for-each (lambda (arg) (newline) (write arg)) args))
44      (newline))) )
45
46;; Printf version of error
47
48(define (errorf format-string . rest)
49  (let ([loc #f])
50    (when (symbol? format-string)
51      (set! loc format-string)
52      (if (null? rest)
53          (set! format-string #f)
54          (begin
55            (set! format-string (car rest))
56            (set! rest (cdr rest)) ) ) )
57    (if format-string
58        (error loc (apply format format-string rest))
59        (error loc) ) ) )
Note: See TracBrowser for help on using the repository browser.